module kinds use, intrinsic :: iso_fortran_env use, intrinsic :: iso_c_binding implicit none private !!! available REAL kinds ! prec. ! ISO ! C integer, parameter :: single = 4 ! 1.. 6 ! real32 ! c_float integer, parameter :: double = 8 ! 7..15 ! real64 ! c_double public :: single, double public :: default, c_default_float, c_default_complex integer, parameter :: default = double integer, parameter :: c_default_float = c_double integer, parameter :: c_default_complex = c_double_complex end module kinds module iso_varying_string implicit none integer, parameter, private :: GET_BUFFER_LEN = 1 type, public :: varying_string private character(LEN=1), dimension(:), allocatable :: chars end type varying_string interface assignment(=) module procedure op_assign_CH_VS module procedure op_assign_VS_CH end interface assignment(=) interface operator(//) module procedure op_concat_VS_VS module procedure op_concat_CH_VS module procedure op_concat_VS_CH end interface operator(//) interface operator(==) module procedure op_eq_VS_VS module procedure op_eq_CH_VS module procedure op_eq_VS_CH end interface operator(==) interface char module procedure char_auto module procedure char_fixed end interface char interface len module procedure len_ end interface len interface trim module procedure trim_ end interface trim interface var_str module procedure var_str_ end interface var_str public :: assignment(=) public :: operator(//) public :: operator(==) public :: char public :: len public :: trim public :: var_str private :: op_assign_CH_VS private :: op_assign_VS_CH private :: op_concat_VS_VS private :: op_concat_CH_VS private :: op_concat_VS_CH private :: op_eq_VS_VS private :: op_eq_CH_VS private :: op_eq_VS_CH private :: char_auto private :: char_fixed private :: len_ private :: trim_ private :: var_str_ contains elemental function len_ (string) result (length) type(varying_string), intent(in) :: string integer :: length if(ALLOCATED(string%chars)) then length = SIZE(string%chars) else length = 0 endif end function len_ elemental subroutine op_assign_CH_VS (var, exp) character(LEN=*), intent(out) :: var type(varying_string), intent(in) :: exp var = char(exp) end subroutine op_assign_CH_VS elemental subroutine op_assign_VS_CH (var, exp) type(varying_string), intent(out) :: var character(LEN=*), intent(in) :: exp var = var_str(exp) end subroutine op_assign_VS_CH elemental function op_concat_VS_VS (string_a, string_b) result (concat_string) type(varying_string), intent(in) :: string_a type(varying_string), intent(in) :: string_b type(varying_string) :: concat_string integer :: len_string_a len_string_a = len(string_a) ALLOCATE(concat_string%chars(len_string_a+len(string_b))) concat_string%chars(:len_string_a) = string_a%chars concat_string%chars(len_string_a+1:) = string_b%chars end function op_concat_VS_VS elemental function op_concat_CH_VS (string_a, string_b) result (concat_string) character(LEN=*), intent(in) :: string_a type(varying_string), intent(in) :: string_b type(varying_string) :: concat_string concat_string = op_concat_VS_VS(var_str(string_a), string_b) end function op_concat_CH_VS elemental function op_concat_VS_CH (string_a, string_b) result (concat_string) type(varying_string), intent(in) :: string_a character(LEN=*), intent(in) :: string_b type(varying_string) :: concat_string concat_string = op_concat_VS_VS(string_a, var_str(string_b)) end function op_concat_VS_CH elemental function op_eq_VS_VS (string_a, string_b) result (op_eq) type(varying_string), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: op_eq op_eq = char(string_a) == char(string_b) end function op_eq_VS_VS elemental function op_eq_CH_VS (string_a, string_b) result (op_eq) character(LEN=*), intent(in) :: string_a type(varying_string), intent(in) :: string_b logical :: op_eq op_eq = string_a == char(string_b) end function op_eq_CH_VS elemental function op_eq_VS_CH (string_a, string_b) result (op_eq) type(varying_string), intent(in) :: string_a character(LEN=*), intent(in) :: string_b logical :: op_eq op_eq = char(string_a) == string_b end function op_eq_VS_CH pure function char_auto (string) result (char_string) type(varying_string), intent(in) :: string character(LEN=len(string)) :: char_string integer :: i_char forall(i_char = 1:len(string)) char_string(i_char:i_char) = string%chars(i_char) end forall end function char_auto pure function char_fixed (string, length) result (char_string) type(varying_string), intent(in) :: string integer, intent(in) :: length character(LEN=length) :: char_string char_string = char(string) end function char_fixed elemental function trim_ (string) result (trim_string) type(varying_string), intent(in) :: string type(varying_string) :: trim_string trim_string = TRIM(char(string)) end function trim_ elemental function var_str_ (char) result (string) character(LEN=*), intent(in) :: char type(varying_string) :: string integer :: length integer :: i_char length = LEN(char) ALLOCATE(string%chars(length)) forall(i_char = 1:length) string%chars(i_char) = char(i_char:i_char) end forall return end function var_str_ end module iso_varying_string module model_data use, intrinsic :: iso_c_binding !NODEP! use kinds, only: default use iso_varying_string, string_t => varying_string implicit none private public :: modelpar_data_t public :: field_data_t public :: model_data_t type, abstract :: modelpar_data_t private type(string_t) :: name contains generic :: init => modelpar_data_init_real, modelpar_data_init_complex procedure, private :: modelpar_data_init_real procedure, private :: modelpar_data_init_complex generic :: assignment(=) => modelpar_data_set_real, modelpar_data_set_complex procedure, private :: modelpar_data_set_real procedure, private :: modelpar_data_set_complex procedure, pass :: get_real => modelpar_data_get_real procedure, pass :: get_complex => modelpar_data_get_complex procedure :: get_real_ptr => modelpar_data_get_real_ptr procedure :: get_complex_ptr => modelpar_data_get_complex_ptr end type modelpar_data_t type, extends (modelpar_data_t) :: modelpar_real_t private real(default) :: value end type modelpar_real_t type, extends (modelpar_data_t) :: modelpar_complex_t private complex(default) :: value end type modelpar_complex_t type :: field_data_t private type(string_t) :: longname integer :: pdg = 0 logical :: visible = .true. logical :: parton = .false. logical :: gauge = .false. logical :: has_anti = .false. type(string_t), dimension(:), allocatable :: name, anti type(string_t) :: tex_name, tex_anti integer :: spin_type = 0 integer :: isospin_type = 1 integer :: charge_type = 1 integer :: color_type = 1 real(default), pointer :: mass_val => null () class(modelpar_data_t), pointer :: mass_data => null () real(default), pointer :: width_val => null () class(modelpar_data_t), pointer :: width_data => null () integer :: multiplicity = 1 type(string_t), dimension(:), allocatable :: p_decay type(string_t), dimension(:), allocatable :: a_decay contains procedure :: init => field_data_init procedure :: set => field_data_set procedure, private :: & set_multiplicity => field_data_set_multiplicity procedure :: freeze => field_data_freeze end type field_data_t type :: model_data_t private type(string_t) :: name integer :: scheme = 0 type(modelpar_real_t), dimension(:), pointer :: par_real => null () type(modelpar_complex_t), dimension(:), pointer :: par_complex => null () type(field_data_t), dimension(:), allocatable :: field contains procedure :: final => model_data_final generic :: init => model_data_init procedure, private :: model_data_init procedure :: freeze_fields => model_data_freeze_fields generic :: init_par => model_data_init_par_real, model_data_init_par_complex procedure, private :: model_data_init_par_real procedure, private :: model_data_init_par_complex procedure :: real_parameters_from_array & => model_data_real_par_from_array procedure :: complex_parameters_from_array & => model_data_complex_par_from_array procedure :: get_par_real_ptr => model_data_get_par_real_ptr_index procedure :: get_par_complex_ptr => model_data_get_par_complex_ptr_index procedure :: get_par_data_ptr => model_data_get_par_data_ptr_name procedure :: get_real => model_data_get_par_real_value procedure :: get_complex => model_data_get_par_complex_value generic :: set_par => model_data_set_par_real, model_data_set_par_complex procedure, private :: model_data_set_par_real procedure, private :: model_data_set_par_complex procedure :: get_n_field => model_data_get_n_field procedure :: get_field_ptr_by_index => model_data_get_field_ptr_index procedure :: field_error => model_data_field_error procedure :: init_test => model_data_init_test end type model_data_t contains subroutine modelpar_data_init_real (par, name, value) class(modelpar_data_t), intent(out) :: par type(string_t), intent(in) :: name real(default), intent(in) :: value par%name = name par = value end subroutine modelpar_data_init_real subroutine modelpar_data_init_complex (par, name, value) class(modelpar_data_t), intent(out) :: par type(string_t), intent(in) :: name complex(default), intent(in) :: value par%name = name par = value end subroutine modelpar_data_init_complex elemental subroutine modelpar_data_set_real (par, value) class(modelpar_data_t), intent(inout) :: par real(default), intent(in) :: value select type (par) type is (modelpar_real_t) par%value = value type is (modelpar_complex_t) par%value = value end select end subroutine modelpar_data_set_real elemental subroutine modelpar_data_set_complex (par, value) class(modelpar_data_t), intent(inout) :: par complex(default), intent(in) :: value select type (par) type is (modelpar_real_t) par%value = value type is (modelpar_complex_t) par%value = value end select end subroutine modelpar_data_set_complex elemental function modelpar_data_get_real (par) result (value) class(modelpar_data_t), intent(in), target :: par real(default) :: value select type (par) type is (modelpar_real_t) value = par%value type is (modelpar_complex_t) value = par%value end select end function modelpar_data_get_real elemental function modelpar_data_get_complex (par) result (value) class(modelpar_data_t), intent(in), target :: par complex(default) :: value select type (par) type is (modelpar_real_t) value = par%value type is (modelpar_complex_t) value = par%value end select end function modelpar_data_get_complex function modelpar_data_get_real_ptr (par) result (ptr) class(modelpar_data_t), intent(in), target :: par real(default), pointer :: ptr select type (par) type is (modelpar_real_t) ptr => par%value class default ptr => null () end select end function modelpar_data_get_real_ptr function modelpar_data_get_complex_ptr (par) result (ptr) class(modelpar_data_t), intent(in), target :: par complex(default), pointer :: ptr select type (par) type is (modelpar_complex_t) ptr => par%value class default ptr => null () end select end function modelpar_data_get_complex_ptr subroutine field_data_init (prt, longname, pdg) class(field_data_t), intent(out) :: prt type(string_t), intent(in) :: longname integer, intent(in) :: pdg prt%longname = longname prt%pdg = pdg prt%tex_name = "" prt%tex_anti = "" end subroutine field_data_init subroutine field_data_set (prt, & is_visible, is_parton, is_gauge, & name, anti, tex_name, tex_anti, & spin_type, isospin_type, charge_type, color_type, & mass_data, width_data, & p_decay, a_decay) class(field_data_t), intent(inout) :: prt logical, intent(in), optional :: is_visible, is_parton, is_gauge type(string_t), dimension(:), intent(in), optional :: name, anti type(string_t), intent(in), optional :: tex_name, tex_anti integer, intent(in), optional :: spin_type, isospin_type integer, intent(in), optional :: charge_type, color_type class(modelpar_data_t), intent(in), pointer, optional :: mass_data, width_data type(string_t), dimension(:), intent(in), optional :: p_decay, a_decay if (present (name)) then if (allocated (prt%name)) deallocate (prt%name) allocate (prt%name (size (name)), source = name) end if if (present (anti)) then if (allocated (prt%anti)) deallocate (prt%anti) allocate (prt%anti (size (anti)), source = anti) prt%has_anti = .true. end if if (present (tex_name)) prt%tex_name = tex_name if (present (tex_anti)) prt%tex_anti = tex_anti if (present (spin_type)) prt%spin_type = spin_type if (present (isospin_type)) prt%isospin_type = isospin_type if (present (charge_type)) prt%charge_type = charge_type if (present (color_type)) prt%color_type = color_type if (present (mass_data)) then prt%mass_data => mass_data if (associated (mass_data)) then prt%mass_val => mass_data%get_real_ptr () else prt%mass_val => null () end if end if if (present (width_data)) then prt%width_data => width_data if (associated (width_data)) then prt%width_val => width_data%get_real_ptr () else prt%width_val => null () end if end if if (present (spin_type) .or. present (mass_data)) then call prt%set_multiplicity () end if if (present (p_decay)) then if (allocated (prt%p_decay)) deallocate (prt%p_decay) if (size (p_decay) > 0) & allocate (prt%p_decay (size (p_decay)), source = p_decay) end if if (present (a_decay)) then if (allocated (prt%a_decay)) deallocate (prt%a_decay) if (size (a_decay) > 0) & allocate (prt%a_decay (size (a_decay)), source = a_decay) end if end subroutine field_data_set subroutine field_data_set_multiplicity (prt) class(field_data_t), intent(inout) :: prt if (prt%spin_type /= 1) then if (associated (prt%mass_data)) then prt%multiplicity = prt%spin_type else prt%multiplicity = 2 end if end if end subroutine field_data_set_multiplicity elemental subroutine field_data_freeze (prt) class(field_data_t), intent(inout) :: prt if (.not. allocated (prt%name)) allocate (prt%name (0)) if (.not. allocated (prt%anti)) allocate (prt%anti (0)) end subroutine field_data_freeze subroutine model_data_final (model) class(model_data_t), intent(inout) :: model if (associated (model%par_real)) then deallocate (model%par_real) end if if (associated (model%par_complex)) then deallocate (model%par_complex) end if end subroutine model_data_final subroutine model_data_init (model, name, & n_par_real, n_par_complex, n_field, n_vtx) class(model_data_t), intent(out) :: model type(string_t), intent(in) :: name integer, intent(in) :: n_par_real, n_par_complex integer, intent(in) :: n_field integer, intent(in) :: n_vtx model%name = name allocate (model%par_real (n_par_real)) allocate (model%par_complex (n_par_complex)) allocate (model%field (n_field)) end subroutine model_data_init subroutine model_data_freeze_fields (model) class(model_data_t), intent(inout) :: model call model%field%freeze () end subroutine model_data_freeze_fields subroutine model_data_init_par_real (model, i, name, value) class(model_data_t), intent(inout) :: model integer, intent(in) :: i type(string_t), intent(in) :: name real(default), intent(in) :: value call model%par_real(i)%init (name, value) end subroutine model_data_init_par_real subroutine model_data_init_par_complex (model, i, name, value) class(model_data_t), intent(inout) :: model integer, intent(in) :: i type(string_t), intent(in) :: name complex(default), intent(in) :: value call model%par_complex(i)%init (name, value) end subroutine model_data_init_par_complex subroutine model_data_real_par_from_array (model, array) class(model_data_t), intent(inout) :: model real(default), dimension(:), intent(in) :: array model%par_real = array end subroutine model_data_real_par_from_array subroutine model_data_complex_par_from_array (model, array) class(model_data_t), intent(inout) :: model complex(default), dimension(:), intent(in) :: array model%par_complex = array end subroutine model_data_complex_par_from_array function model_data_get_par_real_ptr_index (model, i) result (ptr) class(model_data_t), intent(inout) :: model integer, intent(in) :: i class(modelpar_data_t), pointer :: ptr ptr => model%par_real(i) end function model_data_get_par_real_ptr_index function model_data_get_par_complex_ptr_index (model, i) result (ptr) class(model_data_t), intent(inout) :: model integer, intent(in) :: i class(modelpar_data_t), pointer :: ptr ptr => model%par_complex(i) end function model_data_get_par_complex_ptr_index function model_data_get_par_data_ptr_name (model, name) result (ptr) class(model_data_t), intent(in) :: model type(string_t), intent(in) :: name class(modelpar_data_t), pointer :: ptr integer :: i do i = 1, size (model%par_real) if (model%par_real(i)%name == name) then ptr => model%par_real(i) return end if end do do i = 1, size (model%par_complex) if (model%par_complex(i)%name == name) then ptr => model%par_complex(i) return end if end do ptr => null () end function model_data_get_par_data_ptr_name function model_data_get_par_real_value (model, name) result (value) class(model_data_t), intent(in) :: model type(string_t), intent(in) :: name class(modelpar_data_t), pointer :: par real(default) :: value par => model%get_par_data_ptr (name) value = par%get_real () end function model_data_get_par_real_value function model_data_get_par_complex_value (model, name) result (value) class(model_data_t), intent(in) :: model type(string_t), intent(in) :: name class(modelpar_data_t), pointer :: par complex(default) :: value par => model%get_par_data_ptr (name) value = par%get_complex () end function model_data_get_par_complex_value subroutine model_data_set_par_real (model, name, value) class(model_data_t), intent(inout) :: model type(string_t), intent(in) :: name real(default), intent(in) :: value class(modelpar_data_t), pointer :: par par => model%get_par_data_ptr (name) par = value end subroutine model_data_set_par_real subroutine model_data_set_par_complex (model, name, value) class(model_data_t), intent(inout) :: model type(string_t), intent(in) :: name complex(default), intent(in) :: value class(modelpar_data_t), pointer :: par par => model%get_par_data_ptr (name) par = value end subroutine model_data_set_par_complex function model_data_get_n_field (model) result (n) class(model_data_t), intent(in) :: model integer :: n n = size (model%field) end function model_data_get_n_field function model_data_get_field_ptr_index (model, i) result (ptr) class(model_data_t), intent(in), target :: model integer, intent(in) :: i type(field_data_t), pointer :: ptr ptr => model%field(i) end function model_data_get_field_ptr_index subroutine model_data_field_error (model, check, name, pdg) class(model_data_t), intent(in) :: model logical, intent(in), optional :: check type(string_t), intent(in), optional :: name integer, intent(in), optional :: pdg end subroutine model_data_field_error subroutine model_data_init_test (model) class(model_data_t), intent(out) :: model type(field_data_t), pointer :: field integer, parameter :: n_real = 4 integer, parameter :: n_field = 2 integer, parameter :: n_vertex = 0 integer :: i call model%init (var_str ("Test"), & n_real, 0, n_field, n_vertex) i = 0 i = i + 1 call model%init_par (i, var_str ("gy"), 1._default) i = i + 1 call model%init_par (i, var_str ("ms"), 125._default) i = i + 1 call model%init_par (i, var_str ("ff"), 1.5_default) i = i + 1 call model%init_par (i, var_str ("mf"), 1.5_default * 125._default) i = 0 i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("SCALAR"), 25) call field%set (spin_type=1) call field%set (mass_data=model%get_par_real_ptr (2)) call field%set (name = [var_str ("s")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("FERMION"), 6) call field%set (spin_type=2) call field%set (mass_data=model%get_par_real_ptr (4)) call field%set (name = [var_str ("f")], anti = [var_str ("fbar")]) call model%freeze_fields () end subroutine model_data_init_test end module model_data module prclib_interfaces use, intrinsic :: iso_c_binding !NODEP! use kinds use iso_varying_string, string_t => varying_string implicit none private public :: prc_writer_t public :: prclib_driver_t public :: prc_get_int public :: prc_set_int_tab1 type, abstract :: prc_writer_t end type prc_writer_t type :: prclib_driver_record_t type(string_t) :: id type(string_t) :: model_name type(string_t), dimension(:), allocatable :: feature class(prc_writer_t), pointer :: writer => null () end type prclib_driver_record_t type, abstract :: prclib_driver_t type(string_t) :: basename logical :: loaded = .false. type(string_t) :: libname type(string_t) :: modellibs_ldflags integer :: n_processes = 0 type(prclib_driver_record_t), dimension(:), allocatable :: record procedure(prc_get_int), nopass, pointer :: get_n_in => null () end type prclib_driver_t abstract interface function get_const_string () result (string) import type(string_t) :: string end function get_const_string end interface abstract interface function prc_get_int (pid) result (n) bind(C) import integer(c_int), intent(in) :: pid integer(c_int) :: n end function prc_get_int end interface abstract interface subroutine prc_set_int_tab1 (pid, tab, shape) bind(C) import integer(c_int), intent(in) :: pid integer(c_int), dimension(*), intent(out) :: tab integer(c_int), dimension(2), intent(in) :: shape end subroutine prc_set_int_tab1 end interface end module prclib_interfaces module prc_core_def use iso_varying_string, string_t => varying_string use prclib_interfaces implicit none private public :: prc_core_def_t public :: prc_core_driver_t public :: process_driver_internal_t type, abstract :: prc_core_def_t end type prc_core_def_t type, abstract :: prc_core_driver_t end type prc_core_driver_t type, extends (prc_core_driver_t), abstract :: process_driver_internal_t end type process_driver_internal_t abstract interface function prc_core_def_get_string () result (string) import type(string_t) :: string end function prc_core_def_get_string end interface end module prc_core_def module particle_specifiers use iso_varying_string, string_t => varying_string implicit none private public :: prt_expr_t public :: prt_spec_t public :: new_prt_spec public :: prt_spec_list_t type, abstract :: prt_spec_expr_t contains procedure (prt_spec_expr_to_string), deferred :: to_string end type prt_spec_expr_t type :: prt_expr_t class(prt_spec_expr_t), allocatable :: x contains procedure :: to_string => prt_expr_to_string end type prt_expr_t type, extends (prt_spec_expr_t) :: prt_spec_t private type(string_t) :: name type(string_t), dimension(:), allocatable :: decay contains procedure :: to_string => prt_spec_to_string end type prt_spec_t type, extends (prt_spec_expr_t) :: prt_spec_list_t type(prt_expr_t), dimension(:), allocatable :: expr contains procedure :: to_string => prt_spec_list_to_string end type prt_spec_list_t abstract interface function prt_spec_expr_to_string (object) result (string) import class(prt_spec_expr_t), intent(in) :: object type(string_t) :: string end function prt_spec_expr_to_string end interface interface new_prt_spec module procedure new_prt_spec end interface new_prt_spec contains recursive function prt_expr_to_string (object) result (string) class(prt_expr_t), intent(in) :: object type(string_t) :: string if (allocated (object%x)) then string = object%x%to_string () else string = "" end if end function prt_expr_to_string elemental function new_prt_spec (name) result (prt_spec) type(string_t), intent(in) :: name type(prt_spec_t) :: prt_spec prt_spec%name = name end function new_prt_spec function prt_spec_to_string (object) result (string) class(prt_spec_t), intent(in) :: object type(string_t) :: string integer :: i string = object%name if (allocated (object%decay)) then string = string // "(" do i = 1, size (object%decay) if (i > 1) string = string // " + " string = string // object%decay(i) end do string = string // ")" end if end function prt_spec_to_string recursive function prt_spec_list_to_string (object) result (string) class(prt_spec_list_t), intent(in) :: object type(string_t) :: string integer :: i string = "" if (allocated (object%expr)) then do i = 1, size (object%expr) if (i > 1) string = string // ", " select type (x => object%expr(i)%x) type is (prt_spec_list_t) string = string // "(" // x%to_string () // ")" class default string = string // x%to_string () end select end do end if end function prt_spec_list_to_string end module particle_specifiers module process_libraries use, intrinsic :: iso_c_binding !NODEP! use iso_varying_string, string_t => varying_string use model_data use prclib_interfaces use prc_core_def use particle_specifiers implicit none private public :: process_component_def_t public :: process_def_t public :: process_def_entry_t public :: process_def_list_t public :: process_library_t integer, parameter, public :: STAT_UNKNOWN = 0 integer, parameter, public :: STAT_OPEN = 1 integer, parameter, public :: STAT_CONFIGURED = 2 integer, parameter, public :: STAT_SOURCE = 3 integer, parameter, public :: STAT_COMPILED = 4 integer, parameter, public :: STAT_LINKED = 5 integer, parameter, public :: STAT_ACTIVE = 6 character, dimension(0:6), parameter :: STATUS_LETTER = & ["?", "o", "f", "s", "c", "l", "a"] type :: process_component_def_t private type(string_t) :: basename logical :: initial = .false. integer :: n_in = 0 integer :: n_out = 0 integer :: n_tot = 0 type(prt_spec_t), dimension(:), allocatable :: prt_in type(prt_spec_t), dimension(:), allocatable :: prt_out type(string_t) :: method type(string_t) :: description class(prc_core_def_t), allocatable :: core_def logical :: active integer :: fixed_emitter = -1 contains procedure :: get_n_in => process_component_def_get_n_in end type process_component_def_t type :: process_def_t private type(string_t) :: id class(model_data_t), pointer :: model => null () type(string_t) :: model_name integer :: n_in = 0 integer :: n_initial = 0 integer :: n_extra = 0 type(process_component_def_t), dimension(:), allocatable :: initial type(process_component_def_t), dimension(:), allocatable :: extra contains procedure :: init => process_def_init procedure :: import_component => process_def_import_component procedure :: get_n_in => process_def_get_n_in end type process_def_t type, extends (process_def_t) :: process_def_entry_t private type(process_def_entry_t), pointer :: next => null () end type process_def_entry_t type :: process_def_list_t private type(process_def_entry_t), pointer :: first => null () type(process_def_entry_t), pointer :: last => null () contains procedure :: append => process_def_list_append procedure :: get_process_def_ptr => process_def_list_get_process_def_ptr procedure :: get_n_in => process_def_list_get_n_in end type process_def_list_t type :: process_library_entry_t private integer :: status = STAT_UNKNOWN type(process_def_t), pointer :: def => null () integer :: i_component = 0 integer :: i_external = 0 class(prc_core_driver_t), allocatable :: driver contains procedure :: init => process_library_entry_init end type process_library_entry_t type, extends (process_def_list_t) :: process_library_t private type(string_t) :: basename integer :: n_entries = 0 logical :: external = .false. integer :: status = STAT_UNKNOWN logical :: static = .false. logical :: driver_exists = .false. logical :: makefile_exists = .false. integer :: update_counter = 0 type(process_library_entry_t), dimension(:), allocatable :: entry class(prclib_driver_t), allocatable :: driver contains procedure :: init => process_library_init procedure :: configure => process_library_configure procedure :: allocate_entries => process_library_allocate_entries procedure :: load => process_library_load end type process_library_t contains function process_component_def_get_n_in (component) result (n_in) class(process_component_def_t), intent(in) :: component integer :: n_in n_in = component%n_in end function process_component_def_get_n_in subroutine process_def_init (def, id, & model, model_name, n_in, n_components) class(process_def_t), intent(out) :: def type(string_t), intent(in), optional :: id class(model_data_t), intent(in), optional, target :: model type(string_t), intent(in), optional :: model_name integer, intent(in), optional :: n_in integer, intent(in), optional :: n_components character(16) :: suffix integer :: i if (present (id)) then def%id = id else def%id = "" end if if (present (model)) then def%model => model def%model_name = "Test" else def%model => null () if (present (model_name)) then def%model_name = model_name else def%model_name = "" end if end if if (present (n_in)) def%n_in = n_in if (present (n_components)) then def%n_initial = n_components allocate (def%initial (n_components)) end if def%initial%initial = .true. def%initial%method = "" do i = 1, def%n_initial write (suffix, "(A,I0)") "_i", i def%initial(i)%basename = def%id // trim (suffix) end do def%initial%description = "" end subroutine process_def_init subroutine process_def_import_component (def, & i, n_out, prt_in, prt_out, method, variant) class(process_def_t), intent(inout) :: def integer, intent(in) :: i integer, intent(in), optional :: n_out type(prt_spec_t), dimension(:), intent(in), optional :: prt_in type(prt_spec_t), dimension(:), intent(in), optional :: prt_out type(string_t), intent(in), optional :: method class(prc_core_def_t), & intent(inout), allocatable, optional :: variant integer :: p associate (comp => def%initial(i)) if (present (n_out)) then comp%n_in = def%n_in comp%n_out = n_out comp%n_tot = def%n_in + n_out end if if (present (prt_in)) then allocate (comp%prt_in (size (prt_in))) comp%prt_in = prt_in end if if (present (prt_out)) then allocate (comp%prt_out (size (prt_out))) comp%prt_out = prt_out end if if (present (method)) comp%method = method if (present (variant)) then call move_alloc (variant, comp%core_def) end if comp%active = .true. if (allocated (comp%prt_in) .and. allocated (comp%prt_out)) then associate (d => comp%description) d = "" do p = 1, size (prt_in) if (p > 1) d = d // ", " d = d // comp%prt_in(p)%to_string () end do d = d // " => " do p = 1, size (prt_out) if (p > 1) d = d // ", " d = d // comp%prt_out(p)%to_string () end do end associate end if end associate end subroutine process_def_import_component function process_def_get_n_in (def) result (n_in) class(process_def_t), intent(in) :: def integer :: n_in n_in = def%n_in end function process_def_get_n_in subroutine process_def_list_append (list, entry) class(process_def_list_t), intent(inout) :: list type(process_def_entry_t), intent(inout), pointer :: entry if (associated (list%first)) then list%last%next => entry else list%first => entry end if list%last => entry entry => null () end subroutine process_def_list_append function process_def_list_get_process_def_ptr (list, id) result (entry) type(process_def_entry_t), pointer :: entry class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(process_def_entry_t), pointer :: current current => list%first do while (associated (current)) if (id == current%id) exit current => current%next end do entry => current end function process_def_list_get_process_def_ptr function process_def_list_get_n_in (list, id) result (n) integer :: n class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(process_def_entry_t), pointer :: current current => list%get_process_def_ptr (id) if (associated (current)) then n = current%n_in else n = 0 end if end function process_def_list_get_n_in subroutine process_library_entry_init (object, & status, def, i_component, i_external, driver_template) class(process_library_entry_t), intent(out) :: object integer, intent(in) :: status type(process_def_t), target, intent(in) :: def integer, intent(in) :: i_component integer, intent(in) :: i_external class(prc_core_driver_t), intent(inout), allocatable, optional & :: driver_template object%status = status object%def => def object%i_component = i_component object%i_external = i_external if (present (driver_template)) then call move_alloc (driver_template, object%driver) end if end subroutine process_library_entry_init subroutine process_library_init (lib, basename) class(process_library_t), intent(out) :: lib type(string_t), intent(in) :: basename lib%basename = basename lib%status = STAT_OPEN print *, "Process library '" // char (basename) & // "': initialized" end subroutine process_library_init subroutine process_library_configure (lib) class(process_library_t), intent(inout) :: lib type(process_def_entry_t), pointer :: def_entry integer :: n_entries, n_external, i_entry, i_external type(string_t) :: model_name integer :: i_component n_entries = 0 n_external = 0 if (allocated (lib%entry)) deallocate (lib%entry) def_entry => lib%first do while (associated (def_entry)) do i_component = 1, def_entry%n_initial n_entries = n_entries + 1 end do def_entry => def_entry%next end do call lib%allocate_entries (n_entries) i_entry = 0 i_external = 0 def_entry => lib%first do while (associated (def_entry)) do i_component = 1, def_entry%n_initial i_entry = i_entry + 1 associate (lib_entry => lib%entry(i_entry)) lib_entry%status = STAT_CONFIGURED lib_entry%def => def_entry%process_def_t lib_entry%i_component = i_component end associate end do def_entry => def_entry%next end do do i_entry = 1, n_entries associate (lib_entry => lib%entry(i_entry)) i_component = lib_entry%i_component model_name = lib_entry%def%model_name end associate end do if (lib%n_entries /= 0) lib%entry%status = STAT_LINKED lib%status = STAT_LINKED end subroutine process_library_configure subroutine process_library_allocate_entries (lib, n_entries) class(process_library_t), intent(inout) :: lib integer, intent(in) :: n_entries lib%n_entries = n_entries allocate (lib%entry (n_entries)) end subroutine process_library_allocate_entries subroutine process_library_load (lib) class(process_library_t), intent(inout) :: lib print *, "Inside process_library_load" print *, "status = ", lib%status select case (lib%status) case (STAT_CONFIGURED:STAT_COMPILED) print *, "linking" end select select case (lib%status) case (STAT_LINKED) print *, "stat_linked!, external = ", lib%external lib%entry%status = STAT_ACTIVE lib%status = STAT_ACTIVE end select end subroutine process_library_load end module process_libraries module prc_test use, intrinsic :: iso_c_binding !NODEP! use kinds, only: default use iso_varying_string, string_t => varying_string use prclib_interfaces use prc_core_def use particle_specifiers, only: new_prt_spec use process_libraries implicit none private public :: prc_test_def_t public :: prc_test_create_library type, extends (prc_core_def_t) :: prc_test_def_t type(string_t) :: model_name type(string_t), dimension(:), allocatable :: prt_in type(string_t), dimension(:), allocatable :: prt_out contains procedure :: init => prc_test_def_init end type prc_test_def_t contains subroutine prc_test_def_init (object, model_name, prt_in, prt_out) class(prc_test_def_t), intent(out) :: object type(string_t), intent(in) :: model_name type(string_t), dimension(:), intent(in) :: prt_in type(string_t), dimension(:), intent(in) :: prt_out object%model_name = model_name allocate (object%prt_in (size (prt_in))) object%prt_in = prt_in allocate (object%prt_out (size (prt_out))) object%prt_out = prt_out end subroutine prc_test_def_init subroutine prc_test_create_library & (libname, lib, scattering, decay, procname1, procname2) type(string_t), intent(in) :: libname type(process_library_t), intent(out) :: lib logical, intent(in), optional :: scattering, decay type(string_t), intent(in), optional :: procname1, procname2 type(string_t) :: model_name, procname type(string_t), dimension(:), allocatable :: prt_in, prt_out class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry logical :: sca, dec sca = .true.; if (present (scattering)) sca = scattering dec = .false.; if (present (decay)) dec = decay print *, "inside create test library" print *, "scattering = ", sca print *, "decay = ", dec call lib%init (libname) model_name = "Test" if (sca) then if (present (procname1)) then procname = procname1 else procname = libname end if allocate (prt_in (2), prt_out (2)) prt_in = [var_str ("s"), var_str ("s")] prt_out = [var_str ("s"), var_str ("s")] allocate (prc_test_def_t :: def) select type (def) type is (prc_test_def_t) call def%init (model_name, prt_in, prt_out) end select allocate (entry) call entry%init (procname, model_name = model_name, & n_in = 2, n_components = 1) call entry%import_component (1, n_out = size (prt_out), & prt_in = new_prt_spec (prt_in), & prt_out = new_prt_spec (prt_out), & method = var_str ("test_me"), & variant = def) call lib%append (entry) end if print *, "Checkpoint 1" call lib%configure () print *, "Checkpoint 2" call lib%load () end subroutine prc_test_create_library end module prc_test module models use, intrinsic :: iso_c_binding !NODEP! use kinds, only: default use kinds, only: c_default_float use iso_varying_string, string_t => varying_string use model_data implicit none private public :: model_t type, extends (model_data_t) :: model_t private logical :: ufo_model = .false. contains procedure, private :: basic_init => model_basic_init end type model_t contains subroutine model_basic_init (model, name, n_par, n_prt, n_vtx) class(model_t), intent(inout) :: model type(string_t), intent(in) :: name integer, intent(in) :: n_par, n_prt, n_vtx call model%model_data_t%init (name, n_par, 0, n_prt, n_vtx) end subroutine model_basic_init end module models module process_config use kinds, only: default use iso_varying_string, string_t => varying_string use model_data use models use process_libraries implicit none private public :: process_config_data_t public :: process_environment_t public :: process_metadata_t type :: process_config_data_t class(process_def_t), pointer :: process_def => null () integer :: n_in = 0 type(string_t) :: model_name class(model_data_t), pointer :: model => null () contains procedure :: init => process_config_data_init end type process_config_data_t type :: process_environment_t private type(process_library_t), pointer :: lib => null () contains procedure :: init => process_environment_init end type process_environment_t type :: process_metadata_t integer :: type = 0 type(string_t) :: id logical, dimension(:), allocatable :: active contains procedure :: init => process_metadata_init end type process_metadata_t contains subroutine process_config_data_init (config, meta, env) class(process_config_data_t), intent(out) :: config type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env print *, "1" config%process_def => env%lib%get_process_def_ptr (meta%id) print *, "2" config%n_in = config%process_def%get_n_in () end subroutine process_config_data_init subroutine process_environment_init & (env, lib) class(process_environment_t), intent(out) :: env type(process_library_t), intent(in), target :: lib print *, "inside process_environment_init==================================" env%lib => lib end subroutine process_environment_init subroutine process_metadata_init (meta, id, lib) class(process_metadata_t), intent(out) :: meta type(string_t), intent(in) :: id type(process_library_t), intent(in), target :: lib select case (lib%get_n_in (id)) case (1); meta%type = 1 case (2); meta%type = 2 end select meta%id = id end subroutine process_metadata_init end module process_config module process use kinds, only: default use iso_varying_string, string_t => varying_string use model_data use models use process_libraries use process_config implicit none private public :: process_t type :: process_t private type(process_metadata_t) :: meta type(process_environment_t) :: env type(process_config_data_t) :: config contains procedure :: init => process_init end type process_t contains subroutine process_init & (process, proc_id, lib, model) class(process_t), intent(out) :: process type(string_t), intent(in) :: proc_id type(process_library_t), intent(in), target :: lib class(model_t), intent(in), target :: model integer :: next_rng_seed associate & (meta => process%meta, env => process%env, config => process%config) call env%init (lib) print *, "env initialized" call meta%init (proc_id, lib) print *, "meta initialized" call config%init (meta, env) print *, "rng_seed updated" end associate end subroutine process_init end module process module processes_uti use kinds, only: default use iso_varying_string, string_t => varying_string use model_data use models use prc_test, only: prc_test_create_library use process_libraries use process, only: process_t implicit none private public :: processes_2 contains subroutine processes_2 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(model_t), target :: model type(process_t), allocatable :: process write (u, "(A)") "* Build and load a test library with one process" libname = "processes2" procname = libname call prc_test_create_library (libname, lib) call model%init_test () allocate (process) call process%init (procname, lib, model) end subroutine processes_2 end module processes_uti program main_ut use processes_uti implicit none call processes_2 (6) end program main_ut