module flow_accumulation_algorithm_mod
use subfield_mod
use coords_mod
use doubly_linked_list_mod
implicit none

type, abstract :: flow_accumulation_algorithm
  private
    class(subfield), pointer :: dependencies => null()
    class(subfield), pointer :: cumulative_flow => null()
    type(doubly_linked_list) :: q
    class(coords), pointer :: links(:)
    class(coords),pointer :: external_data_value
    class(coords),pointer :: flow_terminates_value
    class(coords),pointer :: no_data_value
    class(coords),pointer :: no_flow_value
  contains
    private
    procedure :: init_flow_accumulation_algorithm
    procedure, public :: generate_cumulative_flow
    procedure :: set_dependencies
    procedure :: add_cells_to_queue
    procedure :: process_queue
    procedure :: follow_paths
    procedure :: get_external_flow_value
    procedure :: get_flow_terminates_value
    procedure :: get_no_data_value
    procedure :: get_no_flow_value
    procedure, public :: destructor
    procedure(get_next_cell_coords), deferred :: get_next_cell_coords
    procedure(generate_coords_index), deferred :: generate_coords_index
    procedure(assign_coords_to_link_array), deferred :: assign_coords_to_link_array
end type flow_accumulation_algorithm

abstract interface
  function generate_coords_index(this,coords_in) result(index)
    import flow_accumulation_algorithm
    import coords
    class(flow_accumulation_algorithm), intent(in) :: this
    class(coords), pointer, intent(in) :: coords_in
    integer :: index
  end function generate_coords_index

  subroutine assign_coords_to_link_array(this,coords_index,coords_in)
    import flow_accumulation_algorithm
    import coords
    class(flow_accumulation_algorithm), intent(inout) :: this
    class(coords), pointer :: coords_in
    integer :: coords_index
  end subroutine assign_coords_to_link_array

  function get_next_cell_coords(this,coords_in) result(next_cell_coords)
    import flow_accumulation_algorithm
    import coords
    class(flow_accumulation_algorithm), intent(in) :: this
    class(coords), pointer :: coords_in
    class(coords), pointer :: next_cell_coords
  end function get_next_cell_coords
end interface

type, extends(flow_accumulation_algorithm) :: latlon_flow_accumulation_algorithm
  private
    integer :: tile_min_lat
    integer :: tile_max_lat
    integer :: tile_min_lon
    integer :: tile_max_lon
    integer :: tile_width_lat
    integer :: tile_width_lon
    class(subfield), pointer :: next_cell_index_lat => null()
    class(subfield), pointer :: next_cell_index_lon => null()
    class(subfield), pointer :: river_directions => null()
  contains
    procedure :: generate_coords_index => latlon_generate_coords_index
    procedure :: assign_coords_to_link_array => latlon_assign_coords_to_link_array
    procedure :: get_next_cell_coords => latlon_get_next_cell_coords
end type latlon_flow_accumulation_algorithm

type, extends(flow_accumulation_algorithm) :: icon_single_index_flow_accumulation_algorithm
  private
    class(subfield), pointer :: next_cell_index => null()
  contains
    procedure :: icon_single_index_init_flow_accumulation_algorithm
    procedure :: icon_single_index_destructor
    procedure :: generate_coords_index => icon_single_index_generate_coords_index
    procedure :: assign_coords_to_link_array => icon_single_index_assign_coords_to_link_array
    procedure :: get_next_cell_coords => icon_single_index_get_next_cell_coords
end type icon_single_index_flow_accumulation_algorithm

interface icon_single_index_flow_accumulation_algorithm
  procedure :: icon_single_index_flow_accumulation_algorithm_constructor
end interface icon_single_index_flow_accumulation_algorithm

contains

subroutine init_flow_accumulation_algorithm(this)
  class(flow_accumulation_algorithm), intent(inout) :: this
    call this%dependencies%set_all(0)
    call this%cumulative_flow%set_all(0)
end subroutine init_flow_accumulation_algorithm

subroutine latlon_init_flow_accumulation_algorithm(this)
  class(latlon_flow_accumulation_algorithm), intent(inout) :: this
    allocate(this%external_data_value,source=latlon_coords(-1,-1))
    allocate(this%flow_terminates_value,source=latlon_coords(-2,-2))
    allocate(this%no_data_value,source=latlon_coords(-3,-3))
    allocate(this%no_flow_value,source=latlon_coords(-4,-4))
end subroutine latlon_init_flow_accumulation_algorithm

subroutine icon_single_index_init_flow_accumulation_algorithm(this,field_section_coords, &
                                                              next_cell_index, &
                                                              cumulative_flow)
  class(icon_single_index_flow_accumulation_algorithm), intent(inout) :: this
  class(*), dimension(:), pointer, intent(in) :: next_cell_index
  class(*), dimension(:), pointer, intent(out) :: cumulative_flow
  type(generic_1d_section_coords), intent(in) :: field_section_coords
  class(*), dimension(:), pointer :: dependencies_data
    this%next_cell_index => icon_single_index_subfield(next_cell_index,field_section_coords)
    this%cumulative_flow => icon_single_index_subfield(cumulative_flow,field_section_coords)
    allocate(integer::dependencies_data(size(next_cell_index)))
    this%dependencies => icon_single_index_subfield(dependencies_data, &
                                                    field_section_coords)
    allocate(this%external_data_value,source=generic_1d_coords(-2,.true.))
    allocate(this%flow_terminates_value,source=generic_1d_coords(-3,.true.))
    allocate(this%no_data_value,source=generic_1d_coords(-4,.true.))
    allocate(this%no_flow_value,source=generic_1d_coords(-5,.true.))
    call this%init_flow_accumulation_algorithm()
end subroutine icon_single_index_init_flow_accumulation_algorithm

function icon_single_index_flow_accumulation_algorithm_constructor(field_section_coords, &
                                                                   next_cell_index, &
                                                                   cumulative_flow) &
                                                                   result(constructor)
  class(*), dimension(:), pointer, intent(in) :: next_cell_index
  class(*), dimension(:), pointer, intent(out) :: cumulative_flow
  type(generic_1d_section_coords), intent(in) :: field_section_coords
  type(icon_single_index_flow_accumulation_algorithm) :: constructor
    call constructor%icon_single_index_init_flow_accumulation_algorithm(field_section_coords, &
                                                                        next_cell_index, &
                                                                        cumulative_flow)
end function icon_single_index_flow_accumulation_algorithm_constructor

subroutine destructor(this)
  class(flow_accumulation_algorithm), intent(inout) :: this
    call this%dependencies%destructor()
    deallocate(this%dependencies)
    deallocate(this%cumulative_flow)
    deallocate(this%external_data_value)
    deallocate(this%flow_terminates_value)
    deallocate(this%no_data_value)
    deallocate(this%no_flow_value)
    call this%q%destructor()
end subroutine destructor

subroutine icon_single_index_destructor(this)
  class(icon_single_index_flow_accumulation_algorithm), intent(inout) :: this
    deallocate(this%next_cell_index)
    call this%destructor
end subroutine

subroutine generate_cumulative_flow(this,set_links)
  class(flow_accumulation_algorithm), intent(inout) :: this
  logical, intent(in) :: set_links
    call this%dependencies%for_all(set_dependencies_wrapper,this)
    call this%dependencies%for_all(add_cells_to_queue_wrapper,this)
    call this%process_queue()
    if (set_links) call this%dependencies%for_all_edge_cells(follow_paths_wrapper,this)
end subroutine generate_cumulative_flow

subroutine set_dependencies_wrapper(this,coords_in)
  class(*), intent(inout) :: this
  class(coords), pointer, intent(inout) :: coords_in
    select type(this)
      class is (flow_accumulation_algorithm)
        call this%set_dependencies(coords_in)
    end select
end subroutine set_dependencies_wrapper

subroutine set_dependencies(this,coords_in)
  class(flow_accumulation_algorithm), intent(inout) :: this
  class(coords), pointer, intent(inout) :: coords_in
  class(coords),pointer :: target_coords
  class(coords),pointer :: target_of_target_coords
  class(*), pointer  :: dependency_ptr
    if ( .not. (coords_in%are_equal_to(this%get_no_data_value()) .or. &
                coords_in%are_equal_to(this%get_no_flow_value()) .or. &
                coords_in%are_equal_to(this%get_flow_terminates_value()) )) then
      target_coords => this%get_next_cell_coords(coords_in)
      if ( target_coords%are_equal_to(this%get_no_data_value()) ) then
        call this%cumulative_flow%set_value(coords_in,this%get_no_data_value())
      else if ( target_coords%are_equal_to(this%get_no_flow_value())) then
        call this%cumulative_flow%set_value(coords_in,this%get_no_flow_value())
      else if ( .not. target_coords%are_equal_to(this%get_flow_terminates_value())) then
        target_of_target_coords => this%get_next_cell_coords(target_coords)
        if ( .not. (target_of_target_coords%are_equal_to(this%get_no_flow_value()) .or. &
                    target_of_target_coords%are_equal_to(this%get_no_data_value()) )) then
          dependency_ptr => this%dependencies%get_value(target_coords)
          select type (dependency_ptr)
            type is (integer)
              call this%dependencies%set_value(target_coords, &
                                               dependency_ptr+1)
          end select
          deallocate(dependency_ptr)
        end if
        deallocate(target_of_target_coords)
      end if
      deallocate(target_coords)
    end if
    deallocate(coords_in)
end subroutine set_dependencies

subroutine add_cells_to_queue_wrapper(this,coords_in)
  class(*), intent(inout) :: this
  class(coords), pointer, intent(inout) :: coords_in
    select type(this)
    class is (flow_accumulation_algorithm)
      call this%add_cells_to_queue(coords_in)
    end select
end subroutine add_cells_to_queue_wrapper

subroutine add_cells_to_queue(this,coords_in)
  class(flow_accumulation_algorithm), intent(inout) :: this
  class(coords), pointer, intent(inout) :: coords_in
  class(coords), pointer :: target_coords
  class(*), pointer  :: dependency_ptr
  target_coords => this%get_next_cell_coords(coords_in)
  dependency_ptr => this%dependencies%get_value(coords_in)
  select type (dependency_ptr)
    type is (integer)
    if (  dependency_ptr == 0 .and. &
         ( .not. target_coords%are_equal_to(this%get_no_data_value()) ) ) then
      call this%q%add_value_to_back(coords_in)
      if ( .not. target_coords%are_equal_to(this%get_flow_terminates_value())) then
        call this%cumulative_flow%set_value(coords_in,1)
      end if
    end if
  end select
  deallocate(coords_in)
  deallocate(dependency_ptr)
  deallocate(target_coords)
end subroutine add_cells_to_queue

subroutine process_queue(this)
  class(flow_accumulation_algorithm), intent(inout) :: this
  class(coords), pointer :: current_coords
  class(*),      pointer :: current_coords_ptr
  class(coords), pointer :: target_coords
  class(coords), pointer :: target_of_target_coords
  class(*), pointer :: cumulative_flow_current_coords_ptr
  class(*), pointer :: cumulative_flow_target_coords_ptr
  class(*), pointer :: dependency_ptr
  integer :: dependency
  do while ( .not. this%q%iterate_forward() )
    current_coords_ptr => this%q%get_value_at_iterator_position()
    select type(current_coords_ptr)
      class is (coords)
        current_coords => current_coords_ptr
    end select
    target_coords => this%get_next_cell_coords(current_coords)
    if ( target_coords%are_equal_to(this%get_no_data_value()) .or. &
         target_coords%are_equal_to(this%get_no_flow_value()) .or. &
         target_coords%are_equal_to(this%get_flow_terminates_value())) then
      call this%q%remove_element_at_iterator_position()
      deallocate(target_coords)
      cycle
    end if
    target_of_target_coords => this%get_next_cell_coords(target_coords)
    if ( target_of_target_coords%are_equal_to(this%get_no_data_value())) then
      call this%q%remove_element_at_iterator_position()
      deallocate(target_of_target_coords)
      cycle
    end if
    deallocate(target_of_target_coords)
    dependency_ptr => this%dependencies%get_value(target_coords)
    select type (dependency_ptr)
      type is (integer)
      dependency = dependency_ptr - 1
    end select
    deallocate(dependency_ptr)
    call this%dependencies%set_value(target_coords, &
                                     dependency)
    cumulative_flow_target_coords_ptr => this%cumulative_flow%get_value(target_coords)
    cumulative_flow_current_coords_ptr => this%cumulative_flow%get_value(current_coords)
    call this%q%remove_element_at_iterator_position()
    select type (cumulative_flow_target_coords_ptr)
      type is (integer)
        select type(cumulative_flow_current_coords_ptr)
          type is (integer)
            if (dependency == 0 .and. .not. &
                target_coords%are_equal_to(this%get_flow_terminates_value())) then
              call this%cumulative_flow%set_value(target_coords, &
                                                  cumulative_flow_target_coords_ptr + &
                                                  cumulative_flow_current_coords_ptr + 1)
              call this%q%add_value_to_back(target_coords)
            else
              call this%cumulative_flow%set_value(target_coords, &
                                                  cumulative_flow_target_coords_ptr + &
                                                  cumulative_flow_current_coords_ptr)
            end if
        end select
      end select
      deallocate(target_coords)
      deallocate(cumulative_flow_target_coords_ptr)
      deallocate(cumulative_flow_current_coords_ptr)
  end do
end subroutine process_queue

subroutine follow_paths_wrapper(this,initial_coords)
  class(*), intent(inout) :: this
  class(coords), pointer, intent(inout) :: initial_coords
    select type(this)
    class is (flow_accumulation_algorithm)
      call this%follow_paths(initial_coords)
    end select
end subroutine follow_paths_wrapper

subroutine follow_paths(this,initial_coords)
  class(flow_accumulation_algorithm), intent(inout) :: this
  class(coords), pointer, intent(inout) :: initial_coords
  class(coords), pointer :: current_coords
  class(coords), pointer :: target_coords
  integer :: coords_index
  allocate(current_coords,source=initial_coords)
  coords_index = this%generate_coords_index(initial_coords)
  do
    if ( target_coords%are_equal_to(this%get_no_data_value()) .or. &
         target_coords%are_equal_to(this%get_no_flow_value()) ) then
      call this%assign_coords_to_link_array(coords_index,this%get_flow_terminates_value())
      exit
    end if
    target_coords => this%get_next_cell_coords(current_coords)
    if ( this%dependencies%coords_outside_subfield(target_coords) ) then
      if ( current_coords%are_equal_to(initial_coords) ) then
         call this%assign_coords_to_link_array(coords_index,this%get_external_flow_value())
      else
         call this%assign_coords_to_link_array(coords_index,current_coords)
      end if
      exit
    end if
    current_coords => target_coords
  end do
  deallocate(initial_coords)
end subroutine follow_paths

  function get_external_flow_value(this) result(external_data_value)
    class(flow_accumulation_algorithm), intent(in) :: this
    class(coords), pointer :: external_data_value
      external_data_value => this%external_data_value
  end function get_external_flow_value

  function get_flow_terminates_value(this) result(flow_terminates_value)
    class(flow_accumulation_algorithm), intent(in) :: this
    class(coords), pointer :: flow_terminates_value
      flow_terminates_value => this%flow_terminates_value
  end function get_flow_terminates_value

  function get_no_data_value(this) result(no_data_value)
    class(flow_accumulation_algorithm), intent(in) :: this
    class(coords), pointer ::no_data_value
      no_data_value => this%no_data_value
  end function get_no_data_value

  function get_no_flow_value(this) result(no_flow_value)
    class(flow_accumulation_algorithm), intent(in) :: this
    class(coords), pointer ::no_flow_value
      no_flow_value => this%no_flow_value
  end function get_no_flow_value

  function latlon_get_next_cell_coords(this,coords_in) result(next_cell_coords)
    class(latlon_flow_accumulation_algorithm), intent(in) :: this
    class(coords), pointer :: coords_in
    class(coords), pointer :: next_cell_coords
    class(*), pointer :: next_cell_coords_lat_ptr
    class(*), pointer :: next_cell_coords_lon_ptr
      next_cell_coords_lat_ptr => this%next_cell_index_lat%get_value(coords_in)
      next_cell_coords_lon_ptr => this%next_cell_index_lon%get_value(coords_in)
      select type (next_cell_coords_lat_ptr)
      type is (integer)
        select type (next_cell_coords_lon_ptr)
        type is (integer)
          allocate(next_cell_coords, &
                   source=latlon_coords(next_cell_coords_lat_ptr, &
                                        next_cell_coords_lon_ptr))
        end select
      end select
  end function latlon_get_next_cell_coords

  function latlon_generate_coords_index(this,coords_in) result(index)
    class(latlon_flow_accumulation_algorithm), intent (in) :: this
    class(coords), pointer, intent (in) :: coords_in
    integer :: index
    integer :: relative_lat, relative_lon
    select type (coords_in)
    class is (latlon_coords)
      relative_lat = 1 + coords_in%lat - this%tile_min_lat
      relative_lon = 1 + coords_in%lon - this%tile_min_lon
    end select
    if ( relative_lat == 1 ) then
      index = relative_lon
    else if ( relative_lat < this%tile_width_lat .and. &
              relative_lat > 1 ) then
      if ( relative_lon == 1 ) then
        index = 2*this%tile_width_lon + 2*this%tile_width_lat - relative_lat - 2
      else if ( relative_lon == this%tile_width_lon ) then
        index = this%tile_width_lon + relative_lat - 1
      else
        stop 'trying to generate the index of an non edge cell'
      end if
    else if ( relative_lat == this%tile_width_lat ) then
      index = this%tile_width_lat + 2*this%tile_width_lon - relative_lon - 1
    else
        stop 'trying to generate the index of an non edge cell'
    end if
  end function latlon_generate_coords_index

  subroutine latlon_assign_coords_to_link_array(this,coords_index,coords_in)
    class(latlon_flow_accumulation_algorithm), intent(inout) :: this
    class(coords), pointer :: coords_in
    integer :: coords_index
    select type(latlon_links => this%links)
      type is (latlon_coords)
      select type(coords_in)
        type is (latlon_coords)
          latlon_links(coords_index) = coords_in
      end select
    end select
  end subroutine latlon_assign_coords_to_link_array

  function icon_single_index_get_next_cell_coords(this,coords_in) result(next_cell_coords)
    class(icon_single_index_flow_accumulation_algorithm), intent(in) :: this
    class(coords), pointer :: coords_in
    class(coords), pointer :: next_cell_coords
    class(*), pointer :: next_cell_coords_index_ptr
      next_cell_coords_index_ptr => this%next_cell_index%get_value(coords_in)
      select type (next_cell_coords_index_ptr)
        type is (integer)
          allocate(next_cell_coords, &
                   source=generic_1d_coords(next_cell_coords_index_ptr,.true.))
      end select
      deallocate(next_cell_coords_index_ptr)
  end function icon_single_index_get_next_cell_coords

  function icon_single_index_generate_coords_index(this,coords_in) result(index)
    class(icon_single_index_flow_accumulation_algorithm), intent (in) :: this
    class(coords), pointer, intent (in) :: coords_in
    integer :: index
      ! Dummy code to prevent compiler warnings
      select type (coords_in)
      type is (latlon_coords)
        index = coords_in%lat
      end select
      ! Dummy code to prevent compiler warnings
      select type (ndv=> this%no_data_value)
      type is (latlon_coords)
      index = ndv%lat
      end select
      index = 1
      stop "Function generate_coords_index not yet implemented for incon grid"
  end function icon_single_index_generate_coords_index

  subroutine icon_single_index_assign_coords_to_link_array(this,coords_index,coords_in)
    class(icon_single_index_flow_accumulation_algorithm), intent(inout) :: this
    class(coords), pointer :: coords_in
    integer :: coords_index
    select type(generic_1d_links => this%links)
      type is (generic_1d_coords)
      select type(coords_in)
        type is (generic_1d_coords)
          generic_1d_links(coords_index) = coords_in
      end select
    end select
  end subroutine icon_single_index_assign_coords_to_link_array

end module flow_accumulation_algorithm_mod


! KGEN-generated Fortran source file
!
! Filename    : rrlw_kg14.f90
! Generated at: 2015-07-06 23:28:45
! KGEN version: 0.4.13

    MODULE rrlw_kg14
        USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check
        USE shr_kind_mod, ONLY: r8 => shr_kind_r8
        !      use parkind ,only : jpim, jprb
        IMPLICIT NONE
        !-----------------------------------------------------------------
        ! rrtmg_lw ORIGINAL abs. coefficients for interval 14
        ! band 14:  2250-2380 cm-1 (low - co2; high - co2)
        !
        ! Initial version:  JJMorcrette, ECMWF, jul1998
        ! Revised: MJIacono, AER, jun2006
        !-----------------------------------------------------------------
        !
        !  name     type     purpose
        !  ----   : ----   : ---------------------------------------------
        !fracrefao: real
        !fracrefbo: real
        ! kao     : real
        ! kbo     : real
        ! selfrefo: real
        ! forrefo : real
        !-----------------------------------------------------------------
        !-----------------------------------------------------------------
        ! rrtmg_lw COMBINED abs. coefficients for interval 14
        ! band 14:  2250-2380 cm-1 (low - co2; high - co2)
        !
        ! Initial version:  JJMorcrette, ECMWF, jul1998
        ! Revised: MJIacono, AER, jun2006
        !-----------------------------------------------------------------
        !
        !  name     type     purpose
        !  ----   : ----   : ---------------------------------------------
        !fracrefa : real
        !fracrefb : real
        ! ka      : real
        ! kb      : real
        ! selfref : real
        ! forref  : real
        !
        ! absa    : real
        ! absb    : real
        !-----------------------------------------------------------------
        INTEGER, parameter :: ng14 = 2
        REAL(KIND=r8), dimension(ng14) :: fracrefa
        REAL(KIND=r8), dimension(ng14) :: fracrefb
        REAL(KIND=r8) :: absa(65,ng14)
        REAL(KIND=r8) :: absb(235,ng14)
        REAL(KIND=r8) :: selfref(10,ng14)
        REAL(KIND=r8) :: forref(4,ng14)
        PUBLIC kgen_read_externs_rrlw_kg14
    CONTAINS

    ! write subroutines

    ! module extern variables

    SUBROUTINE kgen_read_externs_rrlw_kg14(kgen_unit)
        INTEGER, INTENT(IN) :: kgen_unit
        READ(UNIT=kgen_unit) fracrefa
        READ(UNIT=kgen_unit) fracrefb
        READ(UNIT=kgen_unit) absa
        READ(UNIT=kgen_unit) absb
        READ(UNIT=kgen_unit) selfref
        READ(UNIT=kgen_unit) forref
    END SUBROUTINE kgen_read_externs_rrlw_kg14

    END MODULE rrlw_kg14


!> Initialize thermodynamic models
!!
!! \author MH, 2014-02
module eoslibinit
  !
  use thermopack_var, only: nce, get_active_eos, thermo_model, &
       get_active_thermo_model, get_active_alt_eos, base_eos_param, add_eos, &
       active_thermo_model_is_associated, numAssocSites
  use eos_container, only: allocate_eos
  use stringmod,  only: uppercase, str_eq, string_match, string_match_val
  implicit none
  save
  !
  logical :: silent_init = .false. ! Disable output for unit testing
  !
  ! Include TREND interface
  include 'trend_interface.f95'
  !
  private
  public :: init_thermo
  public :: init_cubic, init_cpa, init_saftvrmie, init_pcsaft, init_tcPR, init_quantum_cubic
  public :: init_extcsp, init_lee_kesler, init_quantum_saftvrmie
  public :: init_multiparameter, init_pets
  public :: silent_init
  public :: redefine_critical_parameters
  public :: init_volume_translation
  !
contains

  !----------------------------------------------------------------------
  !> Set method to discriminate between liquid and vapor in case of an
  !! undefined single phase
  !!
  !! \author MH, 2020-06
  !----------------------------------------------------------------------
  subroutine set_liq_vap_discr_method(liq_vap_discr_method)
    ! Method information
    integer, intent(in) :: liq_vap_discr_method !< Method to discriminate between liquid and vapor in case of an undefined single phase.
    type(thermo_model), pointer :: act_mod_ptr
    act_mod_ptr => get_active_thermo_model()

    ! Method for discriminating between liquid/vapor when poorly defined
    act_mod_ptr%liq_vap_discr_method = liq_vap_discr_method
  end subroutine set_liq_vap_discr_method

  !> Initialize volume translation
  !>
  !> \author MH, 2020
  !----------------------------------------------------------------------
  subroutine init_volume_translation(volume_trans_model, param_ref)
    use volume_shift, only: InitVolumeShift
    character(len=*), intent(in) :: volume_trans_model   !< String model for volume translation
    character(len=*), intent(in) :: param_ref !< String defining parameter set
    !
    type(thermo_model), pointer :: act_mod_ptr
    integer :: i
    act_mod_ptr => get_active_thermo_model()

    act_mod_ptr%eos(1)%p_eos%volumeShiftId = &
         InitVolumeShift(nce, act_mod_ptr%comps, &
         volume_trans_model, act_mod_ptr%eos(1)%p_eos%eosid)

    ! Distribute volumeShiftId
    do i=2,size(act_mod_ptr%eos)
      act_mod_ptr%eos(i)%p_eos%volumeShiftId = &
           act_mod_ptr%eos(1)%p_eos%volumeShiftId
    enddo
  end subroutine init_volume_translation

  !----------------------------------------------------------------------
  !> Initialize thermodynamics library (legacy interface)
  !>
  !> \author MH, 2014-02
  !----------------------------------------------------------------------
  subroutine init_thermo(eos,mixing,alpha,comp_string,nphases,&
       liq_vap_discr_method_in,csp_eos,csp_ref_comp,kij_ref,alpha_ref,&
       saft_ref,b_exponent,TrendEosForCp,cptype,silent)
    use thermopack_constants, only: clen, TREND, THERMOPACK
    use cbselect,   only: SelectCubicEOS
    use compdata,   only: SelectComp, initCompList
    use thermopack_var,  only: nc, nce, ncsym, complist, apparent, nph
    use eosdata,    only: cpaSRK, cpaPR, eosPC_SAFT, eosPeTS, eosBH_pert
    !$ use omp_lib, only: omp_get_max_threads
    ! Method information
    character(len=*), intent(in) :: eos    !< String defining equation of state
    character(len=*), intent(in) :: mixing !< String defining mixing rules
    character(len=*), intent(in) :: alpha  !< String defining alpha correlation
    character(len=*), intent(in) :: comp_string    !< String defining components. Comma or white-space separated.
    integer, intent(in) :: nphases !< Number of phases
    integer, optional, intent(in) :: liq_vap_discr_method_in !< Method to discriminate between liquid and vapor in case of an undefined single phase. Will be set to none if absent.
    character(len=*), optional, intent(in) :: csp_eos !< Corrensponding state equation
    character(len=*), optional, intent(in) :: csp_ref_comp !< CSP component
    character(len=*), optional, intent(in) :: kij_ref, alpha_ref, saft_ref !< Data set identifiers
    real, optional, intent(in) :: b_exponent !< Inverse exponent (1/s) in mixing of covolume (s>1.0)
    character(len=*), optional, intent(in) :: TrendEosForCp !< Option to init trend for ideal gas properties.
    integer, optional, intent(in) :: cptype !< Type numbers for Cp
    logical, optional, intent(in) :: silent !< Option to disable init messages.
    ! Locals
    integer :: ncomp !< Number of components
    character(len=clen) :: message
    integer             :: i, ierr, index
    type(thermo_model), pointer :: act_mod_ptr
    if (present(silent)) then
      silent_init = silent
    endif

    if (.not. active_thermo_model_is_associated()) then
      ! No thermo_model have been allocated
      index = add_eos()
    endif
    act_mod_ptr => get_active_thermo_model()

    ! Component list.
    call initCompList(trim(uppercase(comp_string)),ncomp,act_mod_ptr%complist)
    allocate(complist, source=act_mod_ptr%complist)

    ! Equation of state
    call allocate_eos(ncomp, eos)

    ! Method for discriminating between liquid/vapor when poorly defined
    if (present(liq_vap_discr_method_in)) then
      act_mod_ptr%liq_vap_discr_method = liq_vap_discr_method_in
    end if

    ! Number of phases
    act_mod_ptr%nph = nphases

    ! Assign active mode variables
    ncsym = ncomp
    nce = ncomp
    nc = ncomp
    act_mod_ptr%nc = ncomp
    nph = act_mod_ptr%nph
    complist => act_mod_ptr%complist
    apparent => NULL()
    numAssocSites = 0

    ! Initialize components
    call SelectComp(complist,nce,"DEFAULT",act_mod_ptr%comps,ierr)

    ! Set cptype
    if (present(cptype)) then
      do i=1,nc
        act_mod_ptr%comps(i)%p_comp%id_cp%cptype = cptype
      enddo
    endif

    if (str_eq(eos, "EOSCG") .or. &
         str_eq(eos, "EOS-CG") .or. &
         str_eq(eos, "GERG2008") .or. &
         str_eq(eos, "GERG-2008") .or. &
         str_eq(eos, "EOSCG-GERG")) then
      act_mod_ptr%eosLib = TREND
    else
      act_mod_ptr%eosLib = THERMOPACK
    endif

    ! Initialize the selected EoS-library
    select case (act_mod_ptr%eosLib)
    case (THERMOPACK)
      ! Initialize Thermopack
      call init_thermopack(trim(uppercase(eos)),trim(uppercase(mixing)), &
           trim(uppercase(alpha)), &
           nphases,csp_eos,csp_ref_comp, & ! csp_refcomp is case sensitive in compDB
           kij_ref,Alpha_ref,saft_ref,&
           b_exponent)
      if (present(TrendEosForCp)) then
        ! Initialize Trend for ideal properties
        call init_trend(trim(uppercase(TrendEosForCp)),ncomp,nphases,.false.)
      endif
    case (TREND)
      ! Initialize Trend
      call init_trend(trim(uppercase(eos)),ncomp,nphases,.true.)
    case default
      write(message,*) 'Wrong EoS library'
      call stoperror(trim(message))
    end select

    call init_fallback_and_redefine_criticals(silent_init)
  end subroutine init_thermo

  !----------------------------------------------------------------------------
  !> Initialize cubic fallback eos
  !----------------------------------------------------------------------------
  subroutine init_fallback_and_redefine_criticals(silent)
    use thermopack_constants, only: TREND, THERMOPACK
    use thermopack_var, only: nce
    use eosdata, only: isSAFTEOS
    use cbselect, only: selectCubicEOS, SelectMixingRules
    use cubic_eos, only: cb_eos
    !$ use omp_lib, only: omp_get_max_threads
    logical, intent(in) :: silent !< Option to disable init messages.
    ! Locals
    integer             :: i
    real                :: Tci, Pci, oi

    type(thermo_model), pointer :: act_mod_ptr
    act_mod_ptr => get_active_thermo_model()

    if (.not. act_mod_ptr%need_alternative_eos) return

    if (act_mod_ptr%EoSLib == TREND) then
      ! Use TREND parameters to get better critical point in alternative model
      do i=1,nce
        call trend_getcrit(i,Tci,Pci,oi)
        act_mod_ptr%comps(i)%p_comp%tc = Tci
        act_mod_ptr%comps(i)%p_comp%pc = Pci
        act_mod_ptr%comps(i)%p_comp%acf = oi
      enddo
    endif

    select type(p_eos => act_mod_ptr%cubic_eos_alternative(1)%p_eos)
    type is (cb_eos)
      call SelectCubicEOS(nce, act_mod_ptr%comps, p_eos, &
           "CLASSIC", "DEFAULT")

      call SelectMixingRules(nce, act_mod_ptr%comps, p_eos, &
         "VDW", "DEFAULT")
    class default
      call stoperror("init_cubic: Should be cubic EOS")
    end select

    ! Distribute parameters from redefined eos
    do i=2,size(act_mod_ptr%cubic_eos_alternative)
      act_mod_ptr%cubic_eos_alternative(i)%p_eos = &
           act_mod_ptr%cubic_eos_alternative(1)%p_eos
    enddo

    if (act_mod_ptr%EoSLib == THERMOPACK .and. &
         isSAFTEOS(act_mod_ptr%eos(1)%p_eos%eosidx)) then
      call redefine_critical_parameters(silent)
    endif
  end subroutine init_fallback_and_redefine_criticals

  !----------------------------------------------------------------------------
  !> Initialize cubic EoS. Use: call init_cubic('CO2,N2','PR', alpha='TWU')
  !----------------------------------------------------------------------------
  subroutine init_cubic(comps,eos,mixing,alpha,parameter_reference,vol_shift)
    use compdata,   only: SelectComp, initCompList
    use thermopack_var, only: nc, nce, ncsym, complist, nph, apparent
    use thermopack_constants, only: THERMOPACK
    use eos_container, only: allocate_eos
    use cbselect, only: selectCubicEOS, SelectMixingRules
    use cubic_eos, only: cb_eos
    use volume_shift, only: InitVolumeShift
    character(len=*), intent(in) :: comps !< Components. Comma or white-space separated
    character(len=*), intent(in) :: eos     !< Equation of state
    character(len=*), optional, intent(in) :: mixing !< Mixing rule
    character(len=*), optional, intent(in) :: alpha  !< Alpha correlation
    character(len=*), optional, intent(in) :: parameter_reference  !< Parameter reference
    logical, optional, intent(in) :: vol_shift  !< Volume shift
    ! Locals
    integer                          :: ncomp, i, index, ierr, volumeShiftId
    character(len=len_trim(comps))   :: comps_upper
    character(len=100)               :: mixing_loc, alpha_loc, paramref_loc, beta_loc
    logical                          :: volshift_loc
    type(thermo_model), pointer      :: act_mod_ptr
    logical                          :: found_tcPR, found_QuantumCubic
    integer                          :: matchval_tcPR, matchval_QuantumCubic
    ! Get a pointer to the active thermodynamics model
    if (.not. active_thermo_model_is_associated()) then
      ! No thermo_model has been allocated
      index = add_eos()
    endif
    act_mod_ptr => get_active_thermo_model()

    ! Set component list
    comps_upper=trim(uppercase(comps))
    call initCompList(comps_upper,ncomp,act_mod_ptr%complist)
    call allocate_eos(ncomp, eos)

    ! Number of phases
    act_mod_ptr%nph = 3

    ! Assign active mode variables
    ncsym = ncomp
    nce = ncomp
    nc = ncomp
    nph = act_mod_ptr%nph
    act_mod_ptr%nc = ncomp
    complist => act_mod_ptr%complist
    apparent => NULL()

    ! Set eos library identifier
    act_mod_ptr%eosLib = THERMOPACK

    ! Set local variables inputs that are optional
    mixing_loc = "vdW"
    alpha_loc = "Classic"
    paramref_loc = "DEFAULT"
    volshift_loc = .False.
    beta_loc = "Classic"
    if (present(mixing)) then
       mixing_loc = uppercase(mixing)
       if (str_eq(mixing_loc, "Classic")) mixing_loc = "VDW"
    end if
    if (present(alpha)) alpha_loc = uppercase(alpha)
    if (present(parameter_reference)) paramref_loc = parameter_reference
    if (present(vol_shift)) volshift_loc = vol_shift

    ! Special handling of translated-consistent Peng--Robinson EoS by le Guennec
    ! et al. (10.1016/j.fluid.2016.09.003)
    call string_match_val("tcPR", paramref_loc, found_tcPR, matchval_tcPR)
    if (found_tcPR) then
       alpha_loc = "TWU"
       volshift_loc = .True.
    end if

    ! Special handling of Quantum Cubic Peng-Robinson equation of state by Aasen
    ! et al. (10.1016/j.fluid.2020.112790)
    call string_match_val("QuantumCubic", paramref_loc, found_QuantumCubic, matchval_QuantumCubic)
    if (found_QuantumCubic) then
       alpha_loc = "TWU"
       volshift_loc = .True.
       beta_loc = "Quantum"
    end if

    ! Initialize components module
    call SelectComp(complist,nce,paramref_loc,act_mod_ptr%comps,ierr)

    ! Initialize volume shift
    if (volshift_loc) then
       volumeShiftId = InitVolumeShift(nc,act_mod_ptr%comps,'Peneloux',eos, param_ref=paramref_loc)
       act_mod_ptr%eos(1)%p_eos%volumeShiftId = volumeShiftId
    end if

    ! Initialize Thermopack
    select type(p_eos => act_mod_ptr%eos(1)%p_eos)
    type is (cb_eos)
      call SelectCubicEOS(nc, act_mod_ptr%comps, &
           p_eos, alpha_loc, paramref_loc, betastr=beta_loc)

      call SelectMixingRules(nc, act_mod_ptr%comps, &
           p_eos, mixing_loc, paramref_loc)
    class default
      call stoperror("init_cubic: Should be cubic EOS")
   end select

    ! Distribute parameters from redefined eos
    do i=2,size(act_mod_ptr%eos)
      act_mod_ptr%eos(i)%p_eos = act_mod_ptr%eos(1)%p_eos
    enddo

  end subroutine init_cubic

  !----------------------------------------------------------------------------
  !> Initialize translated and consistent cubic EoS by le Guennec et al.
  ! (10.1016/j.fluid.2016.09.003)
  !----------------------------------------------------------------------------
  subroutine init_tcPR(comps, mixing, parameter_ref)
    character(len=*), intent(in) :: comps !< Components. Comma or white-space separated
    character(len=*), intent(in), optional :: mixing !< Mixing rule
    character(len=*), intent(in), optional :: parameter_ref !< Parameter set reference
    !
    character(len=200) :: parameter_reference
    type(thermo_model), pointer      :: act_mod_ptr
    parameter_reference = "tcPR"
    if (present(parameter_ref)) then
      parameter_reference = trim(parameter_ref) // "/" // trim(parameter_reference)
    endif
    call init_cubic(eos="PR", comps=comps, mixing=mixing, &
         parameter_reference=parameter_reference)
  end subroutine init_tcPR

  !----------------------------------------------------------------------------
  !> Initialize Quantum Cubic Peng-Robinson equation of state by Aasen et al.
  !> (10.1016/j.fluid.2020.112790)
  !----------------------------------------------------------------------------
  subroutine init_quantum_cubic(comps, mixing)
    character(len=*), intent(in) :: comps !< Components. Comma or white-space separated
    character(len=*), intent(in), optional :: mixing !< Mixing rule
    call init_cubic(eos="PR", comps=comps, mixing=mixing, parameter_reference="QuantumCubic/tcPR")
  end subroutine init_quantum_cubic

  !----------------------------------------------------------------------------
  !> Initialize extended corresponding state EoS. Use: call init_extcsp
  !----------------------------------------------------------------------------
  subroutine init_extcsp(comps,sh_eos,sh_mixing,sh_alpha,&
       ref_eos,ref_comp,ref_alpha,&
       parameter_ref)
    use compdata,   only: SelectComp, initCompList
    use thermopack_var, only: nc, nce, ncsym, complist, nph, apparent
    use thermopack_constants, only: THERMOPACK, ref_len
    use stringmod,  only: uppercase
    use eos_container, only: allocate_eos
    use extcsp, only: extcsp_eos, csp_init
    use volume_shift, only: NOSHIFT
    !$ use omp_lib, only: omp_get_max_threads
    character(len=*), intent(in) :: comps !< Components. Comma or white-space
    !separated
    character(len=*), intent(in) :: sh_eos      !< Shape factor equation of state
    character(len=*), intent(in) :: sh_alpha    !< Shape factor alpha
    character(len=*), intent(in) :: sh_mixing   !< Shape factor mixing rules
    character(len=*), intent(in) :: ref_eos     !< Reference equation of state
    character(len=*), intent(in) :: ref_comp    !< Reference component
    character(len=*), intent(in), optional :: ref_alpha  !< Needed if refEos is a cubic eos. Should not be present if one want to use an mbwr reference eos.
    character(len=*), intent(in), optional :: parameter_ref !< Parameter set reference

    ! Locals
    integer                          :: ncomp, i, index, ierr, ncbeos
    character(len=len_trim(comps))   :: comps_upper
    type(thermo_model), pointer      :: act_mod_ptr
    class(base_eos_param), pointer   :: act_eos_ptr
    character(len=ref_len)           :: param_ref

    if (.not. active_thermo_model_is_associated()) then
      ! No thermo_model have been allocated
      index = add_eos()
    endif
    act_mod_ptr => get_active_thermo_model()
    ! Set component list
    comps_upper=trim(uppercase(comps))
    call initCompList(comps_upper,ncomp,act_mod_ptr%complist)
    !
    call allocate_eos(ncomp, "CSP-"//trim(sh_eos))

    ! Number of phases
    act_mod_ptr%nph = 3

    ! Assign active mode variables
    ncsym = ncomp
    nce = ncomp
    nc = ncomp
    nph = act_mod_ptr%nph
    act_mod_ptr%nc = ncomp
    complist => act_mod_ptr%complist
    apparent => NULL()

    ! Set eos library identifyer
    act_mod_ptr%eosLib = THERMOPACK

    ! Set local variable for parameter reference
    if (present(parameter_ref)) then
      param_ref = parameter_ref
    else
      param_ref = "DEFAULT"
    endif

    ! Initialize components module
    call SelectComp(complist,nce,param_ref,act_mod_ptr%comps,ierr)

    act_eos_ptr => get_active_eos()
    act_eos_ptr%volumeShiftId = NOSHIFT
    act_eos_ptr%isElectrolyteEoS = .false.
    select type(p_eos => act_eos_ptr)
    type is (extcsp_eos)
      call csp_init(p_eos,nce,act_mod_ptr%comps,&
           refcomp_str=trim(ref_comp),&
           shEos=trim(sh_eos),&
           shMixRule=trim(sh_mixing),shAlpha=trim(sh_alpha),&
           refEos=trim(ref_eos),refAlpha=ref_alpha,&
           parameter_ref=parameter_ref)
   end select

   ncbeos = 1
   !$ ncbeos = omp_get_max_threads()
   do i=2,ncbeos
     act_mod_ptr%eos(i)%p_eos = act_mod_ptr%eos(1)%p_eos
   enddo

   ! Set globals
   call update_global_variables_form_active_thermo_model()

   ! Initialize fallback eos
   call init_fallback_and_redefine_criticals(silent=.true.)

  end subroutine init_extcsp

  !----------------------------------------------------------------------
  !> Set critical parameters to represent actual model
  !>
  !> \author MH, 2019-03
  !----------------------------------------------------------------------
  subroutine redefine_critical_parameters(silent_init, Tc_in, vc_in)
    use cbmix,      only: cbSingleCalcABC
    use thermopack_var, only: nce
    use eosTV,        only: pressure
    use critical,     only: calcCriticalTV
    use saturation,   only: acentricFactorEos
    use thermopack_constants,      only: tpTmin, Rgas
    use cbAlpha,      only: getAcentricAlphaParam
    use cubic_eos,    only: cb_eos
    logical, intent(in) :: silent_init
    real, optional, intent(in) :: Tc_in(nce), vc_in(nce)
    ! Locals
    integer :: i, j, ierr
    real :: Tmin
    real :: Vc
    real :: Tc  !< Specified critical temperature [K]
    real :: Pc  !< Specified critical pressure [Pa]
    real :: Acf !< Specified acentric factor [-]
    real :: Z(nce)
    type(thermo_model), pointer :: act_mod_ptr
    class(base_eos_param), pointer :: act_eos_ptr

    act_mod_ptr => get_active_thermo_model()
    act_eos_ptr => get_active_alt_eos()
    Tmin = tpTmin
    tpTmin = 2.0
    do i=1,nce
      Z = 0
      Z(i) = 1
      Tc = -1.0
      Vc = -1.0
      if (present(Tc_in)) Tc = Tc_in(i)
      if (present(Vc_in)) Vc = Vc_in(i)
      call calcCriticalTV(Tc,Vc,Z,ierr)
      if (ierr /= 0 .and. .not. silent_init) then
        print *, 'Not able to redefine critical properties for component: ', &
             trim(act_mod_ptr%comps(i)%p_comp%ident)
      else
        Pc = pressure(Tc,Vc,Z)
        select type (p_eos => act_eos_ptr)
        class is (cb_eos)
          p_eos%single(i)%Tc = Tc
          p_eos%single(i)%Pc = Pc
          call cbSingleCalcABC(nce,p_eos,i)
          act_mod_ptr%comps(i)%p_comp%tc = Tc
          act_mod_ptr%comps(i)%p_comp%pc = Pc
          act_mod_ptr%comps(i)%p_comp%zc = Pc*Vc/(Tc*Rgas)
          Acf = acentricFactorEos(i,ierr)
          act_mod_ptr%comps(i)%p_comp%acf = Acf
          p_eos%single(i)%Acf = Acf
          call getAcentricAlphaParam(p_eos%single(i)%alphaMethod, Acf, &
               p_eos%single(i)%alphaParams)

          ! Copy to others
          do j=2,size(act_mod_ptr%cubic_eos_alternative)
            select type (p_eos_j => act_mod_ptr%cubic_eos_alternative(j)%p_eos)
            class is (cb_eos)
              p_eos_j%single(i)%Tc = p_eos%single(i)%Tc
              p_eos_j%single(i)%Pc = p_eos%single(i)%Pc
              p_eos_j%single(i)%Acf = p_eos%single(i)%Acf
              p_eos_j%single(i)%alphaParams = p_eos%single(i)%alphaParams
              call cbSingleCalcABC(nce, p_eos_j, i)
            class default
              print *,"Fallback eos should be cubic"
            end select
          enddo
        class default
          print *,"Fallback eos should be cubic"
        end select
      endif
    enddo
    tpTmin = Tmin
  end subroutine redefine_critical_parameters

  !> Initialize ThermoPack
  !>
  !> \author MH, 2013-03-06
  !----------------------------------------------------------------------
  subroutine init_thermopack(eos,mixing,alpha,nphase,&
       csp_eos,csp_ref_comp,kij_ref,alpha_ref,saft_ref,&
       b_exponent)
    use eosdata, only: isSAFTEOS
    use stringmod, only: str_eq
    use thermopack_constants, only: THERMOPACK, ref_len
    use thermopack_var, only: nce, nc, complist
    use volume_shift, only: initVolumeShift, NOSHIFT
    use extcsp, only: csp_init, extcsp_eos
    use cubic_eos, only: cb_eos
    use cbselect, only: SelectCubicEOS, SelectMixingRules
    use saft_interface, only: saft_type_eos_init
    use cpa_parameters, only: mixHasSelfAssociatingComp
    use assocschemeutils, only: no_assoc
    use saft_association, only: numAssocSites
    use stringmod, only: uppercase
    use eos_container, only: allocate_eos
    !$ use omp_lib
    ! Method information
    character(len=*), intent(in) :: eos    !< String defining equation of state
    character(len=*), intent(in) :: mixing !< String defining mixing rules
    character(len=*), intent(in) :: alpha  !< String defining alpha correlation
    integer, intent(in) :: nphase !< Number of phases
    character(len=*), optional, intent(in) :: csp_eos !< Corrensponding state equation
    character(len=*), optional, intent(in) :: csp_ref_comp !< CSP component
    character(len=*), optional, intent(in) :: kij_ref, alpha_ref, saft_ref !< Data set number
    real, optional, intent(in) :: b_exponent !< Inverse exponent (1/s) in mixing of covolume (s>1.0)
    ! String containing components on TPLib format
    character(len=100) :: mixRule,csp_refEos,csp_refcomp_str
    character(len=len(eos)) :: eosLocal  !< Local copy of string defining equation of state
    integer :: ncbeos, i, volumeShiftId
    character(len=ref_len) :: kij_ref_local, alpha_ref_local, saft_ref_local
    type(thermo_model), pointer :: act_mod_ptr
    class(base_eos_param), pointer :: act_eos_ptr
    !
    act_mod_ptr => get_active_thermo_model()
    act_eos_ptr => get_active_eos()

    if (present(kij_ref)) then
      kij_ref_local = trim(kij_ref)
    else
      kij_ref_local = "DEFAULT"
    endif
    if (present(alpha_ref)) then
      alpha_ref_local = trim(alpha_ref)
    else
      alpha_ref_local = "DEFAULT"
    endif
    if (present(saft_ref)) then
      saft_ref_local = trim(saft_ref)
    else
      saft_ref_local = "DEFAULT"
    endif

    ! Set parameters
    mixRule = trim(mixing)
    volumeShiftId = NOSHIFT
    eosLocal = eos
    numAssocSites = 0
    if (len(eos) >= 3) then
      if (eos(1:3) == 'CPA') then
        if ( .not. mixHasSelfAssociatingComp(nc,trim(eosLocal),&
             complist,saft_ref)) then
          print *,'No self associating components. Initializing ',&
               eos(5:len(eos)),' instead of ',trim(eos)
          eosLocal = eos(5:len(eos))
          do i=1,nce
            act_mod_ptr%comps(i)%p_comp%assoc_scheme = no_assoc
          enddo
        endif
      endif
    endif

    if (trim(uppercase(eos)) == 'LK') then
      mixRule = 'VDW'
    else if (trim(uppercase(eos)) == 'SRK-PENELOUX') then
      eosLocal = 'SRK'
      volumeShiftId = InitVolumeShift(nc,act_mod_ptr%comps,'Peneloux','SRK')
    else if (trim(uppercase(eos)) == 'PR-PENELOUX') then
      eosLocal = 'PR'
      volumeShiftId = InitVolumeShift(nc,act_mod_ptr%comps,'Peneloux','PR')
    else if (len(eos) >= 3) then
      if (uppercase(eos(1:3)) == 'CSP') then
        eosLocal = eos(5:len(trim(eos)))
        if (present(csp_eos)) then
          csp_refEos = uppercase(csp_eos)
        else
          csp_refEos = "NIST_MEOS"
          if (.not. silent_init) &
               print *,'init_thermopack: CSP model defaulted to MBWR32'
        endif
        if (present(csp_ref_comp)) then
          csp_refcomp_str = csp_ref_comp ! This is case sensitive
        else
          csp_refcomp_str = "C3"
          if (.not. silent_init) &
               print *,'init_thermopack: CSP reference component defaulted to C3'
        endif
      end if
    end if

    act_eos_ptr%volumeShiftId = volumeShiftId
    act_eos_ptr%isElectrolyteEoS = .false.
    select type(p_eos => act_eos_ptr)
    class is (cb_eos)
      call SelectCubicEOS(nce,act_mod_ptr%comps,p_eos,trim(alpha),&
           alpha_ref_local)
      call SelectMixingRules(nce,act_mod_ptr%comps,p_eos,mixRule,&
           kij_ref_local,b_exponent)
    type is (extcsp_eos)
      call csp_init(p_eos,nce,act_mod_ptr%comps,refcomp_str=trim(csp_refcomp_str),&
           shEos=trim(eosLocal),&
           shMixRule=trim(mixRule),shAlpha=trim(alpha),&
           refEos=trim(csp_refEos),refAlpha=trim(alpha))
   end select

    ! SAFT initialization must be done after cbeos initialization.
    if (isSAFTEOS(act_eos_ptr%eosidx)) then
       call saft_type_eos_init(nce,act_mod_ptr%comps,&
            act_eos_ptr,saft_ref_local,silent_init)
    end if
    ncbeos = 1
    !$ ncbeos = omp_get_max_threads()
    do i=2,ncbeos
      act_mod_ptr%eos(i)%p_eos = act_mod_ptr%eos(1)%p_eos
    enddo
  end subroutine init_thermopack

  !----------------------------------------------------------------------
  !> Initialize trend
  !>
  !> \author MH, 2013-04-10, EA 2014-02
  !----------------------------------------------------------------------
  subroutine init_trend(eos,ncomp,nphase,doFallbackInit)
    !use thermopack_constants, only: Rgas,TREND,verbose
    !use thermopack_var, only: complist,nph
    !use stringmod, only: chartoascii
    !use compname_translation, only: translate_compname
#ifdef __INTEL_COMPILER
    use ifport
#endif
    ! Input:
    character(len=*), intent(in)    :: eos            !< String defining equation of state
    integer, intent(in)             :: ncomp          !< Number of components
    integer, intent(in)             :: nphase         !< Number of phases
    logical, intent(in)             :: doFallbackInit !< Init thermopack as fallback
    !Internal:
    ! integer                         :: i
    ! integer                         :: mix
    ! character (12)                  :: comps(ncomp)
    ! character(len=255)              :: path,trendroot
    ! integer                         :: npath,int_path(255),int_comps(12*ncomp),ncomps

    ! if (doFallbackInit) then
    !   ! Also initialize Thermopack cubic EoS, to be used for initial estimates.
    !   if (verbose) then
    !     write(*,*) "Initializing EoS-lib Thermopack for initial estimates. (SRK, Classic)"
    !   endif
    !   call init_thermopack("SRK","Classic","Classic", nphase)
    ! endif
    ! ! Setting EoSLib flag
    ! if (verbose) then
    !   write(*,*) "Initializing EoS-lib TREND"
    ! endif
    ! EoSLib = TREND
    ! call set_constants() ! Depend on EoSLib
    ! ! Setting global nph number
    ! nph = nphase
    ! do i=1,ncomp
    !   call translate_compname(trim(complist(i)), TREND, comps(i))
    !   char_comps((i-1)*12+1:i*12) = comps(i)
    ! enddo
    ! ! Setting mixing rules
    ! if (verbose) then
    !   write(*,*) "OBS: Mixing rule and alpha-correlation input ignored."
    ! endif
    ! mix = 1 ! Lorentz-Berthelot or modified Helmholtz mixing rules
    ! call getenv("TRENDROOT",trendroot)
    ! if (trim(trendroot) == "") then
    !    trendroot = "./trend/"
    ! endif
    ! ! Setting path based on input EoS-string:
    ! ! They are all "Multi-parameter explicit Helmholtz" EoS, but with different parameters.
    ! select case(trim(eos))
    ! case ("EOSCG")
    !   ! The EoS for CCS mixtures, parameters fitted by Johannes Gernert.
    !   ! Will fail when selecting components not covered in the original fitting.
    !    path = trim(trendroot)//"EOS_CG/"
    ! case ("GERG2008")
    !   ! The GERG-2008 EoS for natural gas mixtures.
    !   path = trim(trendroot)//"GERG-2008/"
    ! case ("EOSCG-GERG")
    !   ! Primarily EOSCG, but now falling back to GERG2008 for unsupported components.
    !   path = trim(trendroot)//"/"
    ! case default
    !   call stoperror("No such EoS in TREND (EOSCG,GERG2008,EOSCG-GERG): "//trim(eos))
    ! end select
    ! if (verbose) then
    !   write(*,*) "Will look for dirs FLUIDS and BINARY_MIX_FILES in: "//trim(path)
    ! endif
    ! npath = len(trim(path))
    ! call chartoascii(int_path,path,npath)
    ! ncomps = 12*ncomp
    ! call chartoascii(int_comps,char_comps,ncomps)
    ! call trend_init_no_char(ncomp,int_path,npath,int_comps,ncomps,mix,Rgas)

  end subroutine init_trend

  !----------------------------------------------------------------------------
  !> Initialize SAFT-VR-MIE EoS. Use: call init_saftvrmie('CO2,N2')
  !----------------------------------------------------------------------------
  subroutine init_saftvrmie(comps,parameter_reference)
    use compdata,   only: SelectComp, initCompList
    use thermopack_var,  only: nce, complist
    use thermopack_constants, only: THERMOPACK, ref_len
    use stringmod,  only: uppercase
    use volume_shift, only: NOSHIFT
    use saft_interface, only: saft_type_eos_init
    !$ use omp_lib
    character(len=*), intent(in) :: comps !< Components. Comma or white-space separated
    character(len=*), optional, intent(in) :: parameter_reference !< Data set reference
    ! Locals
    integer                          :: ncomp, index, ierr, i, ncbeos
    character(len=len_trim(comps))   :: comps_upper
    type(thermo_model), pointer      :: act_mod_ptr
    class(base_eos_param), pointer   :: act_eos_ptr
    character(len=ref_len)           :: param_ref

    if (.not. active_thermo_model_is_associated()) then
      ! No thermo_model have been allocated
      index = add_eos()
    endif
    act_mod_ptr => get_active_thermo_model()
    ! Set component list
    comps_upper=trim(uppercase(comps))
    call initCompList(comps_upper,ncomp,act_mod_ptr%complist)

    call allocate_eos(ncomp, "SAFT-VR-MIE")
    act_mod_ptr%need_alternative_eos = .true.

    ! Number of phases
    act_mod_ptr%nph = 3
    ! Assign active mode variables
    act_mod_ptr%nc = ncomp
    nce = ncomp
    complist => act_mod_ptr%complist
    ! Set eos library identifyer
    act_mod_ptr%eosLib = THERMOPACK

    ! Set local variable for parameter reference
    if (present(parameter_reference)) then
      param_ref = parameter_reference
    else
      param_ref = "DEFAULT"
    endif

    ! Initialize components module
    call SelectComp(complist,nce,param_ref,act_mod_ptr%comps,ierr)

    ! Initialize Thermopack
    act_eos_ptr => act_mod_ptr%eos(1)%p_eos
    act_eos_ptr%volumeShiftId = NOSHIFT
    act_eos_ptr%isElectrolyteEoS = .false.

    ! SAFT initialization must be done after cbeos initialization.
    call saft_type_eos_init(nce,act_mod_ptr%comps,&
         act_eos_ptr,param_ref,silent_init=.true.)
    ncbeos = 1
    !$ ncbeos = omp_get_max_threads()
    do i=2,ncbeos
      act_mod_ptr%eos(i)%p_eos = act_mod_ptr%eos(1)%p_eos
    enddo

    ! Set globals
    call update_global_variables_form_active_thermo_model()

    ! Initialize fallback eos
    call init_fallback_and_redefine_criticals(silent=.true.)

  end subroutine init_saftvrmie

  !----------------------------------------------------------------------------
  !> Initialize SAFT-VR-MIE with quantum corrections EoS.
  !! Use: call init_quantum_saftvrmie('He,Ne',feynman_hibbs_order=1)
  !----------------------------------------------------------------------------
  subroutine init_quantum_saftvrmie(comps,feynman_hibbs_order,parameter_reference)
    use saftvrmie_options, only: LAFITTE, QSAFT_FH1, QSAFT_FH2, LAFITTE_HS_REF, &
         saftvrmieaij_model_options
    character(len=*), intent(in) :: comps !< Components. Comma or white-space separated
    integer, optional, intent(in) :: feynman_hibbs_order
    character(len=*), optional, intent(in) :: parameter_reference !< Data set reference
    ! Locals
    integer :: FH, FH_model
    if (present(feynman_hibbs_order)) then
      FH = feynman_hibbs_order
    else
      FH = 1
    endif
    FH_model = FH + 1
    call saftvrmieaij_model_options(FH_model, LAFITTE_HS_REF)
    call init_saftvrmie(comps,parameter_reference)
  end subroutine init_quantum_saftvrmie

  !----------------------------------------------------------------------------
  !> Initialize PC-SAFT EoS. Use: call init_pcsaft('CO2,N2')
  !----------------------------------------------------------------------------
  subroutine init_pcsaft(comps,parameter_reference)
    use compdata,   only: SelectComp, initCompList
    use thermopack_var,  only: nc, nce, ncsym, complist, apparent, nph
    use thermopack_constants, only: THERMOPACK, ref_len
    use stringmod,  only: uppercase
    character(len=*), intent(in) :: comps !< Components. Comma or white-space separated
    character(len=*), optional, intent(in) :: parameter_reference !< Data set reference
    ! Locals
    integer                          :: ncomp, index, ierr
    character(len=len_trim(comps))   :: comps_upper
    type(thermo_model), pointer      :: act_mod_ptr
    character(len=ref_len)           :: param_ref

    if (.not. active_thermo_model_is_associated()) then
      ! No thermo_model have been allocated
      index = add_eos()
    endif
    act_mod_ptr => get_active_thermo_model()
    ! Set component list
    comps_upper=trim(uppercase(comps))
    call initCompList(comps_upper,ncomp,act_mod_ptr%complist)
    !
    call allocate_eos(ncomp, "PC-SAFT")

    ! Number of phases
    act_mod_ptr%nph = 3

    ! Assign active mode variables
    ncsym = ncomp
    nce = ncomp
    nc = ncomp
    nph = act_mod_ptr%nph
    act_mod_ptr%nc = ncomp
    complist => act_mod_ptr%complist
    apparent => NULL()

    ! Set eos library identifyer
    act_mod_ptr%eosLib = THERMOPACK

    ! Set local variable for parameter reference
    if (present(parameter_reference)) then
      param_ref = parameter_reference
    else
      param_ref = "DEFAULT"
    endif

    ! Initialize components module
    call SelectComp(complist,nce,param_ref,act_mod_ptr%comps,ierr)

    ! Initialize Thermopack
    call init_thermopack("PC-SAFT", "Classic", "Classic", nphase=3,&
         saft_ref=param_ref)

    ! Set globals
    call update_global_variables_form_active_thermo_model()

    ! Initialize fallback eos
    call init_fallback_and_redefine_criticals(silent=.true.)

  end subroutine init_pcsaft

  !----------------------------------------------------------------------------
  !> Initialize CPA EoS. Use: call init_cpa('CO2,N2','PR', alpha='TWU')
  !----------------------------------------------------------------------------
  subroutine init_cpa(comps,eos,mixing,alpha,parameter_reference)
    use compdata,   only: SelectComp, initCompList
    use thermopack_var,  only: nc, nce, ncsym, complist, apparent, nph
    use thermopack_constants, only: THERMOPACK
    use stringmod,  only: uppercase
    character(len=*), intent(in) :: comps !< Components. Comma or white-space separated
    character(len=*), optional, intent(in) :: eos    !< Equation of state
    character(len=*), optional, intent(in) :: mixing !< Mixing rule
    character(len=*), optional, intent(in) :: alpha  !< Alpha correlation
    character(len=*), optional, intent(in) :: parameter_reference !< Data set reference
    ! Locals
    integer                          :: ncomp, index, ierr
    character(len=len_trim(comps))   :: comps_upper
    character(len=100)               :: mixing_loc, alpha_loc, eos_loc, param_ref
    type(thermo_model), pointer     :: act_mod_ptr

    ! Initialize Thermopack
    eos_loc = "SRK"
    if (present(eos)) eos_loc = uppercase(eos)
    !
    if (.not. active_thermo_model_is_associated()) then
      ! No thermo_model have been allocated
      index = add_eos()
    endif
    act_mod_ptr => get_active_thermo_model()
    ! Set component list
    comps_upper=trim(uppercase(comps))
    call initCompList(comps_upper,ncomp,act_mod_ptr%complist)
    !
    call allocate_eos(ncomp, "CPA-"//trim(eos_loc))

    ! Number of phases
    act_mod_ptr%nph = 3

    ! Assign active mode variables
    ncsym = ncomp
    nce = ncomp
    nc = ncomp
    act_mod_ptr%nc = ncomp
    nph = act_mod_ptr%nph
    complist => act_mod_ptr%complist
    apparent => NULL()

    ! Set eos library identifyer
    act_mod_ptr%eosLib = THERMOPACK

    ! Set local variable for parameter reference
    if (present(parameter_reference)) then
      param_ref = parameter_reference
    else
      param_ref = "DEFAULT"
    endif

    ! Initialize components module
    call SelectComp(complist,nce,param_ref,act_mod_ptr%comps,ierr)

    alpha_loc = "Classic"
    mixing_loc = "Classic"
    if (present(mixing)) mixing_loc = uppercase(mixing)
    if (present(alpha)) alpha_loc = uppercase(alpha)

    call init_thermopack("CPA-"//trim(eos_loc),trim(uppercase(mixing_loc)), &
         trim(uppercase(alpha_loc)), nphase=3, saft_ref=param_ref)

    ! Set globals
    call update_global_variables_form_active_thermo_model()

    ! Initialize fallback eos
    act_mod_ptr%need_alternative_eos = .true.
    call init_fallback_and_redefine_criticals(silent=.true.)
  end subroutine init_cpa

  !----------------------------------------------------------------------------
  !> Initialize Lee-Kesler EoS.
  !----------------------------------------------------------------------------
  subroutine init_lee_kesler(comps,parameter_reference)
    use compdata,   only: SelectComp, initCompList
    use thermopack_var,  only: nc, nce, ncsym, complist, apparent, nph
    use thermopack_constants, only: THERMOPACK, ref_len
    use stringmod,  only: uppercase
    character(len=*), intent(in) :: comps !< Components. Comma or white-space separated
    character(len=*), optional, intent(in) :: parameter_reference !< Data set reference
    ! Locals
    integer                          :: ncomp, index, ierr
    character(len=len_trim(comps))   :: comps_upper
    type(thermo_model), pointer      :: act_mod_ptr
    character(len=ref_len)           :: param_ref

    ! Initialize Lee-Kesler eos
    if (.not. active_thermo_model_is_associated()) then
      ! No thermo_model have been allocated
      index = add_eos()
    endif
    act_mod_ptr => get_active_thermo_model()
    ! Set component list
    comps_upper=trim(uppercase(comps))
    call initCompList(comps_upper,ncomp,act_mod_ptr%complist)
    !
    call allocate_eos(ncomp, "LK")

    ! Number of phases
    act_mod_ptr%nph = 3

    ! Assign active mode variables
    ncsym = ncomp
    nce = ncomp
    nc = ncomp
    act_mod_ptr%nc = ncomp
    nph = act_mod_ptr%nph
    complist => act_mod_ptr%complist
    apparent => NULL()

    ! Set eos library identifyer
    act_mod_ptr%eosLib = THERMOPACK

    ! Set local variable for parameter reference
    if (present(parameter_reference)) then
      param_ref = parameter_reference
    else
      param_ref = "DEFAULT"
    endif

    ! Initialize components module
    call SelectComp(complist,nce,param_ref,act_mod_ptr%comps,ierr)

    call init_thermopack("LK","CLASSIC", &
         "CLASSIC", nphase=3, kij_ref=param_ref)
    ! Set globals
    call update_global_variables_form_active_thermo_model()

    ! Initialize fallback eos
    act_mod_ptr%need_alternative_eos = .true.
    call init_fallback_and_redefine_criticals(silent=.true.)
  end subroutine init_lee_kesler

  !----------------------------------------------------------------------------
  !> Initialize multiparamaters eos
  !----------------------------------------------------------------------------
  subroutine init_multiparameter(comps, eos)
    use compdata,   only: SelectComp, initCompList
    use thermopack_var,  only: nc, nce, ncsym, complist, apparent, nph
    use thermopack_constants, only: THERMOPACK
    use stringmod,  only: uppercase
    !$ use omp_lib, only: omp_get_max_threads
    character(len=*), intent(in) :: comps !< Components. Comma or white-space separated
    character(len=*), intent(in) :: eos !< Equation of state
    ! Locals
    integer                          :: ncomp, index, ierr, ncbeos, i
    character(len=len_trim(comps))   :: comps_upper
    type(thermo_model), pointer      :: act_mod_ptr

    ! Initialize MEOS
    if (.not. active_thermo_model_is_associated()) then
      ! No thermo_model have been allocated
      index = add_eos()
    endif
    act_mod_ptr => get_active_thermo_model()
    ! Set component list
    comps_upper=trim(uppercase(comps))
    call initCompList(comps_upper,ncomp,act_mod_ptr%complist)
    !
    complist => act_mod_ptr%complist
    call allocate_eos(ncomp, eos)

    ! Number of phases
    act_mod_ptr%nph = 3

    ! Assign active mode variables
    ncsym = ncomp
    nce = ncomp
    nc = ncomp
    act_mod_ptr%nc = ncomp
    nph = act_mod_ptr%nph
    apparent => NULL()

    ! Set eos library identifyer
    act_mod_ptr%eosLib = THERMOPACK

    ! Initialize components module
    call SelectComp(complist,nce,"DEFAULT",act_mod_ptr%comps,ierr)

    ! Set globals
    call update_global_variables_form_active_thermo_model()

    ncbeos = 1
    !$ ncbeos = omp_get_max_threads()
    do i=2,ncbeos
      act_mod_ptr%eos(i)%p_eos = act_mod_ptr%eos(1)%p_eos
    enddo

    ! Initialize fallback eos
    act_mod_ptr%need_alternative_eos = .true.
    call init_fallback_and_redefine_criticals(silent=.true.)
  end subroutine init_multiparameter

  !----------------------------------------------------------------------------
  !> Initialize Pets EoS.
  !----------------------------------------------------------------------------
  subroutine init_pets(parameter_reference)
    use compdata, only: SelectComp, initCompList
    use thermopack_var,  only: nc, nce, ncsym, complist, apparent, nph
    use thermopack_constants, only: THERMOPACK, ref_len
    use stringmod,  only: uppercase
    use volume_shift, only: NOSHIFT
    use saft_interface, only: saft_type_eos_init
    !$ use omp_lib, only: omp_get_max_threads
    character(len=*), optional, intent(in) :: parameter_reference !< Data set reference
    ! Locals
    integer                          :: ncomp, ncbeos, i, ierr, index
    character(len=3)                 :: comps_upper
    type(thermo_model), pointer      :: act_mod_ptr
    class(base_eos_param), pointer   :: act_eos_ptr
    character(len=ref_len)           :: param_ref

    ! Initialize Pets eos
    if (.not. active_thermo_model_is_associated()) then
      ! No thermo_model have been allocated
      index = add_eos()
    endif
    act_mod_ptr => get_active_thermo_model()
    ! Set component list
    comps_upper="AR"
    call initCompList(comps_upper,ncomp,act_mod_ptr%complist)
    !
    call allocate_eos(ncomp, "PETS")

    ! Number of phases
    act_mod_ptr%nph = 2

    ! Assign active mode variables
    ncsym = ncomp
    nce = ncomp
    nc = ncomp
    act_mod_ptr%nc = ncomp
    nph = act_mod_ptr%nph
    complist => act_mod_ptr%complist
    apparent => NULL()

    ! Set eos library identifyer
    act_mod_ptr%eosLib = THERMOPACK

    ! Set local variable for parameter reference
    if (present(parameter_reference)) then
      param_ref = parameter_reference
    else
      param_ref = "DEFAULT"
    endif

    ! Initialize components module
    call SelectComp(complist,nce,param_ref,act_mod_ptr%comps,ierr)

    ! Initialize Thermopack
    act_eos_ptr => act_mod_ptr%eos(1)%p_eos
    act_eos_ptr%volumeShiftId = NOSHIFT
    act_eos_ptr%isElectrolyteEoS = .false.

    call saft_type_eos_init(nce,act_mod_ptr%comps,&
         act_eos_ptr,param_ref,silent_init=.true.)

    ! Set globals
    call update_global_variables_form_active_thermo_model()

    ncbeos = 1
    !$ ncbeos = omp_get_max_threads()
    do i=2,ncbeos
      act_mod_ptr%eos(i)%p_eos = act_mod_ptr%eos(1)%p_eos
    enddo

    ! Initialize fallback eos
    act_mod_ptr%need_alternative_eos = .true.
    call init_fallback_and_redefine_criticals(silent=.true.)
  end subroutine init_pets

end module eoslibinit


       module compfrac
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Data module for parallel fracture dispersion interpolation calculations.
!D1
!***********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 2.20 [10086-STN-2.20-00]
!D2 Initial implementation: 28-Oct-02, Programmer: Z. Dash
!D2
!D2 $Log:   /pvcs.config/fehm90/src/compfrac.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:42:36   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 08:58:12   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!***********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 2.3.5 Cell-based particle-tracking module
!D3 2.3.6 Streamline particle-tracking module
!D3
!***********************************************************************
!D4
!D4 SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!***********************************************************************

      implicit none
      save

      integer :: numparams !Number of parameters defining type curves
      integer :: nump1     !Number of param1 values or number of curves
      integer :: nump2     !Number of param2 values
      integer :: nump3     !Number of param3 values
      integer :: d4        !Number of possible fracture-matrix flow interactions
      integer :: curve_structure   ! if 1, free format structure of curves
      integer :: log_flag(100)  ! If 0, use value itself in interpolation
!   if 1, take log of value first
      real :: normal_param(100)
!Number of time/concentration pairs in each curve
      integer, allocatable, dimension(:,:,:,:) :: nump
      integer, allocatable, dimension(:,:,:) :: itf_curve
      real, allocatable, dimension(:,:,:) :: wt_curve
      real weight_factor
!Maximum fracture flow fraction (upper limit) used in transfer function curves
      real*8 :: ffmax = 0.99
! Parameters to monitor range of values sampled in curves, first value
! will be max or min value in the curves, second value will be the
! max or min value sampled during calculations
      real*8 :: sigma_low(2), sigma_high(2), omega_low(2), omega_high(2)
      real*8 :: par3_low(2), par3_high(2)
      real*8, allocatable, dimension(:) :: param1
      real*8, allocatable, dimension(:) :: param2
      real*8, allocatable, dimension(:) :: param3
      real*8, allocatable, dimension(:,:,:,:,:) :: dtime
      real*8, allocatable, dimension(:,:,:,:,:) :: conc
      integer, allocatable, dimension(:,:,:) :: param_density

      logical :: pfrac_read = .false.
      integer :: ipartout = 0

      end module compfrac


!---------------------------------------------------------------------
      subroutine net_input0(time_start,time_end,tin,din,vin,zin,ein,xin)
      include 'implno.dek'
      include 'const.dek'
      include 'vector_eos.dek'
      include 'burn_common.dek'
      include 'network.dek'

! declare the pass
      double precision time_start,time_end,tin,din,vin,zin,ein,xin(*)

! local variables
      character*80  :: string,word
      logical       :: err
      integer       :: i,j,k,ibtype,ictype,igues,kkase,ians,getnam
      double precision xneut,xh1,xhe4,xc12,xc13,xn14,xo16,xne20,xne22,xmg24,&
                       xsi28,xs32,xfe52,xfe54,xfe56,xni56,zye,xx,abar,zbar, &
                       wbar,xcess,ye,ye_orig,xmup,xmun,qdum,a,z,xelem, &
                       andgrev,value2

! bigbang specifics
      real*8            :: fac

! popular format statements
01    format(1x,a,a,a)
02    format(1x,a,'=',1pe10.3,' ',a,'=',1pe10.3,' ', &
                a,'=',1pe10.3,' ',a,'=',1pe10.3,' ', &
                a,'=',1pe10.3)
03    format(a)
04    format(1x,a,'=',i2,' ',a,'=',i2,' ', &
                a,'=',i2,' ',a,'=',i2,' ', &
                a,'=',i2)

! initialize the common block variables
      call net_initialize

! inititailize local variables
      ibtype     = 0
      ictype     = 0
      time_start = 0.0d0
      time_end   = 0.0d0
      bpres      = 0.0d0
      tin        = 0.0d0
      din        = 0.0d0
      vin        = 0.0d0
      zin        = 0.0d0
      zye        = 0.0d0
      xin(1:ionmax) = 1.0d-30

!---------------------------------------------------------------------------

! get an alternative the stopping condition; when the
! mass fraction of a given isotope falls below a given level

!      write(6,*)
!      string = ' '
!      write(6,*) 'stop when an isotope falls below a given abundance?', &
!                  ' <cr> = no, any other input = yes :'
!      read(5,03) string
!      if (string(1:1) .eq. ' ') then
       name_stop  = 'he4 '
       xmass_stop = -1.0d30
       id_stop    = ihe4
!      else
!15     write(6,*) 'give the name of the isotope and the mass fraction'
!       write(6,*) 'for example: c12 0.50'
!       read(5,03) string
!       j = 1
!       i = getnam(string,word,j)
!       name_stop = word(1:5)
!       i = getnam(string,word,j)
!       xmass_stop = value2(word,err)
!       if (err) goto 15
!       write(6,*) name_stop,xmass_stop

! check that the name_stop isotope is in the network
!       do i=1,ionmax
!        if (ionam(i) .eq. name_stop) then
!         id_stop = i
!         goto 16
!        end if
!       enddo
!       write(6,*)
!       write(6,*) 'name_stop>',name_stop,'< not in network'
!       write(6,*)
!       goto 15
!       stop ' bad name for stopping isotope'
!      end if
! 16   continue

!---------------------------------------------------------------------------

! limit the temperature since the rates are invalid much above t9=100
       tin = min(1.0d11,tin)

!---------------------------------------------------------------------------

! there is probably a better place for this
! if requested, adjust the number of equations being solved

      if (pure_network .eq. 1) then
       neqs  = ionmax
       btemp = tin
       bden  = din
      end if

      return
      end
!---------------------------------------------------------------------


MODULE vars_obs

USE common, ONLY: r_size

IMPLICIT NONE

PUBLIC

REAL(r_size),SAVE :: dist_zero
REAL(r_size),SAVE :: dist_zerov
REAL(r_size),ALLOCATABLE,SAVE :: dlon_zero(:)
REAL(r_size),SAVE :: dlat_zero
REAL(r_size),ALLOCATABLE,SAVE :: obselm(:)
REAL(r_size),ALLOCATABLE,SAVE :: obslon(:)
REAL(r_size),ALLOCATABLE,SAVE :: obslat(:)
REAL(r_size),ALLOCATABLE,SAVE :: obslev(:)
REAL(r_size),ALLOCATABLE,SAVE :: obsdat(:)
REAL(r_size),ALLOCATABLE,SAVE :: obserr(:)
REAL(r_size),ALLOCATABLE,SAVE :: obsdep(:)
REAL(r_size),ALLOCATABLE,SAVE :: obshour(:)
REAL(r_size),ALLOCATABLE,SAVE :: obshdxf(:,:)
REAL(r_size),ALLOCATABLE,SAVE :: obsi(:)
REAL(r_size),ALLOCATABLE,SAVE :: obsj(:)
REAL(r_size),ALLOCATABLE,SAVE :: obsk(:)
INTEGER, ALLOCATABLE, SAVE :: obs_useidx(:) !STEVE: general version of nobs_use()
INTEGER, ALLOCATABLE, SAVE :: nobsgrd(:,:) !(nlon,nlat)
!STEVE: for (DRIFTERS)
REAL(r_size),ALLOCATABLE,SAVE :: obsid(:)
REAL(r_size),ALLOCATABLE,SAVE :: obstime(:)

END MODULE vars_obs


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1!!!!!!!!

subroutine fluxtable(ftable,wav,angles,atmfname,nfnames,ntheta,nwav)
implicit none
!Pythonic array indices, from 0 to n-1.
integer (kind=4) :: nwav,ntheta,nfnames
!f2py depend(nzth) nzth
!f2py depend(nzphi) nzphi
integer (kind=4) :: i,j,k,n
real (kind=8), dimension(0:nwav-1), intent(inout) :: wav
!f2py depend(nwav) wav
!real (kind=8), dimension(0:nwav-1,0:1) :: tempflux
! depend(nwav) tempflux
real (kind=8), dimension(0:nwav-1,0:ntheta-1,0:nfnames-1), intent(inout) :: ftable
!f2py depend(nwav,ntheta,nfnames) fluxtable
!real (kind=8), dimension(0:nwav-1,0:nzphi-1,0:nzth-1), intent(inout) :: fout
! depend(nwav,nzphi,nzth) fout
real (kind=8), dimension(0:ntheta-1) :: angles
!f2py depend(ntheta) angles
character (len=40), intent(in) :: atmfname
character (len=40) :: tempfname
!f2py intent(in,out) :: ftable
!f2py intent(in,out) :: wav

open(unit=66,file="tmp/"//trim(atmfname),status="OLD")
do i = 0,nfnames-1
    read(66,*) tempfname
    tempfname = trim(tempfname)//'.i'
    open(unit=7,file=tempfname,status="OLD")
    read(7,*) n
    read(7,*) (angles(j),j=0,ntheta-1)
    do j = 0,nwav-1
        read(7,*) wav(j)
        read(7,*) (ftable(j,k,i),k=0,ntheta-1)
    enddo
enddo

close(66)
close(7)
return
end subroutine  ! fluxtable

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1!!!!1!!1!!!!!1!!!!!!!!!!!!!!!!!
subroutine interp(tempflux,ftable,wav,angles,ext,dist,nfnames,ntheta,nwav,nzth,nzphi,incl)
implicit none
integer (kind=4) :: i,j,k,l,m,theta1,theta2
integer (kind=4) :: nwav,ntheta,nfnames,nzth,nzphi
real (kind=8) :: incl,p1,p2,p3,p4,ainte,dist,f11,f12,f21,f22,f31,f32,f41,f42
real (kind=8), dimension(0:nwav-1), intent(in) :: wav
!f2py depend(nwav) wav
real (kind=8), dimension(0:nwav-1,0:ntheta-1,0:nfnames-1), intent(in) :: ftable
!f2py depend(nwav,ntheta,nfnames) ftable
real (kind=8), dimension(0:nwav-1,0:nzphi-1,0:nzth-1) :: iout
!f2py depend(nwav,nzphi,nzth) iout
real (kind=8), dimension(0:nwav-1,0:1), intent(out) :: tempflux
!f2py depend(nwav) tempflux
real (kind=8), dimension(0:ntheta-1) :: angles
!f2py depend(ntheta) angles
real (kind=8), dimension(0:nzphi-1,0:nzth-1) :: cossquiggle
!f2py depend(nzphi,nzth) cossquiggle
integer (kind=4), dimension(0:nzth-1,0:3) :: atmkeys
!f2py depend(nzth) atmkeys
real (kind=8), dimension(0:nzth-1,0:5) :: tandg
!f2py depend(nzth) tandg
character (len=20) :: ext
!f2py intent(in) :: wav,ftable
!f2py intent(out) :: tempflux

!! Read in all the support files
open(unit=747,file="tmp/atmkeys")
open(unit=748,file="tmp/tandg")
open(unit=749,file="tmp/cossquiggle_i"//trim(ext))
do i=0,nzth-1
    read(747,*) (atmkeys(i,j),j=0,3)
    read(748,*) (tandg(i,j),j=0,5)
enddo
do i=0,nzphi-1
    read(749,*) (cossquiggle(i,j),j=0,nzth-1)
enddo
close(747)
close(748)
close(749)

do i=0,nzphi-1
    do j=0,nzth-1
        theta1=0
        theta2=1
        do k=0,ntheta-2
        if(cossquiggle(i,j)>=angles(k)) then
            theta1 = k
            theta2 = k+1
        endif
        enddo
        ainte = (cossquiggle(i,j)-angles(theta1))/(angles(theta2)-angles(theta1))
        if(cossquiggle(i,j)>=0) then
        do k=0,nwav-1
            p1 = (1.-ainte)*ftable(k,theta1,atmkeys(j,0))+ainte*ftable(k,theta2,atmkeys(j,0))
            p2 = (1.-ainte)*ftable(k,theta1,atmkeys(j,1))+ainte*ftable(k,theta2,atmkeys(j,1))
            p3 = (1.-ainte)*ftable(k,theta1,atmkeys(j,2))+ainte*ftable(k,theta2,atmkeys(j,2))
            p4 = (1.-ainte)*ftable(k,theta1,atmkeys(j,3))+ainte*ftable(k,theta2,atmkeys(j,3))
            iout(k,i,j)=tandg(j,5)*(tandg(j,4)*p1+(1.-tandg(j,4))*p2)+ &
                        (1-tandg(j,5))*(tandg(j,4)*p3+(1.-tandg(j,4))*p4)
			iout(k,i,j) = 10**(iout(k,i,j))
        enddo
        else
            iout(:,i,j)=0.
        endif
    enddo
enddo

call sumup(iout,tempflux,wav,dist,ext,ntheta,nwav,nzth,nzphi,incl)

return
end subroutine ! interp

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine sumup(iout,tempflux,wav,dist,ext,ntheta,nwav,nzth,nzphi,incl)
implicit none
integer (kind=4) :: i,j,k,l,m
integer (kind=4) :: nwav,ntheta,nfnames,nzth,nzphi
real (kind=8) :: incl,d,dist,temp
real (kind=8), dimension(0:nwav-1), intent(in) :: wav
!f2py depend(nwav) wav
real (kind=8), dimension(0:nwav-1,0:1), intent(inout) :: tempflux
!f2py depend(nwav) tempflux
real (kind=8), dimension(0:nwav-1,0:nzphi-1,0:nzth-1), intent(in) :: iout
!f2py depend(nwav,nzphi,nzth) iout
real (kind=8), dimension(0:nzphi-1,0:nzth-1) :: cossquiggle,darea
!f2py depend(nzphi,nzth) cossquiggle, darea
character (len=20) :: ext
!f2py intent(in,out) tempflux
!f2py intent(in) wav,fout

d = dist

!! Read in all the support files
open(unit=749,file="tmp/cossquiggle_i"//trim(ext))
open(unit=750,file="tmp/darea")
do i=0,nzphi-1
    read(749,*) (cossquiggle(i,j),j=0,nzth-1)
    read(750,*) (darea(i,j),j=0,nzth-1)
enddo
close(749)
close(750)

do i=0,nwav-1
    temp = sum(iout(i,:,:)*cossquiggle(:,:)*darea(:,:),MASK=iout(i,:,:).GT.0.0)/((d**2)*1.0e8)
    tempflux(i,1) = temp
    tempflux(i,0) = wav(i)
enddo

return
end subroutine ! sumup


	SUBROUTINE ZGTORB(ISTAT)
*
*  Module number:
*
*  Module name: ZGTORB
*
*  Keyphrase:
*  ----------
*       Read shp header keywords for orbital and positional information
*
*  Description:
*  ------------
*       This routine reads keywords from the shp that give
*	positional and orbital information about HST and
*       places the values in a common block.
*
*  FORTRAN name: zgtorb.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*  Name                         I/O     Description / Comments
*       <rootname>.SHH          I       GHRS data file
*
*  Subroutines Called:
*  -------------------
*  CDBS:
*       zmsput
*  SDAS:
*       uhdgs*
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       Oct 96  M. De La Pena   Copied and modified from YGTORB.FOR
*                                       written by S. Hulbert for CALFOS
*       1.1     Jan 97  M. De La Pena   Added SAAAVOID keyword
*-------------------------------------------------------------------------------
C
C PASSED PARAMETERS
C
        INTEGER ISTAT
C                                    --->ERROR status
C-------------------------------------------------------------------------------
C
C                       /HRSIO/
C Common Block containing input/output parameters
C
C   IDS(20) - input file IDs
C               1 - .shh
C               2 - .ulh
C               3 - .d0h
C               4 - .q0h
C               5 - .x0h
C               6 - .xqh
C               7 - .c0h
C               8 - .c1h
C               9 - .cqh
C               10 - .c2h
C               11 - .c3h
C               12 - .c4h
C               13 - .c5h
C   GCOUNT(20) - group counts for input files
C   MERGE - Number of bins merged in output spectra
C   OBSRPT - observation repeats
C   NGOUT - number of output groups
C   NGSDT - number of output groups for the special diode files
C   READNO - readout number
C   NSOUT - number of samples in output data sets
C
        INTEGER IDS(20),MERGE,OBSRPT,NGOUT,GCOUNT(20),READNO,NSOUT,NGSDT
        COMMON /HRSIO/ IDS,GCOUNT,MERGE,OBSRPT,NGOUT,READNO,NSOUT,NGSDT
C
C                       /ORBPAR/
C Common block containing orbital/positional parameters
C
        DOUBLE PRECISION EPCHTIME,SDMEANAN,CIRVELOC,COSINCLI
        DOUBLE PRECISION ECCENTRY,ECCENTX2,ECBDX4D3,ESQDX5D2,ECBDX3
        DOUBLE PRECISION FDMEANAN,RCASCNRV,ARGPERIG,MEANANOM,RCARGPER
        DOUBLE PRECISION RASCASCN,SINEINCL,SEMILREC
        DOUBLE PRECISION PSANGLV3,RTASCNV1,DECLNV1
        CHARACTER*2      SAAAVOID
        COMMON /ORBPAR/ EPCHTIME,SDMEANAN,CIRVELOC,COSINCLI,
     *  ECCENTRY,ECCENTX2,ECBDX4D3,ESQDX5D2,ECBDX3,
     *  FDMEANAN,RCASCNRV,ARGPERIG,MEANANOM,RCARGPER,
     *  RASCASCN,SINEINCL,SEMILREC,
     *  PSANGLV3,RTASCNV1,DECLNV1,SAAAVOID
C-------------------------------------------------------------------------------
C
C ZMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C-------------------------------------------------------------------------------
C
C Local variables
C
        INTEGER      I,ID,ISTATS(21)
        CHARACTER*8  NAMES(21)
        CHARACTER*80 CONTXT
C
        DATA NAMES/'EPCHTIME','SDMEANAN','CIRVELOC','COSINCLI',
     $  'ECCENTRY','ECCENTX2','ECBDX4D3','ESQDX5D2','ECBDX3',
     $  'FDMEANAN','RCASCNRV','ARGPERIG','MEANANOM','RCARGPER',
     $  'RASCASCN','SINEINCL','SEMILREC',
     $  'PA_V3','RA_V1','DEC_V1','SAAAVOID'/
C-------------------------------------------------------------------------------
C
        ID = IDS(1)
        CALL UHDGSD(ID,NAMES(1),EPCHTIME,ISTATS(1))
        CALL UHDGSD(ID,NAMES(2),SDMEANAN,ISTATS(2))
        CALL UHDGSD(ID,NAMES(3),CIRVELOC,ISTATS(3))
        CALL UHDGSD(ID,NAMES(4),COSINCLI,ISTATS(4))
        CALL UHDGSD(ID,NAMES(5),ECCENTRY,ISTATS(5))
        CALL UHDGSD(ID,NAMES(6),ECCENTX2,ISTATS(6))
        CALL UHDGSD(ID,NAMES(7),ECBDX4D3,ISTATS(7))
        CALL UHDGSD(ID,NAMES(8),ESQDX5D2,ISTATS(8))
        CALL UHDGSD(ID,NAMES(9),ECBDX3,ISTATS(9))
        CALL UHDGSD(ID,NAMES(10),FDMEANAN,ISTATS(10))
        CALL UHDGSD(ID,NAMES(11),RCASCNRV,ISTATS(11))
        CALL UHDGSD(ID,NAMES(12),ARGPERIG,ISTATS(12))
        CALL UHDGSD(ID,NAMES(13),MEANANOM,ISTATS(13))
        CALL UHDGSD(ID,NAMES(14),RCARGPER,ISTATS(14))
        CALL UHDGSD(ID,NAMES(15),RASCASCN,ISTATS(15))
        CALL UHDGSD(ID,NAMES(16),SINEINCL,ISTATS(16))
        CALL UHDGSD(ID,NAMES(17),SEMILREC,ISTATS(17))
        CALL UHDGSD(ID,NAMES(18),PSANGLV3,ISTATS(18))
        CALL UHDGSD(ID,NAMES(19),RTASCNV1,ISTATS(19))
        CALL UHDGSD(ID,NAMES(20),DECLNV1,ISTATS(20))
        CALL UHDGST(ID,NAMES(21),SAAAVOID,ISTATS(21))
C
        DO 100 I=1,21
            IF(ISTATS(I).NE.0)THEN
                CONTXT='ERROR reading keyword '//NAMES(I)//
     *                  ' from .shh file'
                GO TO 999
            ENDIF
100     CONTINUE
C
        ISTAT=0
        GO TO 1000
999     CALL ZMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
        ISTAT=1
1000    RETURN
        END


C----------------------------------------------------------------------
        subroutine ftgcxd(iunit,colnum,frow,nrow,fbit,nbit,
     &             dvalue,status)

C       read any consecutive bits from an 'X' or 'B' column as an unsigned
C       n-bit integer

C       iunit   i  fortran unit number
C       colnum  i  number of the column to read
C       frow    i  first row to read
C       nrow    i  number of rows to read
C       fbit    i  first bit within the row to read
C       nbit    i  number of bits to read
C       dvalue  d  returned value(s)
C       status  i  output error status
C
C       written by Wm Pence, HEASARC/GSFC, Nov 1994

C       COMMON BLOCK DEFINITIONS:--------------------------------------------
        integer nf,nb,ne
        parameter (nb = 20)
        parameter (nf = 3000)
        parameter (ne = 200)
        integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
        integer nxtfld
        logical wrmode
        common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
     &  wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
        integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount
        integer theap,nxheap
        double precision tscale,tzero
        common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
     &  tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb)
     &  ,theap(nb),nxheap(nb)
C       END OF COMMON BLOCK DEFINITIONS-----------------------------------

        integer iunit,colnum,fbit,nbit,frow,nrow,status
        integer i,k,istart,itodo,ntodo,row,ibuff
        double precision dvalue(*),power,dval
        logical lray(64)

        if (status .gt. 0)return

        ibuff=bufnum(iunit)
        if ((fbit+nbit+6)/8 .gt. trept(colnum+tstart(ibuff)))then
            call ftpmsg('Asked to read more bits than exist in'//
     &      ' the column (ftgcxd)')
            status=308
            return
        end if

        row=frow-1
        do 30 k=1,nrow
            row=row+1
            dval=0.
            power=1.0D+00
            istart=fbit+nbit
            ntodo=nbit

10          itodo=min(ntodo,64)
            istart=istart-itodo

C           read up to 64 bits at a time
C           get the individual bits
            call ftgcx(iunit,colnum,row,istart,itodo,lray,status)
            if (status .gt. 0)return

C           reconstruct the positive integer value
            do 20 i=itodo,1,-1
                if (lray(i))dval=dval+power
                power=power*2.0D+00
20          continue

            ntodo=ntodo-itodo
            if (itodo .gt. 0)go to 10
            dvalue(k)=dval
30      continue
        end


! ======================================================================
!
! Contains all of the default values regarding output file generation
!
! ======================================================================

  ! For naming
  integer(int32), parameter, private :: nameLength = 128
  character(*), parameter, private :: &
       & defaultInpFile = "gsm.inp", & ! Default input file name
       & defaultOutFile = "gsm.out", & ! Default output file name (contains simulation results)
       & defaultAuxFile = "gsm.aux"    ! Default aux. file name (contains simulation warnings and errors)

  ! Maximum allowed input file comments
  integer(int32), parameter, private :: maxCommentLines = 10_int32

  ! Default number of inelastic events to simulate
  integer(int64), parameter, private :: defaultInelasticEvents = 100000_int64

  ! Output options
  integer(int32), parameter, private :: &
       & defaultAngSpec       = 0_int32, & ! Default for angular integrated spectra
       & defaultEnergySpec    = 0_int32, & ! Default for energy integrated spectra
       & defaultDoubDiffSpec  = 0_int32, & ! Default for double differential spectra
       & defaultMultiplicity  = 0_int32, & ! Default for calculating particle multiplicities
       & defaultChannelXSCalc = 0_int32, & ! Default for calculating reaction channel cross sections
       & defaultNuclideXSCalc = 0_int32    ! Default for calculation nuclide cross section
  logical, parameter, private :: &
       & defaultPISAPrint     = .FALSE., & ! Default for printing PISA cross section tables
       & defaultHistPrint     = .FALSE.    ! Default for printing HIST residual tables

  ! Default angular bin width for spectra calculation
  !    (energy int., angle int., double diff.)
  real(real64), parameter, private :: &
       & defaultDTheta = 5.0_real64, &
       & halfDTheta = defaultDTheta / 2.0_real64

  ! The number of angles considered for particle emission
  integer(int32), parameter, public :: numAnglesConsidered = 10_int32

  ! The default angles considered for PISA histograms
  real(real64), parameter, private, dimension(numAnglesConsidered) :: &
       & defaultPisaAngles = [ &
       &  15.0_real64,  30.0_real64,  45.0_real64,  60.0_real64, &
       &  75.0_real64,  90.0_real64, 105.0_real64, 120.0_real64, &
       & 135.0_real64, 150.0_real64 &
       & ]

  ! The default number of angles considered for ejectile spectra
  type(histogramBin), parameter, private, dimension(numAnglesConsidered) :: &
       & defaultAngleBins = [ (histogramBin( &
       &       defaultPisaAngles(iter) - halfDTheta, defaultPisaAngles(iter) + halfDTheta), &
       &    iter=1,numAnglesConsidered) ]

  ! Number of grouped energy bins considered
  integer(int32), parameter, private :: numEnergyBins = 4_int32

  ! Default grouped energy bins
  type(histogramBin), parameter, private, dimension(numEnergyBins) :: &
       & defaultEnergyBins = &
       & [ histogramBin(   0.0_real64,  250.0_real64), &
       &   histogramBin( 250.0_real64,  500.0_real64), &
       &   histogramBin( 500.0_real64, 1000.0_real64), &
       &   histogramBin(1000.0_real64, 2500.0_real64)  &
       & ]
  ! Default sub-step size for energy bins
  real(real64), parameter, private, dimension(numEnergyBins) :: &
       & defaultEnergyBinSubStep = &
       & [  2.0_real64, &
       &    5.0_real64, &
       &   10.0_real64, &
       &   25.0_real64  &
       & ]

  ! Number of ejectiles considered for spectra calculations
  integer(int32), parameter, private :: numSpecEjectiles = 9_int32

  ! Default flags for ejectile includsion regarding spectra calculations
  logical, parameter, private, dimension(numSpecEjectiles) :: &
       & defaultEjectiles = [(.TRUE., iter=1, 9)]