Index: trunk/src/matrix_elements/matrix_elements.nw =================================================================== --- trunk/src/matrix_elements/matrix_elements.nw (revision 8826) +++ trunk/src/matrix_elements/matrix_elements.nw (revision 8827) @@ -1,11570 +1,11570 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: matrix elements and process libraries \chapter{Matrix Element Handling} \includemodulegraph{matrix_elements} In this chapter, we support internal and external matrix elements: initialization, automatic generation where necessary, and numerical evaluation. We provide the interface for code generation and linking. Matrix-element code is organized in processes and process libraries. \begin{description} \item[process\_constants] A record of static process properties, for easy transfer between various \whizard\ modules. \item[prclib\_interfaces] This module deals with matrix-element code which is accessible via external libraries (Fortran libraries or generic C-compatible libraries) and must either be generated by the program or provided by the user explicitly. The module defines and uses an abstract type [[prc_writer_t]] and two abstract extensions, one for a Fortran module and one for a C-compatible library. The implementation provides the specific methods for writing the appropriate parts in external matrix element code. \item[prc\_core\_def] This module defines the abstract types [[prc_core_def_t]] and [[prc_driver_t]]. The implementation of the former provides the configuration for processes of a certain class, while the latter accesses the corresponding matrix element, in particular those generated by the appropriate [[prc_writer_t]] object. \item[process\_libraries] This module combines the functionality of the previous module with the means for holding processes definitions (the internal counterpart of appropriate declarations in the user interface), for handling matrix elements which do not need external code, and for accessing the matrix elements by the procedures for matrix-element evaluation, integration and event generation. \item[prclib\_stacks] Collect process libraries. \item[test\_me] This module provides a test implementation for the abstract types in the [[prc_core_def]] module. The implementation is intended for self-tests of several later modules. The implementation is internal, i.e., no external code has is generated. \end{description} All data structures which are specific for a particular way of generating code or evaluating matrix element are kept abstract and thus generic. Later modules such as [[prc_omega]] provide implementations, in the form of type extensions for the various abstract types. \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process data block} We define a simple transparent type that contains universal constant process data. We will reference objects of this type for the phase-space setup, for interfacing with process libraries, for implementing matrix-element generation, and in the master process-handling module. <<[[process_constants.f90]]>>= <> module process_constants <> <> use pdg_arrays <> <> <> interface <> end interface end module process_constants @ %def process_constants @ <<[[process_constants_sub.f90]]>>= <> submodule (process_constants) process_constants_s use io_units, only: given_output_unit, free_unit use format_utils, only: write_integer_array use md5, only: md5sum implicit none contains <> end submodule process_constants_s @ %def process_constants_s @ The data type is just a block of public objects, only elementary types, no type-bound procedures. <>= public :: process_constants_t <>= type :: process_constants_t type(string_t) :: id type(string_t) :: model_name character(32) :: md5sum = "" logical :: openmp_supported = .false. integer :: n_in = 0 integer :: n_out = 0 integer :: n_flv = 0 integer :: n_hel = 0 integer :: n_col = 0 integer :: n_cin = 0 integer :: n_cf = 0 integer, dimension(:,:), allocatable :: flv_state integer, dimension(:,:), allocatable :: hel_state integer, dimension(:,:,:), allocatable :: col_state logical, dimension(:,:), allocatable :: ghost_flag complex(default), dimension(:), allocatable :: color_factors integer, dimension(:,:), allocatable :: cf_index integer, dimension(:), allocatable :: eqv_flv_index integer, dimension(:), allocatable :: eqv_hel_index contains <> end type process_constants_t @ %def process_constants_t @ <>= procedure :: get_n_tot => process_constants_get_n_tot <>= elemental module function process_constants_get_n_tot (prc_const) result (n_tot) integer :: n_tot class(process_constants_t), intent(in) :: prc_const end function process_constants_get_n_tot <>= elemental module function process_constants_get_n_tot (prc_const) result (n_tot) integer :: n_tot class(process_constants_t), intent(in) :: prc_const n_tot = prc_const%n_in + prc_const%n_out end function process_constants_get_n_tot @ %def process_constants_get_n_tot @ <>= procedure :: get_flv_state => process_constants_get_flv_state <>= module subroutine process_constants_get_flv_state (prc_const, flv_state) class(process_constants_t), intent(in) :: prc_const integer, dimension(:,:), allocatable, intent(out) :: flv_state end subroutine process_constants_get_flv_state <>= module subroutine process_constants_get_flv_state (prc_const, flv_state) class(process_constants_t), intent(in) :: prc_const integer, dimension(:,:), allocatable, intent(out) :: flv_state allocate (flv_state (size (prc_const%flv_state, 1), & size (prc_const%flv_state, 2))) flv_state = prc_const%flv_state end subroutine process_constants_get_flv_state @ %def process_constants_get_flv_state @ <>= procedure :: get_n_flv => process_constants_get_n_flv <>= module function process_constants_get_n_flv (data) result (n_flv) integer :: n_flv class(process_constants_t), intent(in) :: data end function process_constants_get_n_flv <>= module function process_constants_get_n_flv (data) result (n_flv) integer :: n_flv class(process_constants_t), intent(in) :: data n_flv = data%n_flv end function process_constants_get_n_flv @ %def process_constants_get_n_flv @ <>= procedure :: get_n_hel => process_constants_get_n_hel <>= module function process_constants_get_n_hel (data) result (n_hel) integer :: n_hel class(process_constants_t), intent(in) :: data end function process_constants_get_n_hel <>= module function process_constants_get_n_hel (data) result (n_hel) integer :: n_hel class(process_constants_t), intent(in) :: data n_hel = data%n_hel end function process_constants_get_n_hel @ %def process_constants_get_n_flv @ <>= procedure :: get_hel_state => process_constants_get_hel_state <>= module subroutine process_constants_get_hel_state (prc_const, hel_state) class(process_constants_t), intent(in) :: prc_const integer, dimension(:,:), allocatable, intent(out) :: hel_state end subroutine process_constants_get_hel_state <>= module subroutine process_constants_get_hel_state (prc_const, hel_state) class(process_constants_t), intent(in) :: prc_const integer, dimension(:,:), allocatable, intent(out) :: hel_state allocate (hel_state (size (prc_const%hel_state, 1), & size (prc_const%hel_state, 2))) hel_state = prc_const%hel_state end subroutine process_constants_get_hel_state @ %def process_constants_get_hel_state @ <>= procedure :: get_col_state => process_constants_get_col_state <>= module subroutine process_constants_get_col_state (prc_const, col_state) class(process_constants_t), intent(in) :: prc_const integer, dimension(:,:,:), allocatable, intent(out) :: col_state end subroutine process_constants_get_col_state <>= module subroutine process_constants_get_col_state (prc_const, col_state) class(process_constants_t), intent(in) :: prc_const integer, dimension(:,:,:), allocatable, intent(out) :: col_state allocate (col_state (size (prc_const%col_state, 1), & size (prc_const%col_state, 2), size (prc_const%col_state, 3))) col_state = prc_const%col_state end subroutine process_constants_get_col_state @ %def process_constants_get_col_state @ <>= procedure :: get_ghost_flag => process_constants_get_ghost_flag <>= module subroutine process_constants_get_ghost_flag (prc_const, ghost_flag) class(process_constants_t), intent(in) :: prc_const logical, dimension(:,:), allocatable, intent(out) :: ghost_flag end subroutine process_constants_get_ghost_flag <>= module subroutine process_constants_get_ghost_flag (prc_const, ghost_flag) class(process_constants_t), intent(in) :: prc_const logical, dimension(:,:), allocatable, intent(out) :: ghost_flag allocate (ghost_flag (size (prc_const%ghost_flag, 1), & size (prc_const%ghost_flag, 2))) ghost_flag = prc_const%ghost_flag end subroutine process_constants_get_ghost_flag @ %def process_constants_get_ghost_flag @ <>= procedure :: get_color_factors => process_constants_get_color_factors <>= module subroutine process_constants_get_color_factors (prc_const, col_facts) class(process_constants_t), intent(in) :: prc_const complex(default), dimension(:), allocatable, intent(out) :: col_facts end subroutine process_constants_get_color_factors <>= module subroutine process_constants_get_color_factors (prc_const, col_facts) class(process_constants_t), intent(in) :: prc_const complex(default), dimension(:), allocatable, intent(out) :: col_facts allocate (col_facts (size (prc_const%color_factors))) col_facts = prc_const%color_factors end subroutine process_constants_get_color_factors @ %def process_constants_get_color_factors @ <>= procedure :: get_cf_index => process_constants_get_cf_index <>= module subroutine process_constants_get_cf_index (prc_const, cf_index) class(process_constants_t), intent(in) :: prc_const integer, intent(out), dimension(:,:), allocatable :: cf_index end subroutine process_constants_get_cf_index <>= module subroutine process_constants_get_cf_index (prc_const, cf_index) class(process_constants_t), intent(in) :: prc_const integer, intent(out), dimension(:,:), allocatable :: cf_index allocate (cf_index (size (prc_const%cf_index, 1), & size (prc_const%cf_index, 2))) cf_index = prc_const%cf_index end subroutine process_constants_get_cf_index @ %def process_constants_get_cf_index @ <>= procedure :: set_flv_state => process_constants_set_flv_state <>= module subroutine process_constants_set_flv_state (prc_const, flv_state) class(process_constants_t), intent(inout) :: prc_const integer, intent(in), dimension(:,:), allocatable :: flv_state end subroutine process_constants_set_flv_state <>= module subroutine process_constants_set_flv_state (prc_const, flv_state) class(process_constants_t), intent(inout) :: prc_const integer, intent(in), dimension(:,:), allocatable :: flv_state if (allocated (prc_const%flv_state)) deallocate (prc_const%flv_state) allocate (prc_const%flv_state (size (flv_state, 1), & size (flv_state, 2))) prc_const%flv_state = flv_state prc_const%n_flv = size (flv_state, 2) end subroutine process_constants_set_flv_state @ %def process_constants_set_flv_state @ <>= procedure :: set_col_state => process_constants_set_col_state <>= module subroutine process_constants_set_col_state (prc_const, col_state) class(process_constants_t), intent(inout) :: prc_const integer, intent(in), dimension(:,:,:), allocatable :: col_state end subroutine process_constants_set_col_state <>= module subroutine process_constants_set_col_state (prc_const, col_state) class(process_constants_t), intent(inout) :: prc_const integer, intent(in), dimension(:,:,:), allocatable :: col_state allocate (prc_const%col_state (size (col_state, 1), & size (col_state, 2), size (col_state, 3))) prc_const%col_state = col_state end subroutine process_constants_set_col_state @ %def process_constants_set_col_state @ <>= procedure :: set_cf_index => process_constants_set_cf_index <>= module subroutine process_constants_set_cf_index (prc_const, cf_index) class(process_constants_t), intent(inout) :: prc_const integer, dimension(:,:), intent(in), allocatable :: cf_index end subroutine process_constants_set_cf_index <>= module subroutine process_constants_set_cf_index (prc_const, cf_index) class(process_constants_t), intent(inout) :: prc_const integer, dimension(:,:), intent(in), allocatable :: cf_index allocate (prc_const%cf_index (size (cf_index, 1), & size (cf_index, 2))) prc_const%cf_index = cf_index end subroutine process_constants_set_cf_index @ %def process_constants_set_cf_index @ <>= procedure :: set_color_factors => process_constants_set_color_factors <>= module subroutine process_constants_set_color_factors (prc_const, color_factors) class(process_constants_t), intent(inout) :: prc_const complex(default), dimension(:), intent(in), allocatable :: color_factors end subroutine process_constants_set_color_factors <>= module subroutine process_constants_set_color_factors (prc_const, color_factors) class(process_constants_t), intent(inout) :: prc_const complex(default), dimension(:), intent(in), allocatable :: color_factors allocate (prc_const%color_factors (size (color_factors))) prc_const%color_factors = color_factors end subroutine process_constants_set_color_factors @ %def process_constants_set_color_factors @ <>= procedure :: set_ghost_flag => process_constants_set_ghost_flag <>= module subroutine process_constants_set_ghost_flag (prc_const, ghost_flag) class(process_constants_t), intent(inout) :: prc_const logical, dimension(:,:), allocatable, intent(in) :: ghost_flag end subroutine process_constants_set_ghost_flag <>= module subroutine process_constants_set_ghost_flag (prc_const, ghost_flag) class(process_constants_t), intent(inout) :: prc_const logical, dimension(:,:), allocatable, intent(in) :: ghost_flag allocate (prc_const%ghost_flag (size (ghost_flag, 1), & size (ghost_flag, 2))) prc_const%ghost_flag = ghost_flag end subroutine process_constants_set_ghost_flag @ %def process_constants_set_ghost_flag @ <>= procedure :: get_pdg_in => process_constants_get_pdg_in <>= module function process_constants_get_pdg_in (prc_const) result (pdg_in) type(pdg_array_t), dimension(:), allocatable :: pdg_in class(process_constants_t), intent(in) :: prc_const end function process_constants_get_pdg_in <>= module function process_constants_get_pdg_in (prc_const) result (pdg_in) type(pdg_array_t), dimension(:), allocatable :: pdg_in class(process_constants_t), intent(in) :: prc_const type(pdg_array_t) :: pdg_tmp integer :: i allocate (pdg_in (prc_const%n_in)) do i = 1, prc_const%n_in pdg_tmp = prc_const%flv_state(i,:) pdg_in(i) = sort_abs (pdg_tmp, unique = .true.) end do end function process_constants_get_pdg_in @ %def process_constants_get_pdg_in @ <>= procedure :: compute_md5sum => process_constants_compute_md5sum <>= module subroutine process_constants_compute_md5sum (prc_const, include_id) class(process_constants_t), intent(inout) :: prc_const logical, intent(in) :: include_id end subroutine process_constants_compute_md5sum <>= module subroutine process_constants_compute_md5sum (prc_const, include_id) class(process_constants_t), intent(inout) :: prc_const logical, intent(in) :: include_id integer :: unit unit = prc_const%fill_unit_for_md5sum (include_id) rewind (unit) prc_const%md5sum = md5sum (unit) close (unit) end subroutine process_constants_compute_md5sum @ %process_constants_compute_md5sum @ <>= procedure :: fill_unit_for_md5sum => process_constants_fill_unit_for_md5sum <>= module function process_constants_fill_unit_for_md5sum & (prc_const, include_id) result (unit) integer :: unit class(process_constants_t), intent(in) :: prc_const logical, intent(in) :: include_id end function process_constants_fill_unit_for_md5sum <>= module function process_constants_fill_unit_for_md5sum & (prc_const, include_id) result (unit) integer :: unit class(process_constants_t), intent(in) :: prc_const logical, intent(in) :: include_id integer :: i, j, k unit = free_unit () open (unit, status="scratch", action="readwrite") if (include_id) write (unit, '(A)') char (prc_const%id) write (unit, '(A)') char (prc_const%model_name) write (unit, '(L1)') prc_const%openmp_supported write (unit, '(I0)') prc_const%n_in write (unit, '(I0)') prc_const%n_out write (unit, '(I0)') prc_const%n_flv write (unit, '(I0)') prc_const%n_hel write (unit, '(I0)') prc_const%n_col write (unit, '(I0)') prc_const%n_cin write (unit, '(I0)') prc_const%n_cf do i = 1, size (prc_const%flv_state, dim=1) do j = 1, size (prc_const%flv_state, dim=2) write (unit, '(I0)') prc_const%flv_state (i, j) end do end do do i = 1, size (prc_const%hel_state, dim=1) do j = 1, size (prc_const%hel_state, dim=2) write (unit, '(I0)') prc_const%hel_state (i, j) end do end do do i = 1, size (prc_const%col_state, dim=1) do j = 1, size (prc_const%col_state, dim=2) do k = 1, size (prc_const%col_state, dim=3) write (unit, '(I0)') prc_const%col_state (i, j, k) end do end do end do do i = 1, size (prc_const%ghost_flag, dim=1) do j = 1, size (prc_const%ghost_flag, dim=2) write (unit, '(L1)') prc_const%ghost_flag (i, j) end do end do do i = 1, size (prc_const%color_factors) write (unit, '(F0.0,F0.0)') real (prc_const%color_factors(i)), & aimag (prc_const%color_factors(i)) end do do i = 1, size (prc_const%cf_index, dim=1) do j = 1, size (prc_const%cf_index, dim=2) write (unit, '(I0)') prc_const%cf_index(i, j) end do end do end function process_constants_fill_unit_for_md5sum @ %def process_constants_fill_unit_for_md5sum @ <>= procedure :: write => process_constants_write <>= module subroutine process_constants_write (prc_const, unit) class(process_constants_t), intent(in) :: prc_const integer, intent(in), optional :: unit end subroutine process_constants_write <>= module subroutine process_constants_write (prc_const, unit) class(process_constants_t), intent(in) :: prc_const integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A,A)") "Process data of id: ", char (prc_const%id) write (u, "(1x,A,A)") "Associated model: ", char (prc_const%model_name) write (u, "(1x,A,I0)") "n_in: ", prc_const%n_in write (u, "(1x,A,I0)") "n_out: ", prc_const%n_out write (u, "(1x,A,I0)") "n_flv: ", prc_const%n_flv write (u, "(1x,A,I0)") "n_hel: ", prc_const%n_hel write (u, "(1x,A,I0)") "n_col: ", prc_const%n_col write (u, "(1x,A,I0)") "n_cin: ", prc_const%n_cin write (u, "(1x,A,I0)") "n_cf: ", prc_const%n_cf write (u, "(1x,A)") "Flavors: " do i = 1, prc_const%n_flv write (u, "(1x,A,I0)") "i_flv: ", i call write_integer_array (prc_const%flv_state (:,i)) end do end subroutine process_constants_write @ %def process_constants_write @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process library interface} The module [[prclib_interfaces]] handles external matrix-element code. \subsection{Overview} The top-level data structure is the [[prclib_driver_t]] data type. The associated type-bound procedures deal with the generation of external code, compilation and linking, and accessing the active external library. An object of type [[prclib_driver_t]] consists of the following parts: \begin{enumerate} \item\ Metadata that identify name and status of the library driver, etc. \item\ An array of process records ([[prclib_driver_record_t]]), one for each external matrix element. \item\ A record of type [[dlaccess_t]] which handles the operating-system part of linking a dynamically loadable library. \item\ A collection of procedure pointers which have a counterpart in the external library interface. Given the unique identifier of a matrix element, the procedures retrieve generic matrix-element information such as the particle content and helicity combination tables. There is also a procedure which returns pointers to the more specific procedures that a matrix element provides, called \emph{features}. \end{enumerate} The process records of type [[prclib_driver_record_t]] handle the individual matrix elements. Each record identifies a process by name ([[id]]), names the physics model to be loaded for this process, lists the features that the associated matrix-element code provides, and holds a [[writer]] object which handles all operations that depend on the process type. The numbering of process records is identical to the numbering of matrix-element codes in the external library. The writer object is of abstract type [[prc_writer_t]]. The module defines two basic, also abstract, extensions: [[prc_writer_f_module_t]] and [[prc_writer_c_lib_t]]. The first version is for matrix-element code that is available in form of Fortran modules. The writer contains type-bound procedures which create appropriate [[use]] directives and [[C]]-compatible wrapper functions for the given set of Fortran modules and their features. The second version is for matrix-element code that is available in form of a C-compatible library (this includes Fortran libraries with proper C bindings). The writer needs not write wrapper function, but explicit interface blocks for the matrix-element features. Each matrix-element variant is encoded in an appropriate extension of [[prc_writer_t]]. For instance, \oMega\ matrix elements provide an implementation [[omega_writer_t]] which extends [[prc_writer_f_module_t]]. \subsection{Workflow} We expect that the functionality provided by this module is called in the following order: \begin{enumerate} \item The caller initializes the [[prclib_driver_t]] object and fills the array of [[prclib_record_t]] entries with the appropriate process data and process-specific writer objects. \item It calls the [[generate_makefile]] method to set up an appropriate makefile in the current directory. The makefile will handle source generation, compilation and linking both for the individual matrix elements (unless this has to be done manually) and for the common external driver code which interfaces those matrix element. \item The [[generate_driver_code]] writes the common driver as source code to file. \item The methods [[make_source]], [[make_compile]], and [[make_link]] individually perform the corresponding steps in building the library. Wherever possible, they simply use the generated makefile. By calling [[make]], we make sure that we can avoid unnecessary recompilation. For the compilation and linking steps, the makefile will employ [[libtool]]. \item The [[load]] method loads the library procedures into the corresponding procedure pointers, using the [[dlopen]] mechanism via the [[dlaccess]] subobject. \end{enumerate} \subsection{The module} <<[[prclib_interfaces.f90]]>>= <> module prclib_interfaces use, intrinsic :: iso_c_binding !NODEP! use kinds <> use os_interface <> <> <> <> interface <> end interface contains <> end module prclib_interfaces @ %def prclib_interfaces @ <<[[prclib_interfaces_sub.f90]]>>= <> submodule (prclib_interfaces) prclib_interfaces_s use io_units use system_defs, only: TAB use string_utils, only: lower_case use diagnostics implicit none contains <> end submodule prclib_interfaces_s @ %def prclib_interfaces_s @ \subsection{Writers} External matrix element code provides externally visible procedures, which we denote as \emph{features}. The features consist of informational subroutines and functions which are mandatory (universal features) and matrix-element specific subroutines and functions (specific features). The driver interfaces the generic features directly, while it returns the specific features in form of bind(C) procedure pointers to the caller. For instance, function [[n_in]] is generic, while the matrix matrix-element value itself is specific. To implement these tasks, the driver needs [[use]] directives for Fortran module procedures, interface blocks for other external stuff, wrapper code, and Makefile snippets. \subsubsection{Generic writer} In the [[prc_writer_t]] data type, we collect the procedures which implement the writing tasks. The type is abstract. The concrete implementations are defined by an extension which is specific for the process type. The MD5 sum stored here should be the MD5 checksum of the current process component, which can be calculated once the process is configured completely. It can be used by implementations which work with external files, such as \oMega. <>= public :: prc_writer_t <>= type, abstract :: prc_writer_t character(32) :: md5sum = "" contains <> end type prc_writer_t @ %def prc_writer_t @ In any case, it is useful to have a string representation of the writer type. This must be implemented by all extensions. <>= procedure(get_const_string), nopass, deferred :: type_name <>= abstract interface function get_const_string () result (string) import type(string_t) :: string end function get_const_string end interface @ %def get_const_string @ Return the name of a procedure that implements a given feature, as it is provided by the external matrix-element code. For a reasonable default, we take the feature name unchanged. Due to a bug of bind(C) features with submodules in gfortran 7/8/9 (and maybe together with MPI) this needs to be in the module, not the submodule. <>= procedure, nopass :: get_procname => prc_writer_get_procname <>= function prc_writer_get_procname (feature) result (name) type(string_t) :: name type(string_t), intent(in) :: feature name = feature end function prc_writer_get_procname @ %def prc_writer_get_procname @ Return the name of a procedure that implements a given feature with the bind(C) property, so it can be accessed via a C procedure pointer and handled by dlopen. We need this for all special features of a matrix element, since the interface has to return a C function pointer for it. For a default implementation, we prefix the external procedure name by the process ID. Due to a bug of bind(C) features with submodules in gfortran 7/8/9 (and maybe together with MPI) this needs to be in the module, not the submodule. <>= procedure :: get_c_procname => prc_writer_get_c_procname <>= function prc_writer_get_c_procname (writer, id, feature) result (name) class(prc_writer_t), intent(in) :: writer type(string_t), intent(in) :: id, feature type(string_t) :: name name = id // "_" // feature end function prc_writer_get_c_procname @ %def get_c_procname @ Common signature of code-writing procedures. The procedure may use the process ID, and the feature name. (Not necessarily all of them.) <>= abstract interface subroutine write_code_file (writer, id) import class(prc_writer_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine write_code_file end interface abstract interface subroutine write_code (writer, unit, id) import class(prc_writer_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id end subroutine write_code end interface abstract interface subroutine write_code_os & (writer, unit, id, os_data, verbose, testflag) import class(prc_writer_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag end subroutine write_code_os end interface abstract interface subroutine write_feature_code (writer, unit, id, feature) import class(prc_writer_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature end subroutine write_feature_code end interface @ %def write_code write_feature_code @ There must be a procedure which writes an interface block for a given feature. If the external matrix element is implemented as a Fortran module, this is required only for the specific features which are returned as procedure pointers. <>= procedure(write_feature_code), deferred :: write_interface @ %def write_interface @ There must also be a procedure which writes Makefile code which is specific for the current process, but not the feature. <>= procedure(write_code_os), deferred :: write_makefile_code @ %def write_makefile_code @ This procedure writes code process-specific source-code file (which need not be Fortran). It is called before [[make]] [[source]] is called. It may be a no-op, if the source code is generated by Make instead. <>= procedure(write_code_file), deferred :: write_source_code @ %def write_source_code @ This procedure is executed, once for each process, before (after) [[make]] [[compile]] is called, respectively. <>= procedure(write_code_file), deferred :: before_compile procedure(write_code_file), deferred :: after_compile @ %def before_compile @ %def after_compile @ \subsubsection{Writer for Fortran-module matrix elements} If the matrix element is available as a Fortran module, we have specific requirements: (i) the features are imported via [[use]] directives, (ii) the specific features require bind(C) wrappers. The type is still abstract, all methods must be implemented explicitly for a specific matrix-element variant. <>= public :: prc_writer_f_module_t <>= type, extends (prc_writer_t), abstract :: prc_writer_f_module_t contains <> end type prc_writer_f_module_t @ %def prc_writer_f_module_t @ Return the name of the Fortran module. As a default implementation, we take the process ID unchanged. Due to a bug of bind(C) features with submodules in gfortran 7/8/9 (and maybe together with MPI) this needs to be in the module, not the submodule. <>= procedure, nopass :: get_module_name => prc_writer_get_module_name <>= function prc_writer_get_module_name (id) result (name) type(string_t) :: name type(string_t), intent(in) :: id name = id end function prc_writer_get_module_name @ %def prc_writer_get_module_name @ Write a [[use]] directive that associates the driver reference with the procedure in the matrix element code. By default, we use the C name for this. <>= procedure :: write_use_line => prc_writer_write_use_line <>= module subroutine prc_writer_write_use_line (writer, unit, id, feature) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t) :: id, feature end subroutine prc_writer_write_use_line <>= module subroutine prc_writer_write_use_line (writer, unit, id, feature) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t) :: id, feature write (unit, "(2x,9A)") "use ", char (writer%get_module_name (id)), & ", only: ", char (writer%get_c_procname (id, feature)), & " => ", char (writer%get_procname (feature)) end subroutine prc_writer_write_use_line @ %def prc_writer_write_use_line @ Write a wrapper routine for a feature. This also associates a C name the module procedure. The details depend on the writer variant. <>= procedure(prc_write_wrapper), deferred :: write_wrapper <>= abstract interface subroutine prc_write_wrapper (writer, unit, id, feature) import class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature end subroutine prc_write_wrapper end interface @ %def prc_write_wrapper @ This is used for testing only: initialize the writer with a specific MD5 sum string. <>= procedure :: init_test => prc_writer_init_test <>= module subroutine prc_writer_init_test (writer) class(prc_writer_t), intent(out) :: writer end subroutine prc_writer_init_test <>= module subroutine prc_writer_init_test (writer) class(prc_writer_t), intent(out) :: writer writer%md5sum = "1234567890abcdef1234567890abcdef" end subroutine prc_writer_init_test @ %def prc_writer_init_test @ \subsubsection{Writer for C-library matrix elements} This applies if the matrix element is available as a C library or a Fortran library with bind(C) compatible interface. We can use the basic version. The type is still abstract, all methods must be implemented explicitly for a specific matrix-element variant. <>= public :: prc_writer_c_lib_t <>= type, extends (prc_writer_t), abstract :: prc_writer_c_lib_t contains <> end type prc_writer_c_lib_t @ %def prc_writer_c_lib_t @ \subsection{Process records in the library driver} A process record holds the process (component) [[ID]], the physics [[model_name]], and the array of [[feature]]s that are implemented by the corresponding matrix element code. The [[writer]] component holds procedures. The procedures write source code for the current record, either for the driver or for the Makefile. <>= 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 () contains <> end type prclib_driver_record_t @ %def prclib_driver_record @ Output routine. We indent the output, so it smoothly integrates into the output routine for the whole driver. Note: the pointer [[writer]] is introduced as a workaround for a NAG compiler bug. <>= procedure :: write => prclib_driver_record_write <>= module subroutine prclib_driver_record_write (object, unit) class(prclib_driver_record_t), intent(in) :: object integer, intent(in) :: unit end subroutine prclib_driver_record_write <>= module subroutine prclib_driver_record_write (object, unit) class(prclib_driver_record_t), intent(in) :: object integer, intent(in) :: unit integer :: j class(prc_writer_t), pointer :: writer write (unit, "(3x,A,2x,'[',A,']')") & char (object%id), char (object%model_name) if (allocated (object%feature)) then writer => object%writer write (unit, "(5x,A,A)", advance="no") & char (writer%type_name ()), ":" do j = 1, size (object%feature) write (unit, "(1x,A)", advance="no") & char (object%feature(j)) end do write (unit, *) end if end subroutine prclib_driver_record_write @ %def prclib_driver_record_write @ Get the C procedure name for a feature. Due to a bug of bind(C) features with submodules in gfortran 7/8/9 (and maybe together with MPI) this needs to be in the module, not the submodule. <>= procedure :: get_c_procname => prclib_driver_record_get_c_procname <>= function prclib_driver_record_get_c_procname (record, feature) result (name) type(string_t) :: name class(prclib_driver_record_t), intent(in) :: record type(string_t), intent(in) :: feature name = record%writer%get_c_procname (record%id, feature) end function prclib_driver_record_get_c_procname @ %def prclib_driver_record_get_c_procname @ Write a USE directive for a given feature. Applies only if the record corresponds to a Fortran module. <>= procedure :: write_use_line => prclib_driver_record_write_use_line <>= module subroutine prclib_driver_record_write_use_line (record, unit, feature) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(string_t), intent(in) :: feature end subroutine prclib_driver_record_write_use_line <>= module subroutine prclib_driver_record_write_use_line (record, unit, feature) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(string_t), intent(in) :: feature select type (writer => record%writer) class is (prc_writer_f_module_t) call writer%write_use_line (unit, record%id, feature) end select end subroutine prclib_driver_record_write_use_line @ %def prclib_driver_record_write_use_line @ The alternative: write an interface block for a given feature, unless the record corresponds to a Fortran module. <>= procedure :: write_interface => prclib_driver_record_write_interface <>= module subroutine prclib_driver_record_write_interface (record, unit, feature) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(string_t), intent(in) :: feature end subroutine prclib_driver_record_write_interface <>= module subroutine prclib_driver_record_write_interface (record, unit, feature) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(string_t), intent(in) :: feature select type (writer => record%writer) class is (prc_writer_f_module_t) class default call writer%write_interface (unit, record%id, feature) end select end subroutine prclib_driver_record_write_interface @ %def prclib_driver_record_write_use_line @ Write all special feature interfaces for the current record. Do this for all process variants. <>= procedure :: write_interfaces => prclib_driver_record_write_interfaces <>= module subroutine prclib_driver_record_write_interfaces (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit end subroutine prclib_driver_record_write_interfaces <>= module subroutine prclib_driver_record_write_interfaces (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit integer :: i do i = 1, size (record%feature) call record%writer%write_interface (unit, record%id, record%feature(i)) end do end subroutine prclib_driver_record_write_interfaces @ %def prclib_driver_record_write_interfaces @ Write the wrapper routines for this record, if it corresponds to a Fortran module. <>= procedure :: write_wrappers => prclib_driver_record_write_wrappers <>= module subroutine prclib_driver_record_write_wrappers (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit end subroutine prclib_driver_record_write_wrappers <>= module subroutine prclib_driver_record_write_wrappers (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit integer :: i select type (writer => record%writer) class is (prc_writer_f_module_t) do i = 1, size (record%feature) call writer%write_wrapper (unit, record%id, record%feature(i)) end do end select end subroutine prclib_driver_record_write_wrappers @ %def prclib_driver_record_write_wrappers @ Write the Makefile code for this record. <>= procedure :: write_makefile_code => prclib_driver_record_write_makefile_code <>= module subroutine prclib_driver_record_write_makefile_code & (record, unit, os_data, verbose, testflag) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag end subroutine prclib_driver_record_write_makefile_code <>= module subroutine prclib_driver_record_write_makefile_code & (record, unit, os_data, verbose, testflag) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag call record%writer%write_makefile_code & (unit, record%id, os_data, verbose, testflag) end subroutine prclib_driver_record_write_makefile_code @ %def prclib_driver_record_write_makefile_code @ Write source-code files for this record. This can be used as an alternative to handling source code via Makefile. In fact, this procedure is executed before [[make]] [[source]] is called. Usually, does nothing. <>= procedure :: write_source_code => prclib_driver_record_write_source_code <>= module subroutine prclib_driver_record_write_source_code (record) class(prclib_driver_record_t), intent(in) :: record end subroutine prclib_driver_record_write_source_code <>= module subroutine prclib_driver_record_write_source_code (record) class(prclib_driver_record_t), intent(in) :: record call record%writer%write_source_code (record%id) end subroutine prclib_driver_record_write_source_code @ %def prclib_driver_record_write_source_code @ Execute commands for this record that depend on the sources, so they cannot be included in the previous procedure. This procedure is executed before (after) [[make]] [[compile]] is called, respectively. Usually, does nothing. <>= procedure :: before_compile => prclib_driver_record_before_compile procedure :: after_compile => prclib_driver_record_after_compile <>= module subroutine prclib_driver_record_before_compile (record) class(prclib_driver_record_t), intent(in) :: record end subroutine prclib_driver_record_before_compile module subroutine prclib_driver_record_after_compile (record) class(prclib_driver_record_t), intent(in) :: record end subroutine prclib_driver_record_after_compile <>= module subroutine prclib_driver_record_before_compile (record) class(prclib_driver_record_t), intent(in) :: record call record%writer%before_compile (record%id) end subroutine prclib_driver_record_before_compile module subroutine prclib_driver_record_after_compile (record) class(prclib_driver_record_t), intent(in) :: record call record%writer%after_compile (record%id) end subroutine prclib_driver_record_after_compile @ %def prclib_driver_record_before_compile @ %def prclib_driver_record_after_compile @ \subsection{The process library driver object} A [[prclib_driver_t]] object provides the interface to external matrix element code. The code is provided by an external library which is either statically or dynamically linked. The dynamic and static versions of the library are two different implementations of the abstract base type. The [[basename]] identifies the library, both by file names and by Fortran variable names. The [[loaded]] flag becomes true once all procedure pointers to the matrix element have been assigned. For a dynamical external library, the communication proceeds via a [[dlaccess]] object. [[n_processes]] is the number of external process code components that are referenced by this library. The code is addressed by index ([[i_lib]] in the process library entry above). This number should be equal to the number returned by [[get_n_prc]]. For each external process, there is a separate [[record]] which holds the data that are needed for the driver parts which are specific for a given process component. The actual pointers for the loaded library will be assigned elsewhere. The remainder is a collection of procedure pointers, which can be assigned once all external code has been compiled and linked. The procedure pointers all take a process component code index as an argument. Most return information about the process component that should match the process definition. The [[get_fptr]] procedures return a function pointer, which is the actual means to compute matrix elements or retrieve associated data. Finally, the [[unload_hook]] and [[reload_hook]] pointers allow for the insertion of additional code when a library is loaded. <>= public :: prclib_driver_t <>= type, abstract :: prclib_driver_t type(string_t) :: basename character(32) :: md5sum = "" 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_n_processes), nopass, pointer :: & get_n_processes => null () procedure(prc_get_stringptr), nopass, pointer :: & get_process_id_ptr => null () procedure(prc_get_stringptr), nopass, pointer :: & get_model_name_ptr => null () procedure(prc_get_stringptr), nopass, pointer :: & get_md5sum_ptr => null () procedure(prc_get_log), nopass, pointer :: & get_openmp_status => null () procedure(prc_get_int), nopass, pointer :: get_n_in => null () procedure(prc_get_int), nopass, pointer :: get_n_out => null () procedure(prc_get_int), nopass, pointer :: get_n_flv => null () procedure(prc_get_int), nopass, pointer :: get_n_hel => null () procedure(prc_get_int), nopass, pointer :: get_n_col => null () procedure(prc_get_int), nopass, pointer :: get_n_cin => null () procedure(prc_get_int), nopass, pointer :: get_n_cf => null () procedure(prc_set_int_tab1), nopass, pointer :: & set_flv_state_ptr => null () procedure(prc_set_int_tab1), nopass, pointer :: & set_hel_state_ptr => null () procedure(prc_set_col_state), nopass, pointer :: & set_col_state_ptr => null () procedure(prc_set_color_factors), nopass, pointer :: & set_color_factors_ptr => null () procedure(prc_get_fptr), nopass, pointer :: get_fptr => null () contains <> end type prclib_driver_t @ %def prclib_driver_t @ This is the dynamic version. It contains a [[dlaccess]] object for communicating with the OS. <>= public :: prclib_driver_dynamic_t <>= type, extends (prclib_driver_t) :: prclib_driver_dynamic_t type(dlaccess_t) :: dlaccess contains <> end type prclib_driver_dynamic_t @ %def prclib_driver_dynamic_t @ Print just the metadata. Procedure pointers cannot be printed. <>= procedure :: write => prclib_driver_write <>= module subroutine prclib_driver_write (object, unit, libpath) class(prclib_driver_t), intent(in) :: object integer, intent(in) :: unit logical, intent(in), optional :: libpath end subroutine prclib_driver_write <>= module subroutine prclib_driver_write (object, unit, libpath) class(prclib_driver_t), intent(in) :: object integer, intent(in) :: unit logical, intent(in), optional :: libpath logical :: write_lib integer :: i write_lib = .true. if (present (libpath)) write_lib = libpath write (unit, "(1x,A,A)") & "External matrix-element code library: ", char (object%basename) select type (object) type is (prclib_driver_dynamic_t) write (unit, "(3x,A,L1)") "static = F" class default write (unit, "(3x,A,L1)") "static = T" end select write (unit, "(3x,A,L1)") "loaded = ", object%loaded write (unit, "(3x,A,A,A)") "MD5 sum = '", object%md5sum, "'" if (write_lib) then write (unit, "(3x,A,A,A)") "Mdl flags = '", & char (object%modellibs_ldflags), "'" end if select type (object) type is (prclib_driver_dynamic_t) write (unit, *) call object%dlaccess%write (unit) end select write (unit, *) if (allocated (object%record)) then write (unit, "(1x,A)") "Matrix-element code entries:" do i = 1, object%n_processes call object%record(i)%write (unit) end do else write (unit, "(1x,A)") "Matrix-element code entries: [undefined]" end if end subroutine prclib_driver_write @ %def prclib_driver_write @ Allocate a library as either static or dynamic. For static libraries, the procedure defers control to an external procedure which knows about the available static libraries. By default, this procedure is empty, but when we build a stand-alone executable, we replace the dummy by an actual dispatcher for the available static libraries. If the static dispatcher was not successful, we allocate a dynamic library. The default version of [[dispatch_prclib_static]] resides in the [[prebuilt]] section of the \whizard\ tree, in a separate library. It does nothing, but can be replaced by a different procedure that allocates a static library driver if requested by name. Due to a bug of bind(C) features with submodules in gfortran 7/8/9 (and maybe together with MPI) this needs to be in the module, not the submodule. <>= public :: dispatch_prclib_driver <>= subroutine dispatch_prclib_driver & (driver, basename, modellibs_ldflags) class(prclib_driver_t), intent(out), allocatable :: driver type(string_t), intent(in) :: basename type(string_t), intent(in), optional :: modellibs_ldflags procedure(dispatch_prclib_driver) :: dispatch_prclib_static if (allocated (driver)) deallocate (driver) call dispatch_prclib_static (driver, basename) if (.not. allocated (driver)) then allocate (prclib_driver_dynamic_t :: driver) end if driver%basename = basename driver%modellibs_ldflags = modellibs_ldflags end subroutine dispatch_prclib_driver @ %def dispatch_prclib_driver @ Initialize the ID array and set [[n_processes]] accordingly. <>= procedure :: init => prclib_driver_init <>= module subroutine prclib_driver_init (driver, n_processes) class(prclib_driver_t), intent(inout) :: driver integer, intent(in) :: n_processes end subroutine prclib_driver_init <>= module subroutine prclib_driver_init (driver, n_processes) class(prclib_driver_t), intent(inout) :: driver integer, intent(in) :: n_processes driver%n_processes = n_processes allocate (driver%record (n_processes)) end subroutine prclib_driver_init @ %def prclib_driver_init @ Set the MD5 sum. This is separate because the MD5 sum may be known only after initialization. <>= procedure :: set_md5sum => prclib_driver_set_md5sum <>= module subroutine prclib_driver_set_md5sum (driver, md5sum) class(prclib_driver_t), intent(inout) :: driver character(32), intent(in) :: md5sum end subroutine prclib_driver_set_md5sum <>= module subroutine prclib_driver_set_md5sum (driver, md5sum) class(prclib_driver_t), intent(inout) :: driver character(32), intent(in) :: md5sum driver%md5sum = md5sum end subroutine prclib_driver_set_md5sum @ %def prclib_driver_set_md5sum @ Set the process record for a specific library entry. If the index is zero, we do nothing. <>= procedure :: set_record => prclib_driver_set_record <>= module subroutine prclib_driver_set_record (driver, i, & id, model_name, features, writer) class(prclib_driver_t), intent(inout) :: driver integer, intent(in) :: i type(string_t), intent(in) :: id type(string_t), intent(in) :: model_name type(string_t), dimension(:), intent(in) :: features class(prc_writer_t), intent(in), pointer :: writer end subroutine prclib_driver_set_record <>= module subroutine prclib_driver_set_record (driver, i, & id, model_name, features, writer) class(prclib_driver_t), intent(inout) :: driver integer, intent(in) :: i type(string_t), intent(in) :: id type(string_t), intent(in) :: model_name type(string_t), dimension(:), intent(in) :: features class(prc_writer_t), intent(in), pointer :: writer if (i > 0) then associate (record => driver%record(i)) record%id = id record%model_name = model_name allocate (record%feature (size (features))) record%feature = features record%writer => writer end associate end if end subroutine prclib_driver_set_record @ %def prclib_driver_set_record @ Write all USE directives for a given feature, scanning the array of processes. Only Fortran-module processes count. Then, write interface blocks for the remaining processes. The [[implicit none]] statement must go in-between. <>= procedure :: write_interfaces => prclib_driver_write_interfaces <>= module subroutine prclib_driver_write_interfaces (driver, unit, feature) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: feature end subroutine prclib_driver_write_interfaces <>= module subroutine prclib_driver_write_interfaces (driver, unit, feature) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: feature integer :: i do i = 1, driver%n_processes call driver%record(i)%write_use_line (unit, feature) end do write (unit, "(2x,9A)") "implicit none" do i = 1, driver%n_processes call driver%record(i)%write_interface (unit, feature) end do end subroutine prclib_driver_write_interfaces @ %def prclib_driver_write_interfaces @ \subsection{Write makefile} The makefile contains constant parts, parts that depend on the library name, and parts that depend on the specific processes and their types. <>= procedure :: generate_makefile => prclib_driver_generate_makefile <>= module subroutine prclib_driver_generate_makefile (driver, unit, os_data, verbose, testflag) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag end subroutine prclib_driver_generate_makefile <>= module subroutine prclib_driver_generate_makefile (driver, unit, os_data, verbose, testflag) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag integer :: i write (unit, "(A)") "# WHIZARD: Makefile for process library '" & // char (driver%basename) // "'" write (unit, "(A)") "# Automatically generated file, do not edit" write (unit, "(A)") "" write (unit, "(A)") "# Integrity check (don't modify the following line!)" write (unit, "(A)") "MD5SUM = '" // driver%md5sum // "'" write (unit, "(A)") "" write (unit, "(A)") "# Library name" write (unit, "(A)") "BASE = " // char (driver%basename) write (unit, "(A)") "" write (unit, "(A)") "# Compiler" write (unit, "(A)") "FC = " // char (os_data%fc) write (unit, "(A)") "CC = " // char (os_data%cc) write (unit, "(A)") "" write (unit, "(A)") "# Included libraries" write (unit, "(A)") "FCINCL = " // char (os_data%whizard_includes) write (unit, "(A)") "" write (unit, "(A)") "# Compiler flags" write (unit, "(A)") "FCFLAGS = " // char (os_data%fcflags) write (unit, "(A)") "FCFLAGS_PIC = " // char (os_data%fcflags_pic) write (unit, "(A)") "CFLAGS = " // char (os_data%cflags) write (unit, "(A)") "CFLAGS_PIC = " // char (os_data%cflags_pic) write (unit, "(A)") "LDFLAGS = " // char (os_data%whizard_ldflags) & // " " // char (os_data%ldflags) // " " // & char (driver%modellibs_ldflags) write (unit, "(A)") "" write (unit, "(A)") "# LaTeX setup" write (unit, "(A)") "LATEX = " // char (os_data%latex) write (unit, "(A)") "MPOST = " // char (os_data%mpost) write (unit, "(A)") "DVIPS = " // char (os_data%dvips) write (unit, "(A)") "PS2PDF = " // char (os_data%ps2pdf) write (unit, "(A)") 'TEX_FLAGS = "$$TEXINPUTS:' // & char(os_data%whizard_texpath) // '"' write (unit, "(A)") 'MP_FLAGS = "$$MPINPUTS:' // & char(os_data%whizard_texpath) // '"' write (unit, "(A)") "" write (unit, "(A)") "# Libtool" write (unit, "(A)") "LIBTOOL = " // char (os_data%whizard_libtool) if (verbose) then write (unit, "(A)") "FCOMPILE = $(LIBTOOL) --tag=FC --mode=compile" write (unit, "(A)") "CCOMPILE = $(LIBTOOL) --tag=CC --mode=compile" write (unit, "(A)") "LINK = $(LIBTOOL) --tag=FC --mode=link" else write (unit, "(A)") "FCOMPILE = @$(LIBTOOL) --silent --tag=FC --mode=compile" write (unit, "(A)") "CCOMPILE = @$(LIBTOOL) --silent --tag=CC --mode=compile" write (unit, "(A)") "LINK = @$(LIBTOOL) --silent --tag=FC --mode=link" end if write (unit, "(A)") "" write (unit, "(A)") "# Compile commands (default)" write (unit, "(A)") "LTFCOMPILE = $(FCOMPILE) $(FC) -c & &$(FCINCL) $(FCFLAGS) $(FCFLAGS_PIC)" write (unit, "(A)") "LTCCOMPILE = $(CCOMPILE) $(CC) -c & &$(CFLAGS) $(CFLAGS_PIC)" write (unit, "(A)") "" write (unit, "(A)") "# Default target" write (unit, "(A)") "all: link diags" write (unit, "(A)") "" write (unit, "(A)") "# Matrix-element code files" do i = 1, size (driver%record) call driver%record(i)%write_makefile_code (unit, os_data, verbose, testflag) end do write (unit, "(A)") "" write (unit, "(A)") "# Library driver" write (unit, "(A)") "$(BASE).lo: $(BASE).f90 $(OBJECTS)" write (unit, "(A)") TAB // "$(LTFCOMPILE) $<" if (.not. verbose) then write (unit, "(A)") TAB // '@echo " FC " $@' end if write (unit, "(A)") "" write (unit, "(A)") "# Library" write (unit, "(A)") "$(BASE).la: $(BASE).lo $(OBJECTS)" if (.not. verbose) then write (unit, "(A)") TAB // '@echo " FCLD " $@' end if write (unit, "(A)") TAB // "$(LINK) $(FC) -module -rpath /dev/null & &$(FCFLAGS) $(LDFLAGS) -o $(BASE).la $^" write (unit, "(A)") "" write (unit, "(A)") "# Main targets" write (unit, "(A)") "link: compile $(BASE).la" write (unit, "(A)") "compile: source $(OBJECTS) $(TEX_OBJECTS) $(BASE).lo" write (unit, "(A)") "compile_tex: $(TEX_OBJECTS)" write (unit, "(A)") "source: $(SOURCES) $(BASE).f90 $(TEX_SOURCES)" write (unit, "(A)") ".PHONY: link diags compile compile_tex source" write (unit, "(A)") "" write (unit, "(A)") "# Specific cleanup targets" do i = 1, size (driver%record) write (unit, "(A)") "clean-" // char (driver%record(i)%id) // ":" write (unit, "(A)") ".PHONY: clean-" // char (driver%record(i)%id) end do write (unit, "(A)") "" write (unit, "(A)") "# Generic cleanup targets" write (unit, "(A)") "clean-library:" if (verbose) then write (unit, "(A)") TAB // "rm -f $(BASE).la" else write (unit, "(A)") TAB // '@echo " RM $(BASE).la"' write (unit, "(A)") TAB // "@rm -f $(BASE).la" end if write (unit, "(A)") "clean-objects:" if (verbose) then write (unit, "(A)") TAB // "rm -f $(BASE).lo $(BASE)_driver.mod & &$(CLEAN_OBJECTS)" else write (unit, "(A)") TAB // '@echo " RM $(BASE).lo & &$(BASE)_driver.mod $(CLEAN_OBJECTS)"' write (unit, "(A)") TAB // "@rm -f $(BASE).lo $(BASE)_driver.mod & &$(CLEAN_OBJECTS)" end if write (unit, "(A)") "clean-source:" if (verbose) then write (unit, "(A)") TAB // "rm -f $(CLEAN_SOURCES)" else write (unit, "(A)") TAB // '@echo " RM $(CLEAN_SOURCES)"' write (unit, "(A)") TAB // "@rm -f $(CLEAN_SOURCES)" end if write (unit, "(A)") "clean-driver:" if (verbose) then write (unit, "(A)") TAB // "rm -f $(BASE).f90" else write (unit, "(A)") TAB // '@echo " RM $(BASE).f90"' write (unit, "(A)") TAB // "@rm -f $(BASE).f90" end if write (unit, "(A)") "clean-makefile:" if (verbose) then write (unit, "(A)") TAB // "rm -f $(BASE).makefile" else write (unit, "(A)") TAB // '@echo " RM $(BASE).makefile"' write (unit, "(A)") TAB // "@rm -f $(BASE).makefile" end if write (unit, "(A)") ".PHONY: clean-library clean-objects & &clean-source clean-driver clean-makefile" write (unit, "(A)") "" write (unit, "(A)") "clean: clean-library clean-objects clean-source" write (unit, "(A)") "distclean: clean clean-driver clean-makefile" write (unit, "(A)") ".PHONY: clean distclean" end subroutine prclib_driver_generate_makefile @ %def prclib_driver_generate_makefile @ \subsection{Write driver file} This procedure writes the process library driver source code to the specified output unit. The individual routines for writing source-code procedures are given below. <>= procedure :: generate_driver_code => prclib_driver_generate_code <>= module subroutine prclib_driver_generate_code (driver, unit) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit end subroutine prclib_driver_generate_code <>= module subroutine prclib_driver_generate_code (driver, unit) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t) :: prefix integer :: i prefix = driver%basename // "_" write (unit, "(A)") "! WHIZARD matrix-element code interface" write (unit, "(A)") "!" write (unit, "(A)") "! Automatically generated file, do not edit" call driver%write_module (unit, prefix) call driver%write_lib_md5sum_fun (unit, prefix) call driver%write_get_n_processes_fun (unit, prefix) call driver%write_get_process_id_fun (unit, prefix) call driver%write_get_model_name_fun (unit, prefix) call driver%write_get_md5sum_fun (unit, prefix) call driver%write_string_to_array_fun (unit, prefix) call driver%write_get_openmp_status_fun (unit, prefix) call driver%write_get_int_fun (unit, prefix, var_str ("n_in")) call driver%write_get_int_fun (unit, prefix, var_str ("n_out")) call driver%write_get_int_fun (unit, prefix, var_str ("n_flv")) call driver%write_get_int_fun (unit, prefix, var_str ("n_hel")) call driver%write_get_int_fun (unit, prefix, var_str ("n_col")) call driver%write_get_int_fun (unit, prefix, var_str ("n_cin")) call driver%write_get_int_fun (unit, prefix, var_str ("n_cf")) call driver%write_set_int_sub (unit, prefix, var_str ("flv_state")) call driver%write_set_int_sub (unit, prefix, var_str ("hel_state")) call driver%write_set_col_state_sub (unit, prefix) call driver%write_set_color_factors_sub (unit, prefix) call driver%write_get_fptr_sub (unit, prefix) do i = 1, driver%n_processes call driver%record(i)%write_wrappers (unit) end do end subroutine prclib_driver_generate_code @ %def prclib_driver_generate_code @ The driver module is used and required \emph{only} if we intend to link the library statically. Then, it provides the (static) driver type as a concrete implementation of the abstract library driver. This type contains the internal dispatcher for assigning the library procedures to their appropriate procedure pointers. In the dynamical case, the assignment is done via the base-type dispatcher which invokes the DL mechanism. However, compiling this together with the rest in any case should not do any harm. <>= procedure, nopass :: write_module => prclib_driver_write_module <>= module subroutine prclib_driver_write_module (unit, prefix) integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine prclib_driver_write_module <>= module subroutine prclib_driver_write_module (unit, prefix) integer, intent(in) :: unit type(string_t), intent(in) :: prefix write (unit, "(A)") "" write (unit, "(A)") "! Module: define library driver as an extension & &of the abstract driver type." write (unit, "(A)") "! This is used _only_ by the library dispatcher & &of a static executable." write (unit, "(A)") "! For a dynamical library, the stand-alone proce& &dures are linked via libdl." write (unit, "(A)") "" write (unit, "(A)") "module " & // char (prefix) // "driver" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " use iso_varying_string, string_t => varying_string" write (unit, "(A)") " use diagnostics" write (unit, "(A)") " use prclib_interfaces" write (unit, "(A)") "" write (unit, "(A)") " implicit none" write (unit, "(A)") "" write (unit, "(A)") " type, extends (prclib_driver_t) :: " & // char (prefix) // "driver_t" write (unit, "(A)") " contains" write (unit, "(A)") " procedure :: get_c_funptr => " & // char (prefix) // "driver_get_c_funptr" write (unit, "(A)") " end type " & // char (prefix) // "driver_t" write (unit, "(A)") "" write (unit, "(A)") "contains" write (unit, "(A)") "" write (unit, "(A)") " function " & // char (prefix) // "driver_get_c_funptr (driver, feature) result & &(c_fptr)" write (unit, "(A)") " class(" & // char (prefix) // "driver_t), intent(inout) :: driver" write (unit, "(A)") " type(string_t), intent(in) :: feature" write (unit, "(A)") " type(c_funptr) :: c_fptr" call write_decl ("get_n_processes", "get_n_processes") call write_decl ("get_stringptr", "get_process_id_ptr") call write_decl ("get_stringptr", "get_model_name_ptr") call write_decl ("get_stringptr", "get_md5sum_ptr") call write_decl ("get_log", "get_openmp_status") call write_decl ("get_int", "get_n_in") call write_decl ("get_int", "get_n_out") call write_decl ("get_int", "get_n_flv") call write_decl ("get_int", "get_n_hel") call write_decl ("get_int", "get_n_col") call write_decl ("get_int", "get_n_cin") call write_decl ("get_int", "get_n_cf") call write_decl ("set_int_tab1", "set_flv_state_ptr") call write_decl ("set_int_tab1", "set_hel_state_ptr") call write_decl ("set_col_state", "set_col_state_ptr") call write_decl ("set_color_factors", "set_color_factors_ptr") call write_decl ("get_fptr", "get_fptr") write (unit, "(A)") " select case (char (feature))" call write_case ("get_n_processes") call write_case ("get_process_id_ptr") call write_case ("get_model_name_ptr") call write_case ("get_md5sum_ptr") call write_case ("get_openmp_status") call write_case ("get_n_in") call write_case ("get_n_out") call write_case ("get_n_flv") call write_case ("get_n_hel") call write_case ("get_n_col") call write_case ("get_n_cin") call write_case ("get_n_cf") call write_case ("set_flv_state_ptr") call write_case ("set_hel_state_ptr") call write_case ("set_col_state_ptr") call write_case ("set_color_factors_ptr") call write_case ("get_fptr") write (unit, "(A)") " case default" write (unit, "(A)") " call msg_bug ('prclib2 driver setup: unknown & &function name')" write (unit, "(A)") " end select" write (unit, "(A)") " end function " & // char (prefix) // "driver_get_c_funptr" write (unit, "(A)") "" write (unit, "(A)") "end module " & // char (prefix) // "driver" write (unit, "(A)") "" write (unit, "(A)") "! Stand-alone external procedures: used for both & &static and dynamic linkage" contains subroutine write_decl (template, feature) character(*), intent(in) :: template, feature write (unit, "(A)") " procedure(prc_" // template // ") &" write (unit, "(A)") " :: " & // char (prefix) // feature end subroutine write_decl subroutine write_case (feature) character(*), intent(in) :: feature write (unit, "(A)") " case ('" // feature // "')" write (unit, "(A)") " c_fptr = c_funloc (" & // char (prefix) // feature // ")" end subroutine write_case end subroutine prclib_driver_write_module @ %def prclib_driver_write_module @ This function provides the overall library MD5sum. The function is for internal use (therefore not bind(C)), the external interface is via the [[get_md5sum_ptr]] procedure with index 0. <>= procedure :: write_lib_md5sum_fun => prclib_driver_write_lib_md5sum_fun <>= module subroutine prclib_driver_write_lib_md5sum_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine prclib_driver_write_lib_md5sum_fun <>= module subroutine prclib_driver_write_lib_md5sum_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix write (unit, "(A)") "" write (unit, "(A)") "! The MD5 sum of the library" write (unit, "(A)") "function " // char (prefix) & // "md5sum () result (md5sum)" write (unit, "(A)") " implicit none" write (unit, "(A)") " character(32) :: md5sum" write (unit, "(A)") " md5sum = '" // driver%md5sum // "'" write (unit, "(A)") "end function " // char (prefix) // "md5sum" end subroutine prclib_driver_write_lib_md5sum_fun @ %def prclib_driver_write_lib_md5sum_fun @ \subsection{Interface bodies for informational functions} These interfaces implement the communication between WHIZARD (the main program) and the process-library driver. The procedures are all BIND(C), so they can safely be exposed by the library and handled by the [[dlopen]] mechanism, which apparently understands only C calling conventions. In the sections below, for each procedure, we provide both the interface itself and a procedure that writes the correponding procedure as source code to the process library driver. \subsubsection{Process count} Return the number of processes contained in the library. <>= public :: prc_get_n_processes <>= abstract interface function prc_get_n_processes () result (n) bind(C) import integer(c_int) :: n end function prc_get_n_processes end interface @ %def prc_get_n_processes @ Here is the code. <>= procedure :: write_get_n_processes_fun <>= module subroutine write_get_n_processes_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_get_n_processes_fun <>= module subroutine write_get_n_processes_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix write (unit, "(A)") "" write (unit, "(A)") "! Return the number of processes in this library" write (unit, "(A)") "function " // char (prefix) & // "get_n_processes () result (n) bind(C)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " implicit none" write (unit, "(A)") " integer(c_int) :: n" write (unit, "(A,I0)") " n = ", driver%n_processes write (unit, "(A)") "end function " // char (prefix) & // "get_n_processes" end subroutine write_get_n_processes_fun @ %def write_get_n_processes_fun @ \subsubsection{Informational string functions} These functions return constant information about the matrix-element code. The following procedures have to return strings. With the BIND(C) constraint, we choose to return the C pointer to a string, and its length, so the procedures implement this interface. They are actually subroutines. <>= public :: prc_get_stringptr <>= abstract interface subroutine prc_get_stringptr (i, cptr, len) bind(C) import integer(c_int), intent(in) :: i type(c_ptr), intent(out) :: cptr integer(c_int), intent(out) :: len end subroutine prc_get_stringptr end interface @ %def prc_get_stringptr @ To hide this complication, we introduce a subroutine that converts the returned C pointer to a [[string_t]] object. As a side effect, we deallocate the original after conversion -- otherwise, we might have a memory leak. For the conversion, we first pointer-convert the C pointer to a Fortran character array pointer, length 1 and size [[len]]. Using argument association and an internal subroutine, we convert this to a character array with length [[len]] and size 1. Using ordinary assignment, we finally convert this to [[string_t]]. The function takes the pointer-returning function as an argument. The index [[i]] identifies the process in the library. <>= subroutine get_string_via_cptr (string, i, get_stringptr) type(string_t), intent(out) :: string integer, intent(in) :: i procedure(prc_get_stringptr) :: get_stringptr type(c_ptr) :: cptr integer(c_int) :: pid, len character(kind=c_char), dimension(:), pointer :: c_array pid = i call get_stringptr (pid, cptr, len) if (c_associated (cptr)) then call c_f_pointer (cptr, c_array, shape = [len]) call set_string (c_array) call get_stringptr (0_c_int, cptr, len) else string = "" end if contains subroutine set_string (buffer) character(len, kind=c_char), dimension(1), intent(in) :: buffer string = buffer(1) end subroutine set_string end subroutine get_string_via_cptr @ %def get_string_via_cptr @ Since the module procedures return Fortran strings, we have to convert them. This is the necessary auxiliary routine. The routine is not BIND(C), it is not accessed from outside. <>= procedure, nopass :: write_string_to_array_fun <>= module subroutine write_string_to_array_fun (unit, prefix) integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_string_to_array_fun <>= module subroutine write_string_to_array_fun (unit, prefix) integer, intent(in) :: unit type(string_t), intent(in) :: prefix write (unit, "(A)") "" write (unit, "(A)") "! Auxiliary: convert character string & &to array pointer" write (unit, "(A)") "subroutine " // char (prefix) & // "string_to_array (string, a)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " implicit none" write (unit, "(A)") " character(*), intent(in) :: string" write (unit, "(A)") " character(kind=c_char), dimension(:), & &allocatable, intent(out) :: a" write (unit, "(A)") " integer :: i" write (unit, "(A)") " allocate (a (len (string)))" write (unit, "(A)") " do i = 1, size (a)" write (unit, "(A)") " a(i) = string(i:i)" write (unit, "(A)") " end do" write (unit, "(A)") "end subroutine " // char (prefix) & // "string_to_array" end subroutine write_string_to_array_fun @ %def write_string_to_array_fun @ The above routine is called by other functions. It is not in a module, so they need its interface explicitly. <>= subroutine write_string_to_array_interface (unit, prefix) integer, intent(in) :: unit type(string_t), intent(in) :: prefix write (unit, "(2x,A)") "interface" write (unit, "(2x,A)") " subroutine " // char (prefix) & // "string_to_array (string, a)" write (unit, "(2x,A)") " use iso_c_binding" write (unit, "(2x,A)") " implicit none" write (unit, "(2x,A)") " character(*), intent(in) :: string" write (unit, "(2x,A)") " character(kind=c_char), dimension(:), & &allocatable, intent(out) :: a" write (unit, "(2x,A)") " end subroutine " // char (prefix) & // "string_to_array" write (unit, "(2x,A)") "end interface" end subroutine write_string_to_array_interface @ %def write_string_to_array_interface @ Here are the info functions which return strings, implementing the interface [[prc_get_stringptr]]. Return the process ID for each process. <>= procedure :: write_get_process_id_fun <>= module subroutine write_get_process_id_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_get_process_id_fun <>= module subroutine write_get_process_id_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix integer :: i write (unit, "(A)") "" write (unit, "(A)") "! Return the process ID of process #i & &(as a C pointer to a character array)" write (unit, "(A)") "subroutine " // char (prefix) & // "get_process_id_ptr (i, cptr, len) bind(C)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " implicit none" write (unit, "(A)") " integer(c_int), intent(in) :: i" write (unit, "(A)") " type(c_ptr), intent(out) :: cptr" write (unit, "(A)") " integer(c_int), intent(out) :: len" write (unit, "(A)") " character(kind=c_char), dimension(:), & &allocatable, target, save :: a" call write_string_to_array_interface (unit, prefix) write (unit, "(A)") " select case (i)" write (unit, "(A)") " case (0); if (allocated (a)) deallocate (a)" do i = 1, driver%n_processes write (unit, "(A,I0,9A)") " case (", i, "); ", & "call ", char (prefix), "string_to_array ('", & char (driver%record(i)%id), "', a)" end do write (unit, "(A)") " end select" write (unit, "(A)") " if (allocated (a)) then" write (unit, "(A)") " cptr = c_loc (a)" write (unit, "(A)") " len = size (a)" write (unit, "(A)") " else" write (unit, "(A)") " cptr = c_null_ptr" write (unit, "(A)") " len = 0" write (unit, "(A)") " end if" write (unit, "(A)") "end subroutine " // char (prefix) & // "get_process_id_ptr" end subroutine write_get_process_id_fun @ %def write_get_process_id_fun @ Return the model name, given explicitly. <>= procedure :: write_get_model_name_fun <>= module subroutine write_get_model_name_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_get_model_name_fun <>= module subroutine write_get_model_name_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix integer :: i write (unit, "(A)") "" write (unit, "(A)") "! Return the model name for process #i & &(as a C pointer to a character array)" write (unit, "(A)") "subroutine " // char (prefix) & // "get_model_name_ptr (i, cptr, len) bind(C)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " implicit none" write (unit, "(A)") " integer(c_int), intent(in) :: i" write (unit, "(A)") " type(c_ptr), intent(out) :: cptr" write (unit, "(A)") " integer(c_int), intent(out) :: len" write (unit, "(A)") " character(kind=c_char), dimension(:), & &allocatable, target, save :: a" call write_string_to_array_interface (unit, prefix) write (unit, "(A)") " select case (i)" write (unit, "(A)") " case (0); if (allocated (a)) deallocate (a)" do i = 1, driver%n_processes write (unit, "(A,I0,9A)") " case (", i, "); ", & "call ", char (prefix), "string_to_array ('" , & char (driver%record(i)%model_name), & "', a)" end do write (unit, "(A)") " end select" write (unit, "(A)") " if (allocated (a)) then" write (unit, "(A)") " cptr = c_loc (a)" write (unit, "(A)") " len = size (a)" write (unit, "(A)") " else" write (unit, "(A)") " cptr = c_null_ptr" write (unit, "(A)") " len = 0" write (unit, "(A)") " end if" write (unit, "(A)") "end subroutine " // char (prefix) & // "get_model_name_ptr" end subroutine write_get_model_name_fun @ %def write_get_model_name_fun @ Call the MD5 sum function for the process. The function calls the corresponding function of the matrix-element code, and it returns the C address of a character array with length 32. <>= procedure :: write_get_md5sum_fun <>= module subroutine write_get_md5sum_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_get_md5sum_fun <>= module subroutine write_get_md5sum_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix integer :: i write (unit, "(A)") "" write (unit, "(A)") "! Return the MD5 sum for the process configuration & &(as a C pointer to a character array)" write (unit, "(A)") "subroutine " // char (prefix) & // "get_md5sum_ptr (i, cptr, len) bind(C)" write (unit, "(A)") " use iso_c_binding" call driver%write_interfaces (unit, var_str ("md5sum")) write (unit, "(A)") " interface" write (unit, "(A)") " function " // char (prefix) & // "md5sum () result (md5sum)" write (unit, "(A)") " character(32) :: md5sum" write (unit, "(A)") " end function " // char (prefix) // "md5sum" write (unit, "(A)") " end interface" write (unit, "(A)") " integer(c_int), intent(in) :: i" write (unit, "(A)") " type(c_ptr), intent(out) :: cptr" write (unit, "(A)") " integer(c_int), intent(out) :: len" write (unit, "(A)") " character(kind=c_char), dimension(32), & &target, save :: md5sum" write (unit, "(A)") " select case (i)" write (unit, "(A)") " case (0)" write (unit, "(A)") " call copy (" // char (prefix) // "md5sum ())" write (unit, "(A)") " cptr = c_loc (md5sum)" do i = 1, driver%n_processes write (unit, "(A,I0,A)") " case (", i, ")" call driver%record(i)%write_md5sum_call (unit) end do write (unit, "(A)") " case default" write (unit, "(A)") " cptr = c_null_ptr" write (unit, "(A)") " end select" write (unit, "(A)") " len = 32" write (unit, "(A)") "contains" write (unit, "(A)") " subroutine copy (md5sum_tmp)" write (unit, "(A)") " character, dimension(32), intent(in) :: & &md5sum_tmp" write (unit, "(A)") " md5sum = md5sum_tmp" write (unit, "(A)") " end subroutine copy" write (unit, "(A)") "end subroutine " // char (prefix) & // "get_md5sum_ptr" end subroutine write_get_md5sum_fun @ %def write_get_md5sum_fun @ The actual call depends on the type of matrix element. <>= procedure :: write_md5sum_call => prclib_driver_record_write_md5sum_call <>= module subroutine prclib_driver_record_write_md5sum_call (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit end subroutine prclib_driver_record_write_md5sum_call <>= module subroutine prclib_driver_record_write_md5sum_call (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit call record%writer%write_md5sum_call (unit, record%id) end subroutine prclib_driver_record_write_md5sum_call @ %def prclib_driver_record_write_md5sum_call @ The interface goes into the writer base type: <>= procedure(write_code), deferred :: write_md5sum_call @ %def write_md5sum_call @ In the Fortran module case, we take a detour. The string returned by the Fortran function is copied into a fixed-size array. The copy routine is an internal subroutine of [[get_md5sum_ptr]]. We return the C address of the target array. <>= procedure :: write_md5sum_call => prc_writer_f_module_write_md5sum_call <>= module subroutine prc_writer_f_module_write_md5sum_call (writer, unit, id) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id end subroutine prc_writer_f_module_write_md5sum_call <>= module subroutine prc_writer_f_module_write_md5sum_call (writer, unit, id) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(5x,9A)") "call copy (", & char (writer%get_c_procname (id, var_str ("md5sum"))), " ())" write (unit, "(5x,9A)") "cptr = c_loc (md5sum)" end subroutine prc_writer_f_module_write_md5sum_call @ %def prc_writer_f_module_write_md5sum_call @ In the C library case, the library function returns a C pointer, which we can just copy. <>= procedure :: write_md5sum_call => prc_writer_c_lib_write_md5sum_call <>= module subroutine prc_writer_c_lib_write_md5sum_call (writer, unit, id) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id end subroutine prc_writer_c_lib_write_md5sum_call <>= module subroutine prc_writer_c_lib_write_md5sum_call (writer, unit, id) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(5x,9A)") & "cptr = ", & char (writer%get_c_procname (id, var_str ("get_md5sum"))), " ()" end subroutine prc_writer_c_lib_write_md5sum_call @ %def prc_writer_c_lib_write_md5sum_call @ \subsubsection{Actual references to the info functions} The string-valued info functions return C character arrays. For the API of the library driver, we provide convenience functions which (re)convert those arrays into [[string_t]] objects. <>= procedure :: get_process_id => prclib_driver_get_process_id procedure :: get_model_name => prclib_driver_get_model_name procedure :: get_md5sum => prclib_driver_get_md5sum <>= module function prclib_driver_get_process_id (driver, i) result (string) type(string_t) :: string class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i end function prclib_driver_get_process_id module function prclib_driver_get_model_name (driver, i) result (string) type(string_t) :: string class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i end function prclib_driver_get_model_name module function prclib_driver_get_md5sum (driver, i) result (string) type(string_t) :: string class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i end function prclib_driver_get_md5sum <>= module function prclib_driver_get_process_id (driver, i) result (string) type(string_t) :: string class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i call get_string_via_cptr (string, i, driver%get_process_id_ptr) end function prclib_driver_get_process_id module function prclib_driver_get_model_name (driver, i) result (string) type(string_t) :: string class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i call get_string_via_cptr (string, i, driver%get_model_name_ptr) end function prclib_driver_get_model_name module function prclib_driver_get_md5sum (driver, i) result (string) type(string_t) :: string class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i call get_string_via_cptr (string, i, driver%get_md5sum_ptr) end function prclib_driver_get_md5sum @ %def prclib_driver_get_process_id @ %def prclib_driver_get_model_name @ %def prclib_driver_get_md5sum @ \subsubsection{Informational logical functions} When returning a logical value, we use the C boolean type, which may differ from Fortran. <>= public :: prc_get_log <>= abstract interface function prc_get_log (pid) result (l) bind(C) import integer(c_int), intent(in) :: pid logical(c_bool) :: l end function prc_get_log end interface @ %def prc_get_log @ Return a logical flag which tells whether OpenMP is supported for a specific process code. <>= procedure :: write_get_openmp_status_fun <>= module subroutine write_get_openmp_status_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_get_openmp_status_fun <>= module subroutine write_get_openmp_status_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix integer :: i write (unit, "(A)") "" write (unit, "(A)") "! Return the OpenMP support status" write (unit, "(A)") "function " // char (prefix) & // "get_openmp_status (i) result (openmp_status) bind(C)" write (unit, "(A)") " use iso_c_binding" call driver%write_interfaces (unit, var_str ("openmp_supported")) write (unit, "(A)") " integer(c_int), intent(in) :: i" write (unit, "(A)") " logical(c_bool) :: openmp_status" write (unit, "(A)") " select case (i)" do i = 1, driver%n_processes write (unit, "(A,I0,9A)") " case (", i, "); ", & "openmp_status = ", & char (driver%record(i)%get_c_procname & (var_str ("openmp_supported"))), " ()" end do write (unit, "(A)") " end select" write (unit, "(A)") "end function " // char (prefix) & // "get_openmp_status" end subroutine write_get_openmp_status_fun @ %def write_get_openmp_status_fun @ \subsubsection{Informational integer functions} Various process metadata are integer values. We can use a single interface for all of them. <>= public :: prc_get_int <>= 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 @ %def prc_get_int @ This function returns any data of type integer, for each process. <>= procedure :: write_get_int_fun <>= module subroutine write_get_int_fun (driver, unit, prefix, feature) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix type(string_t), intent(in) :: feature end subroutine write_get_int_fun <>= module subroutine write_get_int_fun (driver, unit, prefix, feature) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix type(string_t), intent(in) :: feature integer :: i write (unit, "(A)") "" write (unit, "(9A)") "! Return the value of ", char (feature) write (unit, "(9A)") "function ", char (prefix), & "get_", char (feature), " (pid)", & " result (", char (feature), ") bind(C)" write (unit, "(9A)") " use iso_c_binding" call driver%write_interfaces (unit, feature) write (unit, "(9A)") " integer(c_int), intent(in) :: pid" write (unit, "(9A)") " integer(c_int) :: ", char (feature) write (unit, "(9A)") " select case (pid)" do i = 1, driver%n_processes write (unit, "(2x,A,I0,9A)") "case (", i, "); ", & char (feature), " = ", & char (driver%record(i)%get_c_procname (feature)), & " ()" end do write (unit, "(9A)") " end select" write (unit, "(9A)") "end function ", char (prefix), & "get_", char (feature) end subroutine write_get_int_fun @ %def write_get_int_fun @ Write a [[case]] line that assigns the value of the external function to the current return value. <>= subroutine write_case_int_fun (record, unit, i, feature) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit integer, intent(in) :: i type(string_t), intent(in) :: feature write (unit, "(5x,A,I0,9A)") "case (", i, "); ", & char (feature), " = ", char (record%get_c_procname (feature)) end subroutine write_case_int_fun @ %def write_case_int_fun @ \subsubsection{Flavor and helicity tables} Transferring tables is more complicated. First, a two-dimensional array. <>= public :: prc_set_int_tab1 <>= 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 @ %def prc_set_int_tab1 @ This subroutine returns a table of integers. <>= procedure :: write_set_int_sub <>= module subroutine write_set_int_sub (driver, unit, prefix, feature) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix type(string_t), intent(in) :: feature end subroutine write_set_int_sub <>= module subroutine write_set_int_sub (driver, unit, prefix, feature) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix type(string_t), intent(in) :: feature integer :: i write (unit, "(A)") "" write (unit, "(9A)") "! Set table: ", char (feature) write (unit, "(9A)") "subroutine ", char (prefix), & "set_", char (feature), "_ptr (pid, ", char (feature), & ", shape) bind(C)" write (unit, "(9A)") " use iso_c_binding" call driver%write_interfaces (unit, feature) write (unit, "(9A)") " integer(c_int), intent(in) :: pid" write (unit, "(9A)") " integer(c_int), dimension(*), intent(out) :: ", & char (feature) write (unit, "(9A)") " integer(c_int), dimension(2), intent(in) :: shape" write (unit, "(9A)") " integer, dimension(:,:), allocatable :: ", & char (feature), "_tmp" write (unit, "(9A)") " integer :: i, j" write (unit, "(9A)") " select case (pid)" do i = 1, driver%n_processes write (unit, "(2x,A,I0,A)") "case (", i, ")" call driver%record(i)%write_int_sub_call (unit, feature) end do write (unit, "(9A)") " end select" write (unit, "(9A)") "end subroutine ", char (prefix), & "set_", char (feature), "_ptr" end subroutine write_set_int_sub @ %def write_set_int_sub @ The actual call depends on the type of matrix element. <>= procedure :: write_int_sub_call => prclib_driver_record_write_int_sub_call <>= module subroutine prclib_driver_record_write_int_sub_call (record, unit, feature) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(string_t), intent(in) :: feature end subroutine prclib_driver_record_write_int_sub_call <>= module subroutine prclib_driver_record_write_int_sub_call (record, unit, feature) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(string_t), intent(in) :: feature call record%writer%write_int_sub_call (unit, record%id, feature) end subroutine prclib_driver_record_write_int_sub_call @ %def prclib_driver_record_write_int_sub_call @ The interface goes into the writer base type: <>= procedure(write_feature_code), deferred :: write_int_sub_call @ %def write_int_sub_call @ In the Fortran module case, we need an extra copy in the (academical) situation where default integer and [[c_int]] differ. Otherwise, we just associate a Fortran array with the C pointer and let the matrix-element subroutine fill the array. <>= procedure :: write_int_sub_call => prc_writer_f_module_write_int_sub_call <>= module subroutine prc_writer_f_module_write_int_sub_call (writer, unit, id, feature) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature end subroutine prc_writer_f_module_write_int_sub_call <>= module subroutine prc_writer_f_module_write_int_sub_call (writer, unit, id, feature) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, "(5x,9A)") "allocate (", char (feature), "_tmp ", & "(shape(1), shape(2)))" write (unit, "(5x,9A)") "call ", & char (writer%get_c_procname (id, feature)), & " (", char (feature), "_tmp)" write (unit, "(5x,9A)") "forall (i=1:shape(1), j=1:shape(2)) " write (unit, "(8x,9A)") char (feature), "(i + shape(1)*(j-1)) = ", & char (feature), "_tmp", "(i,j)" write (unit, "(5x,9A)") "end forall" end subroutine prc_writer_f_module_write_int_sub_call @ %def prc_writer_f_module_write_int_sub_call @ In the C library case, we just transfer the C pointer to the library function. <>= procedure :: write_int_sub_call => prc_writer_c_lib_write_int_sub_call <>= module subroutine prc_writer_c_lib_write_int_sub_call (writer, unit, id, feature) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature end subroutine prc_writer_c_lib_write_int_sub_call <>= module subroutine prc_writer_c_lib_write_int_sub_call (writer, unit, id, feature) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, "(5x,9A)") "call ", & char (writer%get_c_procname (id, feature)), " (", char (feature), ")" end subroutine prc_writer_c_lib_write_int_sub_call @ %def prc_writer_c_lib_write_int_sub_call @ \subsubsection{Color state table} The color-state specification needs a table of integers (one array per color flow) and a corresponding array of color-ghost flags. <>= public :: prc_set_col_state <>= abstract interface subroutine prc_set_col_state (pid, col_state, ghost_flag, shape) bind(C) import integer(c_int), intent(in) :: pid integer(c_int), dimension(*), intent(out) :: col_state logical(c_bool), dimension(*), intent(out) :: ghost_flag integer(c_int), dimension(3), intent(in) :: shape end subroutine prc_set_col_state end interface @ %def prc_set_int_tab2 @ <>= procedure :: write_set_col_state_sub <>= module subroutine write_set_col_state_sub (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_set_col_state_sub <>= module subroutine write_set_col_state_sub (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix integer :: i type(string_t) :: feature feature = "col_state" write (unit, "(A)") "" write (unit, "(9A)") "! Set tables: col_state, ghost_flag" write (unit, "(9A)") "subroutine ", char (prefix), & "set_col_state_ptr (pid, col_state, ghost_flag, shape) bind(C)" write (unit, "(9A)") " use iso_c_binding" call driver%write_interfaces (unit, feature) write (unit, "(9A)") " integer(c_int), intent(in) :: pid" write (unit, "(9A)") & " integer(c_int), dimension(*), intent(out) :: col_state" write (unit, "(9A)") & " logical(c_bool), dimension(*), intent(out) :: ghost_flag" write (unit, "(9A)") & " integer(c_int), dimension(3), intent(in) :: shape" write (unit, "(9A)") & " integer, dimension(:,:,:), allocatable :: col_state_tmp" write (unit, "(9A)") & " logical, dimension(:,:), allocatable :: ghost_flag_tmp" write (unit, "(9A)") " integer :: i, j, k" write (unit, "(A)") " select case (pid)" do i = 1, driver%n_processes write (unit, "(A,I0,A)") " case (", i, ")" call driver%record(i)%write_col_state_call (unit) end do write (unit, "(A)") " end select" write (unit, "(9A)") "end subroutine ", char (prefix), & "set_col_state_ptr" end subroutine write_set_col_state_sub @ %def write_set_col_state_sub @ The actual call depends on the type of matrix element. <>= procedure :: write_col_state_call => prclib_driver_record_write_col_state_call <>= module subroutine prclib_driver_record_write_col_state_call (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit end subroutine prclib_driver_record_write_col_state_call <>= module subroutine prclib_driver_record_write_col_state_call (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit call record%writer%write_col_state_call (unit, record%id) end subroutine prclib_driver_record_write_col_state_call @ %def prclib_driver_record_write_col_state_call @ The interface goes into the writer base type: <>= procedure(write_code), deferred :: write_col_state_call @ %def write_col_state_call @ In the Fortran module case, we need an extra copy in the (academical) situation where default integer and [[c_int]] differ. Otherwise, we just associate a Fortran array with the C pointer and let the matrix-element subroutine fill the array. <>= procedure :: write_col_state_call => prc_writer_f_module_write_col_state_call <>= module subroutine prc_writer_f_module_write_col_state_call (writer, unit, id) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id end subroutine prc_writer_f_module_write_col_state_call <>= module subroutine prc_writer_f_module_write_col_state_call (writer, unit, id) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(9A)") " allocate (col_state_tmp ", & "(shape(1), shape(2), shape(3)))" write (unit, "(5x,9A)") "allocate (ghost_flag_tmp ", & "(shape(2), shape(3)))" write (unit, "(5x,9A)") "call ", & char (writer%get_c_procname (id, var_str ("col_state"))), & " (col_state_tmp, ghost_flag_tmp)" write (unit, "(5x,9A)") "forall (i = 1:shape(2), j = 1:shape(3))" write (unit, "(8x,9A)") "forall (k = 1:shape(1))" write (unit, "(11x,9A)") & "col_state(k + shape(1) * (i + shape(2)*(j-1) - 1)) ", & "= col_state_tmp(k,i,j)" write (unit, "(8x,9A)") "end forall" write (unit, "(8x,9A)") & "ghost_flag(i + shape(2)*(j-1)) = ghost_flag_tmp(i,j)" write (unit, "(5x,9A)") "end forall" end subroutine prc_writer_f_module_write_col_state_call @ %def prc_writer_f_module_write_col_state_call @ In the C library case, we just transfer the C pointer to the library function. <>= procedure :: write_col_state_call => prc_writer_c_lib_write_col_state_call <>= module subroutine prc_writer_c_lib_write_col_state_call (writer, unit, id) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id end subroutine prc_writer_c_lib_write_col_state_call <>= module subroutine prc_writer_c_lib_write_col_state_call (writer, unit, id) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(5x,9A)") "call ", & char (writer%get_c_procname (id, var_str ("col_state"))), & " (col_state, ghost_flag)" end subroutine prc_writer_c_lib_write_col_state_call @ %def prc_writer_c_lib_write_col_state_call @ \subsubsection{Color factors} For the color-factor information, we return two integer arrays and a complex array. <>= public :: prc_set_color_factors <>= abstract interface subroutine prc_set_color_factors & (pid, cf_index1, cf_index2, color_factors, shape) bind(C) import integer(c_int), intent(in) :: pid integer(c_int), dimension(*), intent(out) :: cf_index1, cf_index2 complex(c_default_complex), dimension(*), intent(out) :: color_factors integer(c_int), dimension(1), intent(in) :: shape end subroutine prc_set_color_factors end interface @ %def prc_set_color_factors @ This subroutine returns the color-flavor factor table. <>= procedure :: write_set_color_factors_sub <>= module subroutine write_set_color_factors_sub (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_set_color_factors_sub <>= module subroutine write_set_color_factors_sub (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix integer :: i type(string_t) :: feature feature = "color_factors" write (unit, "(A)") "" write (unit, "(A)") "! Set tables: color factors" write (unit, "(9A)") "subroutine ", char (prefix), & "set_color_factors_ptr (pid, cf_index1, cf_index2, color_factors, ", & "shape) bind(C)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " use kinds" write (unit, "(A)") " use omega_color" call driver%write_interfaces (unit, feature) write (unit, "(A)") " integer(c_int), intent(in) :: pid" write (unit, "(A)") " integer(c_int), dimension(1), intent(in) :: shape" write (unit, "(A)") " integer(c_int), dimension(*), intent(out) :: & &cf_index1, cf_index2" write (unit, "(A)") " complex(c_default_complex), dimension(*), & &intent(out) :: color_factors" write (unit, "(A)") " type(omega_color_factor), dimension(:), & &allocatable :: cf" write (unit, "(A)") " select case (pid)" do i = 1, driver%n_processes write (unit, "(2x,A,I0,A)") "case (", i, ")" call driver%record(i)%write_color_factors_call (unit) end do write (unit, "(A)") " end select" write (unit, "(A)") "end subroutine " // char (prefix) & // "set_color_factors_ptr" end subroutine write_set_color_factors_sub @ %def write_set_color_factors_sub @ The actual call depends on the type of matrix element. <>= procedure :: write_color_factors_call => prclib_driver_record_write_color_factors_call <>= module subroutine prclib_driver_record_write_color_factors_call (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit end subroutine prclib_driver_record_write_color_factors_call <>= module subroutine prclib_driver_record_write_color_factors_call (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit call record%writer%write_color_factors_call (unit, record%id) end subroutine prclib_driver_record_write_color_factors_call @ %def prclib_driver_record_write_color_factors_call @ The interface goes into the writer base type: <>= procedure(write_code), deferred :: write_color_factors_call @ %def write_color_factors_call @ In the Fortran module case, the matrix-element procedure fills an array of [[omega_color_factor]] elements. We distribute this array among two integer arrays and one complex-valued array, for which we have the C pointers. <>= procedure :: write_color_factors_call => prc_writer_f_module_write_color_factors_call <>= module subroutine prc_writer_f_module_write_color_factors_call (writer, unit, id) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id end subroutine prc_writer_f_module_write_color_factors_call <>= module subroutine prc_writer_f_module_write_color_factors_call (writer, unit, id) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(5x,A)") "allocate (cf (shape(1)))" write (unit, "(5x,9A)") "call ", & char (writer%get_c_procname (id, var_str ("color_factors"))), " (cf)" write (unit, "(5x,9A)") "cf_index1(1:shape(1)) = cf%i1" write (unit, "(5x,9A)") "cf_index2(1:shape(1)) = cf%i2" write (unit, "(5x,9A)") "color_factors(1:shape(1)) = cf%factor" end subroutine prc_writer_f_module_write_color_factors_call @ %def prc_writer_f_module_write_color_factors_call @ In the C library case, we just transfer the C pointers to the library function. There are three arrays. <>= procedure :: write_color_factors_call => & prc_writer_c_lib_write_color_factors_call <>= module subroutine prc_writer_c_lib_write_color_factors_call (writer, unit, id) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id end subroutine prc_writer_c_lib_write_color_factors_call <>= module subroutine prc_writer_c_lib_write_color_factors_call (writer, unit, id) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(5x,9A)") "call ", & char (writer%get_c_procname (id, var_str ("color_factors"))), & " (cf_index1, cf_index2, color_factors)" end subroutine prc_writer_c_lib_write_color_factors_call @ %def prc_writer_c_lib_write_color_factors_call @ \subsection{Interfaces for C-library matrix element} If the matrix element code is not provided as a Fortran module but as a C or bind(C) Fortran library, we need explicit interfaces for the library functions. They are not identical to the Fortran module versions. They transfer pointers directly. The implementation is part of the [[prc_writer_c_lib]] type, which serves as base type for all C-library writers. It writes specific interfaces depending on the feature. We bind this as the method [[write_standard_interface]] instead of [[write_interface]], because we have to override the latter. Otherwise we could not call the method because the writer type is abstract. <>= procedure :: write_standard_interface => prc_writer_c_lib_write_interface <>= module subroutine prc_writer_c_lib_write_interface (writer, unit, id, feature) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature end subroutine prc_writer_c_lib_write_interface <>= module subroutine prc_writer_c_lib_write_interface (writer, unit, id, feature) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature select case (char (feature)) case ("md5sum") write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "function ", & char (writer%get_c_procname (id, var_str ("get_md5sum"))), & " () result (cptr) bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "type(c_ptr) :: cptr" write (unit, "(5x,9A)") "end function ", & char (writer%get_c_procname (id, var_str ("get_md5sum"))) write (unit, "(2x,9A)") "end interface" case ("openmp_supported") write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "function ", & char (writer%get_c_procname (id, feature)), & " () result (status) bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "logical(c_bool) :: status" write (unit, "(5x,9A)") "end function ", & char (writer%get_c_procname (id, feature)) write (unit, "(2x,9A)") "end interface" case ("n_in", "n_out", "n_flv", "n_hel", "n_col", "n_cin", "n_cf") write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "function ", & char (writer%get_c_procname (id, feature)), & " () result (n) bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "integer(c_int) :: n" write (unit, "(5x,9A)") "end function ", & char (writer%get_c_procname (id, feature)) write (unit, "(2x,9A)") "end interface" case ("flv_state", "hel_state") write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "subroutine ", & char (writer%get_c_procname (id, feature)), & " (", char (feature), ") bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "integer(c_int), dimension(*), intent(out) ", & ":: ", char (feature) write (unit, "(5x,9A)") "end subroutine ", & char (writer%get_c_procname (id, feature)) write (unit, "(2x,9A)") "end interface" case ("col_state") write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "subroutine ", & char (writer%get_c_procname (id, feature)), & " (col_state, ghost_flag) bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "integer(c_int), dimension(*), intent(out) ", & ":: col_state" write (unit, "(7x,9A)") "logical(c_bool), dimension(*), intent(out) ", & ":: ghost_flag" write (unit, "(5x,9A)") "end subroutine ", & char (writer%get_c_procname (id, feature)) write (unit, "(2x,9A)") "end interface" case ("color_factors") write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "subroutine ", & char (writer%get_c_procname (id, feature)), & " (cf_index1, cf_index2, color_factors) bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "integer(c_int), dimension(*), & &intent(out) :: cf_index1" write (unit, "(7x,9A)") "integer(c_int), dimension(*), & &intent(out) :: cf_index2" write (unit, "(7x,9A)") "complex(c_default_complex), dimension(*), & &intent(out) :: color_factors" write (unit, "(5x,9A)") "end subroutine ", & char (writer%get_c_procname (id, feature)) write (unit, "(2x,9A)") "end interface" end select end subroutine prc_writer_c_lib_write_interface @ %def prc_writer_c_lib_write_interface @ \subsection{Retrieving the tables} In the previous section we had the writer routines for procedures that return tables, actually C pointers to tables. Here, we write convenience routines that unpack them and move the contents to suitable Fortran arrays. The flavor and helicity tables are two-dimensional integer arrays. We use intermediate storage for correctly transforming C to Fortran data types. <>= procedure :: set_flv_state => prclib_driver_set_flv_state procedure :: set_hel_state => prclib_driver_set_hel_state <>= module subroutine prclib_driver_set_flv_state (driver, i, flv_state) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i integer, dimension(:,:), allocatable, intent(out) :: flv_state end subroutine prclib_driver_set_flv_state module subroutine prclib_driver_set_hel_state (driver, i, hel_state) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i integer, dimension(:,:), allocatable, intent(out) :: hel_state end subroutine prclib_driver_set_hel_state <>= module subroutine prclib_driver_set_flv_state (driver, i, flv_state) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i integer, dimension(:,:), allocatable, intent(out) :: flv_state integer :: n_tot, n_flv integer(c_int) :: pid integer(c_int), dimension(:,:), allocatable :: c_flv_state pid = i n_tot = driver%get_n_in (pid) + driver%get_n_out (pid) n_flv = driver%get_n_flv (pid) allocate (flv_state (n_tot, n_flv)) allocate (c_flv_state (n_tot, n_flv)) call driver%set_flv_state_ptr & (pid, c_flv_state, int ([n_tot, n_flv], kind=c_int)) flv_state = c_flv_state end subroutine prclib_driver_set_flv_state module subroutine prclib_driver_set_hel_state (driver, i, hel_state) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i integer, dimension(:,:), allocatable, intent(out) :: hel_state integer :: n_tot, n_hel integer(c_int) :: pid integer(c_int), dimension(:,:), allocatable, target :: c_hel_state pid = i n_tot = driver%get_n_in (pid) + driver%get_n_out (pid) n_hel = driver%get_n_hel (pid) allocate (hel_state (n_tot, n_hel)) allocate (c_hel_state (n_tot, n_hel)) call driver%set_hel_state_ptr & (pid, c_hel_state, int ([n_tot, n_hel], kind=c_int)) hel_state = c_hel_state end subroutine prclib_driver_set_hel_state @ %def prclib_driver_set_flv_state @ %def prclib_driver_set_hel_state @ The color-flow table is three-dimensional, otherwise similar. We simultaneously set the ghost-flag table, which consists of logical entries. <>= procedure :: set_col_state => prclib_driver_set_col_state <>= module subroutine prclib_driver_set_col_state (driver, i, col_state, ghost_flag) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i integer, dimension(:,:,:), allocatable, intent(out) :: col_state logical, dimension(:,:), allocatable, intent(out) :: ghost_flag end subroutine prclib_driver_set_col_state <>= module subroutine prclib_driver_set_col_state (driver, i, col_state, ghost_flag) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i integer, dimension(:,:,:), allocatable, intent(out) :: col_state logical, dimension(:,:), allocatable, intent(out) :: ghost_flag integer :: n_cin, n_tot, n_col integer(c_int) :: pid integer(c_int), dimension(:,:,:), allocatable :: c_col_state logical(c_bool), dimension(:,:), allocatable :: c_ghost_flag pid = i n_cin = driver%get_n_cin (pid) n_tot = driver%get_n_in (pid) + driver%get_n_out (pid) n_col = driver%get_n_col (pid) allocate (col_state (n_cin, n_tot, n_col)) allocate (c_col_state (n_cin, n_tot, n_col)) allocate (ghost_flag (n_tot, n_col)) allocate (c_ghost_flag (n_tot, n_col)) call driver%set_col_state_ptr (pid, & c_col_state, c_ghost_flag, int ([n_cin, n_tot, n_col], kind=c_int)) col_state = c_col_state ghost_flag = c_ghost_flag end subroutine prclib_driver_set_col_state @ %def prclib_driver_set_col_state @ The color-factor table is a sparse matrix: a two-column array of indices and one array which contains the corresponding factors. <>= procedure :: set_color_factors => prclib_driver_set_color_factors <>= module subroutine prclib_driver_set_color_factors (driver, i, color_factors, cf_index) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i complex(default), dimension(:), allocatable, intent(out) :: color_factors integer, dimension(:,:), allocatable, intent(out) :: cf_index end subroutine prclib_driver_set_color_factors <>= module subroutine prclib_driver_set_color_factors (driver, i, color_factors, cf_index) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i complex(default), dimension(:), allocatable, intent(out) :: color_factors integer, dimension(:,:), allocatable, intent(out) :: cf_index integer :: n_cf integer(c_int) :: pid complex(c_default_complex), dimension(:), allocatable, target :: c_color_factors integer(c_int), dimension(:), allocatable, target :: c_cf_index1 integer(c_int), dimension(:), allocatable, target :: c_cf_index2 pid = i n_cf = driver%get_n_cf (pid) allocate (color_factors (n_cf)) allocate (c_color_factors (n_cf)) allocate (c_cf_index1 (n_cf)) allocate (c_cf_index2 (n_cf)) call driver%set_color_factors_ptr (pid, & c_cf_index1, c_cf_index2, & c_color_factors, int ([n_cf], kind=c_int)) color_factors = c_color_factors allocate (cf_index (2, n_cf)) cf_index(1,:) = c_cf_index1 cf_index(2,:) = c_cf_index2 end subroutine prclib_driver_set_color_factors @ %def prclib_driver_set_color_factors @ \subsection{Returning a procedure pointer} The functions that directly access the matrix element, event by event, are assigned to a process-specific driver object as procedure pointers. For the [[dlopen]] interface, we use C function pointers. This subroutine returns such a pointer: <>= public :: prc_get_fptr <>= abstract interface subroutine prc_get_fptr (pid, fid, fptr) bind(C) import integer(c_int), intent(in) :: pid integer(c_int), intent(in) :: fid type(c_funptr), intent(out) :: fptr end subroutine prc_get_fptr end interface @ %def prc_get_fptr @ This procedure writes the source code for the procedure pointer returning subroutine. All C functions that are provided by the matrix element code of a specific process are handled here. The selection consists of a double layered [[select]] [[case]] construct. <>= procedure :: write_get_fptr_sub <>= module subroutine write_get_fptr_sub (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_get_fptr_sub <>= module subroutine write_get_fptr_sub (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix integer :: i, j write (unit, "(A)") "" write (unit, "(A)") "! Return C pointer to a procedure:" write (unit, "(A)") "! pid = process index; fid = function index" write (unit, "(4A)") "subroutine ", char (prefix), "get_fptr ", & "(pid, fid, fptr) bind(C)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " use kinds" write (unit, "(A)") " implicit none" write (unit, "(A)") " integer(c_int), intent(in) :: pid" write (unit, "(A)") " integer(c_int), intent(in) :: fid" write (unit, "(A)") " type(c_funptr), intent(out) :: fptr" do i = 1, driver%n_processes call driver%record(i)%write_interfaces (unit) end do write (unit, "(A)") " select case (pid)" do i = 1, driver%n_processes write (unit, "(2x,A,I0,A)") "case (", i, ")" write (unit, "(5x,A)") "select case (fid)" associate (record => driver%record(i)) do j = 1, size (record%feature) write (unit, "(5x,A,I0,9A)") "case (", j, "); ", & "fptr = c_funloc (", & char (record%get_c_procname (record%feature(j))), & ")" end do end associate write (unit, "(5x,A)") "end select" end do write (unit, "(A)") " end select" write (unit, "(3A)") "end subroutine ", char (prefix), "get_fptr" end subroutine write_get_fptr_sub @ %def write_get_fptr_sub @ The procedures for which we want to return a pointer (the 'features' of the matrix element code) are actually Fortran module procedures. If we want to have a C signature, we must write wrapper functions for all of them. The procedures, their signatures, and the appropriate writer routines are specific for the process type. To keep this generic, we do not provide the writer routines here, but just the interface for a writer routine. The actual routines are stored in the process record. The [[prefix]] indicates the library, the [[id]] indicates the process, and [[procname]] is the bare name of the procedure to be written. <>= public :: write_driver_code <>= abstract interface subroutine write_driver_code (unit, prefix, id, procname) import integer, intent(in) :: unit type(string_t), intent(in) :: prefix type(string_t), intent(in) :: id type(string_t), intent(in) :: procname end subroutine write_driver_code end interface @ %def write_driver_code @ \subsection{Hooks} Interface for additional library unload / reload hooks (currently unused!) <>= public :: prclib_unload_hook public :: prclib_reload_hook <>= abstract interface subroutine prclib_unload_hook (libname) import type(string_t), intent(in) :: libname end subroutine prclib_unload_hook subroutine prclib_reload_hook (libname) import type(string_t), intent(in) :: libname end subroutine prclib_reload_hook end interface @ %def prclib_unload_hook @ %def prclib_reload_hook @ \subsection{Make source, compile, link} Since we should have written a Makefile, these tasks amount to simple [[make]] calls. Note that the Makefile targets depend on each other, so calling [[link]] executes also the [[source]] and [[compile]] steps, when necessary. Optionally, we can use a subdirectory. We construct a prefix for the subdirectory, and generate a shell [[cd]] call that moves us into the workspace. The [[prefix]] version is intended to be prepended to a filename, and can be empty. The [[path]] version is intended to be prepended with a following slash, so the default is [[.]]. <>= public :: workspace_prefix public :: workspace_path <>= module function workspace_prefix (workspace) result (prefix) type(string_t), intent(in), optional :: workspace type(string_t) :: prefix end function workspace_prefix module function workspace_path (workspace) result (path) type(string_t), intent(in), optional :: workspace type(string_t) :: path end function workspace_path module function workspace_cmd (workspace) result (cmd) type(string_t), intent(in), optional :: workspace type(string_t) :: cmd end function workspace_cmd <>= module function workspace_prefix (workspace) result (prefix) type(string_t), intent(in), optional :: workspace type(string_t) :: prefix if (present (workspace)) then if (workspace /= "") then prefix = workspace // "/" else prefix = "" end if else prefix = "" end if end function workspace_prefix module function workspace_path (workspace) result (path) type(string_t), intent(in), optional :: workspace type(string_t) :: path if (present (workspace)) then if (workspace /= "") then path = workspace else path = "." end if else path = "." end if end function workspace_path module function workspace_cmd (workspace) result (cmd) type(string_t), intent(in), optional :: workspace type(string_t) :: cmd if (present (workspace)) then if (workspace /= "") then cmd = "cd " // workspace // " && " else cmd = "" end if else cmd = "" end if end function workspace_cmd @ %def workspace_prefix @ %def workspace_path @ %def workspace_cmd @ The first routine writes source-code files for the individual processes. First it calls the writer routines directly for each process, then it calls [[make source]]. The make command may either post-process the files, or it may do the complete work, e.g., calling an external program the generates the files. <>= procedure :: make_source => prclib_driver_make_source <>= module subroutine prclib_driver_make_source (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_make_source <>= module subroutine prclib_driver_make_source (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace integer :: i do i = 1, driver%n_processes call driver%record(i)%write_source_code () end do call os_system_call ( & workspace_cmd (workspace) & // "make source " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end subroutine prclib_driver_make_source @ %def prclib_driver_make_source @ Compile matrix element source code and the driver source code. As above, we first iterate through all processes and call [[before_compile]]. This is usually empty, but can execute code that depends on [[make_source]] already completed. Similarly, [[after_compile]] scans all processes again. <>= procedure :: make_compile => prclib_driver_make_compile <>= module subroutine prclib_driver_make_compile (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_make_compile <>= module subroutine prclib_driver_make_compile (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace integer :: i do i = 1, driver%n_processes call driver%record(i)%before_compile () end do call os_system_call ( & workspace_cmd (workspace) & // "make compile " // os_data%makeflags & // " -f " // driver%basename // ".makefile") do i = 1, driver%n_processes call driver%record(i)%after_compile () end do end subroutine prclib_driver_make_compile @ %def prclib_driver_make_compile @ Combine all matrix-element code together with the driver in a process library on disk. <>= procedure :: make_link => prclib_driver_make_link <>= module subroutine prclib_driver_make_link (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_make_link <>= module subroutine prclib_driver_make_link (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace integer :: i call os_system_call ( & workspace_cmd (workspace) & // "make link " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end subroutine prclib_driver_make_link @ %def prclib_driver_make_link @ \subsection{Clean up generated files} The task of cleaning any generated files should also be deferred to Makefile targets. Apart from removing everything, removing specific files may be useful for partial rebuilds. (Note that removing the makefile itself can only be done once, for obvious reasons.) If there is no makefile, do nothing. <>= procedure :: clean_library => prclib_driver_clean_library procedure :: clean_objects => prclib_driver_clean_objects procedure :: clean_source => prclib_driver_clean_source procedure :: clean_driver => prclib_driver_clean_driver procedure :: clean_makefile => prclib_driver_clean_makefile procedure :: clean => prclib_driver_clean procedure :: distclean => prclib_driver_distclean <>= module subroutine prclib_driver_clean_library (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_clean_library module subroutine prclib_driver_clean_objects (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_clean_objects module subroutine prclib_driver_clean_source (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_clean_source module subroutine prclib_driver_clean_driver (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_clean_driver module subroutine prclib_driver_clean_makefile (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_clean_makefile module subroutine prclib_driver_clean (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_clean module subroutine prclib_driver_distclean (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_distclean <>= module subroutine prclib_driver_clean_library (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace if (driver%makefile_exists ()) then call os_system_call ( & workspace_cmd (workspace) & // "make clean-library " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_clean_library module subroutine prclib_driver_clean_objects (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace if (driver%makefile_exists ()) then call os_system_call ( & workspace_cmd (workspace) & // "make clean-objects " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_clean_objects module subroutine prclib_driver_clean_source (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace if (driver%makefile_exists ()) then call os_system_call ( & workspace_cmd (workspace) & // "make clean-source " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_clean_source module subroutine prclib_driver_clean_driver (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace if (driver%makefile_exists ()) then call os_system_call ( & workspace_cmd (workspace) & // "make clean-driver " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_clean_driver module subroutine prclib_driver_clean_makefile (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace if (driver%makefile_exists ()) then call os_system_call ( & workspace_cmd (workspace) & // "make clean-makefile " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_clean_makefile module subroutine prclib_driver_clean (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace if (driver%makefile_exists ()) then call os_system_call ( & workspace_cmd (workspace) & // "make clean " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_clean module subroutine prclib_driver_distclean (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace if (driver%makefile_exists ()) then call os_system_call ( & workspace_cmd (workspace) & // "make distclean " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_distclean @ %def prclib_driver_clean_library @ %def prclib_driver_clean_objects @ %def prclib_driver_clean_source @ %def prclib_driver_clean_driver @ %def prclib_driver_clean_makefile @ %def prclib_driver_clean @ %def prclib_driver_distclean @ This Make target should remove all files that apply to a specific process. We execute this when we want to force remaking source code. Note that source targets need not have prerequisites, so just calling [[make_source]] would not do anything if the files exist. <>= procedure :: clean_proc => prclib_driver_clean_proc <>= module subroutine prclib_driver_clean_proc (driver, i, os_data, workspace) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_clean_proc <>= module subroutine prclib_driver_clean_proc (driver, i, os_data, workspace) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace type(string_t) :: id if (driver%makefile_exists ()) then id = driver%record(i)%id call os_system_call ( & workspace_cmd (workspace) & // "make clean-" // driver%record(i)%id // " " & // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_clean_proc @ %def prclib_driver_clean_proc @ \subsection{Further Tools} Check for the appropriate makefile. <>= procedure :: makefile_exists => prclib_driver_makefile_exists <>= module function prclib_driver_makefile_exists (driver, workspace) result (flag) class(prclib_driver_t), intent(in) :: driver type(string_t), intent(in), optional :: workspace logical :: flag end function prclib_driver_makefile_exists <>= module function prclib_driver_makefile_exists (driver, workspace) result (flag) class(prclib_driver_t), intent(in) :: driver type(string_t), intent(in), optional :: workspace logical :: flag inquire (file = char (workspace_prefix (workspace) & & // driver%basename) // ".makefile", & exist = flag) end function prclib_driver_makefile_exists @ %def prclib_driver_makefile_exists @ \subsection{Load the library} Once the library has been linked, we can dlopen it and assign all procedure pointers to their proper places in the library driver object. The [[loaded]] flag is set only if all required pointers have become assigned. <>= procedure :: load => prclib_driver_load <>= module subroutine prclib_driver_load (driver, os_data, noerror, workspace) class(prclib_driver_t), intent(inout) :: driver type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: noerror type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_load <>= module subroutine prclib_driver_load (driver, os_data, noerror, workspace) class(prclib_driver_t), intent(inout) :: driver type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: noerror type(string_t), intent(in), optional :: workspace type(c_funptr) :: c_fptr logical :: ignore ignore = .false.; if (present (noerror)) ignore = noerror driver%libname = os_get_dlname ( & workspace_prefix (workspace) // driver%basename, & os_data, noerror, noerror) if (driver%libname == "") return select type (driver) type is (prclib_driver_dynamic_t) if (.not. dlaccess_is_open (driver%dlaccess)) then call dlaccess_init & (driver%dlaccess, workspace_path (workspace), & driver%libname, os_data) if (.not. ignore) call driver%check_dlerror () end if driver%loaded = dlaccess_is_open (driver%dlaccess) class default driver%loaded = .true. end select if (.not. driver%loaded) return c_fptr = driver%get_c_funptr (var_str ("get_n_processes")) call c_f_procpointer (c_fptr, driver%get_n_processes) driver%loaded = driver%loaded .and. associated (driver%get_n_processes) c_fptr = driver%get_c_funptr (var_str ("get_process_id_ptr")) call c_f_procpointer (c_fptr, driver%get_process_id_ptr) driver%loaded = driver%loaded .and. associated (driver%get_process_id_ptr) c_fptr = driver%get_c_funptr (var_str ("get_model_name_ptr")) call c_f_procpointer (c_fptr, driver%get_model_name_ptr) driver%loaded = driver%loaded .and. associated (driver%get_model_name_ptr) c_fptr = driver%get_c_funptr (var_str ("get_md5sum_ptr")) call c_f_procpointer (c_fptr, driver%get_md5sum_ptr) driver%loaded = driver%loaded .and. associated (driver%get_md5sum_ptr) c_fptr = driver%get_c_funptr (var_str ("get_openmp_status")) call c_f_procpointer (c_fptr, driver%get_openmp_status) driver%loaded = driver%loaded .and. associated (driver%get_openmp_status) c_fptr = driver%get_c_funptr (var_str ("get_n_in")) call c_f_procpointer (c_fptr, driver%get_n_in) driver%loaded = driver%loaded .and. associated (driver%get_n_in) c_fptr = driver%get_c_funptr (var_str ("get_n_out")) call c_f_procpointer (c_fptr, driver%get_n_out) driver%loaded = driver%loaded .and. associated (driver%get_n_out) c_fptr = driver%get_c_funptr (var_str ("get_n_flv")) call c_f_procpointer (c_fptr, driver%get_n_flv) driver%loaded = driver%loaded .and. associated (driver%get_n_flv) c_fptr = driver%get_c_funptr (var_str ("get_n_hel")) call c_f_procpointer (c_fptr, driver%get_n_hel) driver%loaded = driver%loaded .and. associated (driver%get_n_hel) c_fptr = driver%get_c_funptr (var_str ("get_n_col")) call c_f_procpointer (c_fptr, driver%get_n_col) driver%loaded = driver%loaded .and. associated (driver%get_n_col) c_fptr = driver%get_c_funptr (var_str ("get_n_cin")) call c_f_procpointer (c_fptr, driver%get_n_cin) driver%loaded = driver%loaded .and. associated (driver%get_n_cin) c_fptr = driver%get_c_funptr (var_str ("get_n_cf")) call c_f_procpointer (c_fptr, driver%get_n_cf) driver%loaded = driver%loaded .and. associated (driver%get_n_cf) c_fptr = driver%get_c_funptr (var_str ("set_flv_state_ptr")) call c_f_procpointer (c_fptr, driver%set_flv_state_ptr) driver%loaded = driver%loaded .and. associated (driver%set_flv_state_ptr) c_fptr = driver%get_c_funptr (var_str ("set_hel_state_ptr")) call c_f_procpointer (c_fptr, driver%set_hel_state_ptr) driver%loaded = driver%loaded .and. associated (driver%set_hel_state_ptr) c_fptr = driver%get_c_funptr (var_str ("set_col_state_ptr")) call c_f_procpointer (c_fptr, driver%set_col_state_ptr) driver%loaded = driver%loaded .and. associated (driver%set_col_state_ptr) c_fptr = driver%get_c_funptr (var_str ("set_color_factors_ptr")) call c_f_procpointer (c_fptr, driver%set_color_factors_ptr) driver%loaded = driver%loaded .and. associated (driver%set_color_factors_ptr) c_fptr = driver%get_c_funptr (var_str ("get_fptr")) call c_f_procpointer (c_fptr, driver%get_fptr) driver%loaded = driver%loaded .and. associated (driver%get_fptr) end subroutine prclib_driver_load @ %def prclib_driver_load @ Unload. To be sure, nullify the procedure pointers. <>= procedure :: unload => prclib_driver_unload <>= module subroutine prclib_driver_unload (driver) class(prclib_driver_t), intent(inout) :: driver end subroutine prclib_driver_unload <>= module subroutine prclib_driver_unload (driver) class(prclib_driver_t), intent(inout) :: driver select type (driver) type is (prclib_driver_dynamic_t) if (dlaccess_is_open (driver%dlaccess)) then call dlaccess_final (driver%dlaccess) call driver%check_dlerror () end if end select driver%loaded = .false. nullify (driver%get_n_processes) nullify (driver%get_process_id_ptr) nullify (driver%get_model_name_ptr) nullify (driver%get_md5sum_ptr) nullify (driver%get_openmp_status) nullify (driver%get_n_in) nullify (driver%get_n_out) nullify (driver%get_n_flv) nullify (driver%get_n_hel) nullify (driver%get_n_col) nullify (driver%get_n_cin) nullify (driver%get_n_cf) nullify (driver%set_flv_state_ptr) nullify (driver%set_hel_state_ptr) nullify (driver%set_col_state_ptr) nullify (driver%set_color_factors_ptr) nullify (driver%get_fptr) end subroutine prclib_driver_unload @ %def prclib_driver_unload @ This subroutine checks the [[dlerror]] content and issues a fatal error if it finds an error there. <>= procedure :: check_dlerror => prclib_driver_check_dlerror <>= module subroutine prclib_driver_check_dlerror (driver) class(prclib_driver_dynamic_t), intent(in) :: driver end subroutine prclib_driver_check_dlerror <>= module subroutine prclib_driver_check_dlerror (driver) class(prclib_driver_dynamic_t), intent(in) :: driver if (dlaccess_has_error (driver%dlaccess)) then call msg_fatal (char (dlaccess_get_error (driver%dlaccess))) end if end subroutine prclib_driver_check_dlerror @ %def prclib_driver_check_dlerror @ Get the handle (C function pointer) for a given ``feature'' of the matrix element code, so it can be assigned to the appropriate procedure pointer slot. In the static case, this is a trivial pointer assignment, hard-coded into the driver type implementation. <>= procedure (prclib_driver_get_c_funptr), deferred :: get_c_funptr <>= abstract interface function prclib_driver_get_c_funptr (driver, feature) result (c_fptr) import class(prclib_driver_t), intent(inout) :: driver type(string_t), intent(in) :: feature type(c_funptr) :: c_fptr end function prclib_driver_get_c_funptr end interface @ %def prclib_driver_get_c_funptr @ In the dynamic-library case, we call the DL interface to retrieve the C pointer to a named procedure. <>= procedure :: get_c_funptr => prclib_driver_dynamic_get_c_funptr <>= module function prclib_driver_dynamic_get_c_funptr & (driver, feature) result (c_fptr) class(prclib_driver_dynamic_t), intent(inout) :: driver type(string_t), intent(in) :: feature type(c_funptr) :: c_fptr end function prclib_driver_dynamic_get_c_funptr <>= module function prclib_driver_dynamic_get_c_funptr & (driver, feature) result (c_fptr) class(prclib_driver_dynamic_t), intent(inout) :: driver type(string_t), intent(in) :: feature type(c_funptr) :: c_fptr type(string_t) :: prefix, full_name prefix = lower_case (driver%basename) // "_" full_name = prefix // feature c_fptr = dlaccess_get_c_funptr (driver%dlaccess, full_name) call driver%check_dlerror () end function prclib_driver_dynamic_get_c_funptr @ %def prclib_driver_get_c_funptr @ \subsection{MD5 sums} Recall the MD5 sum written in the Makefile <>= procedure :: get_md5sum_makefile => prclib_driver_get_md5sum_makefile <>= module function prclib_driver_get_md5sum_makefile & (driver, workspace) result (md5sum) class(prclib_driver_t), intent(in) :: driver type(string_t), intent(in), optional :: workspace character(32) :: md5sum end function prclib_driver_get_md5sum_makefile <>= module function prclib_driver_get_md5sum_makefile & (driver, workspace) result (md5sum) class(prclib_driver_t), intent(in) :: driver type(string_t), intent(in), optional :: workspace character(32) :: md5sum type(string_t) :: filename character(80) :: buffer logical :: exist integer :: u, iostat md5sum = "" filename = workspace_prefix (workspace) // driver%basename // ".makefile" inquire (file = char (filename), exist = exist) if (exist) then u = free_unit () open (u, file = char (filename), action = "read", status = "old") iostat = 0 do read (u, "(A)", iostat = iostat) buffer if (iostat /= 0) exit buffer = adjustl (buffer) select case (buffer(1:9)) case ("MD5SUM = ") read (buffer(11:), "(A32)") md5sum exit end select end do close (u) end if end function prclib_driver_get_md5sum_makefile @ %def prclib_driver_get_md5sum_makefile @ Recall the MD5 sum written in the driver source code. <>= procedure :: get_md5sum_driver => prclib_driver_get_md5sum_driver <>= module function prclib_driver_get_md5sum_driver (driver, workspace) result (md5sum) class(prclib_driver_t), intent(in) :: driver type(string_t), intent(in), optional :: workspace character(32) :: md5sum end function prclib_driver_get_md5sum_driver <>= module function prclib_driver_get_md5sum_driver (driver, workspace) result (md5sum) class(prclib_driver_t), intent(in) :: driver type(string_t), intent(in), optional :: workspace character(32) :: md5sum type(string_t) :: filename character(80) :: buffer logical :: exist integer :: u, iostat md5sum = "" filename = workspace_prefix (workspace) // driver%basename // ".f90" inquire (file = char (filename), exist = exist) if (exist) then u = free_unit () open (u, file = char (filename), action = "read", status = "old") iostat = 0 do read (u, "(A)", iostat = iostat) buffer if (iostat /= 0) exit buffer = adjustl (buffer) select case (buffer(1:9)) case ("md5sum = ") read (buffer(11:), "(A32)") md5sum exit end select end do close (u) end if end function prclib_driver_get_md5sum_driver @ %def prclib_driver_get_md5sum_driver @ Recall the MD5 sum written in the matrix element source code. <>= procedure :: get_md5sum_source => prclib_driver_get_md5sum_source <>= module function prclib_driver_get_md5sum_source & (driver, i, workspace) result (md5sum) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i type(string_t), intent(in), optional :: workspace character(32) :: md5sum end function prclib_driver_get_md5sum_source <>= module function prclib_driver_get_md5sum_source & (driver, i, workspace) result (md5sum) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i type(string_t), intent(in), optional :: workspace character(32) :: md5sum type(string_t) :: filename character(80) :: buffer logical :: exist integer :: u, iostat md5sum = "" filename = workspace_prefix (workspace) // driver%record(i)%id // ".f90" inquire (file = char (filename), exist = exist) if (exist) then u = free_unit () open (u, file = char (filename), action = "read", status = "old") iostat = 0 do read (u, "(A)", iostat = iostat) buffer if (iostat /= 0) exit buffer = adjustl (buffer) select case (buffer(1:9)) case ("md5sum = ") read (buffer(11:), "(A32)") md5sum exit end select end do close (u) end if end function prclib_driver_get_md5sum_source @ %def prclib_driver_get_md5sum_source @ \subsection{Unit Test} Test module, followed by the corresponding implementation module. <<[[prclib_interfaces_ut.f90]]>>= <> module prclib_interfaces_ut use kinds use system_dependencies, only: CC_IS_GNU, CC_HAS_QUADMATH use unit_tests use prclib_interfaces_uti <> <> <> contains <> end module prclib_interfaces_ut @ %def prclib_interfaces_ut @ <<[[prclib_interfaces_uti.f90]]>>= <> module prclib_interfaces_uti use, intrinsic :: iso_c_binding !NODEP! use kinds use system_dependencies, only: CC_HAS_QUADMATH, DEFAULT_FC_PRECISION <> use io_units use system_defs, only: TAB use os_interface use prclib_interfaces <> <> <> <> contains <> <> end module prclib_interfaces_uti @ %def prclib_interfaces_ut @ API: driver for the unit tests below. <>= public :: prclib_interfaces_test <>= subroutine prclib_interfaces_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine prclib_interfaces_test @ %def prclib_interfaces_test @ \subsubsection{Empty process list} Test 1: Create a driver object and display its contents. One of the feature lists references a writer procedure; this is just a dummy that does nothing useful. <>= call test (prclib_interfaces_1, "prclib_interfaces_1", & "create driver object", & u, results) <>= public :: prclib_interfaces_1 <>= subroutine prclib_interfaces_1 (u) integer, intent(in) :: u class(prclib_driver_t), allocatable :: driver character(32), parameter :: md5sum = "prclib_interfaces_1_md5sum " class(prc_writer_t), pointer :: test_writer_1 write (u, "(A)") "* Test output: prclib_interfaces_1" write (u, "(A)") "* Purpose: display the driver object contents" write (u, *) write (u, "(A)") "* Create a prclib driver object" write (u, "(A)") call dispatch_prclib_driver (driver, var_str ("prclib"), var_str ("")) call driver%init (3) call driver%set_md5sum (md5sum) allocate (test_writer_1_t :: test_writer_1) call driver%set_record (1, var_str ("test1"), var_str ("test_model"), & [var_str ("init")], test_writer_1) call driver%set_record (2, var_str ("test2"), var_str ("foo_model"), & [var_str ("another_proc")], test_writer_1) call driver%set_record (3, var_str ("test3"), var_str ("test_model"), & [var_str ("init"), var_str ("some_proc")], test_writer_1) call driver%write (u) deallocate (test_writer_1) write (u, "(A)") write (u, "(A)") "* Test output end: prclib_interfaces_1" end subroutine prclib_interfaces_1 @ %def prclib_interfaces_1 @ The writer: the procedures write just comment lines. We can fix an instance of this as a parameter (since it has no mutable content) and just reference the fixed parameter. NOTE: temporarily made public. <>= type, extends (prc_writer_t) :: test_writer_1_t contains procedure, nopass :: type_name => test_writer_1_type_name procedure :: write_makefile_code => test_writer_1_mk procedure :: write_source_code => test_writer_1_src procedure :: write_interface => test_writer_1_if procedure :: write_md5sum_call => test_writer_1_md5sum procedure :: write_int_sub_call => test_writer_1_int_sub procedure :: write_col_state_call => test_writer_1_col_state procedure :: write_color_factors_call => test_writer_1_col_factors procedure :: before_compile => test_writer_1_before_compile procedure :: after_compile => test_writer_1_after_compile end type test_writer_1_t @ %def test_writer_1 @ <>= function test_writer_1_type_name () result (string) type(string_t) :: string string = "test_1" end function test_writer_1_type_name subroutine test_writer_1_mk & (writer, unit, id, os_data, verbose, testflag) class(test_writer_1_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag write (unit, "(5A)") "# Makefile code for process ", char (id), & " goes here." end subroutine test_writer_1_mk subroutine test_writer_1_src (writer, id) class(test_writer_1_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_1_src subroutine test_writer_1_if (writer, unit, id, feature) class(test_writer_1_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, "(2x,9A)") "! Interface code for ", & char (id), "_", char (writer%get_procname (feature)), & " goes here." end subroutine test_writer_1_if subroutine test_writer_1_md5sum (writer, unit, id) class(test_writer_1_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(5x,9A)") "! MD5sum call for ", char (id), " goes here." end subroutine test_writer_1_md5sum subroutine test_writer_1_int_sub (writer, unit, id, feature) class(test_writer_1_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, "(5x,9A)") "! ", char (feature), " call for ", & char (id), " goes here." end subroutine test_writer_1_int_sub subroutine test_writer_1_col_state (writer, unit, id) class(test_writer_1_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(5x,9A)") "! col_state call for ", & char (id), " goes here." end subroutine test_writer_1_col_state subroutine test_writer_1_col_factors (writer, unit, id) class(test_writer_1_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(5x,9A)") "! color_factors call for ", & char (id), " goes here." end subroutine test_writer_1_col_factors subroutine test_writer_1_before_compile (writer, id) class(test_writer_1_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_1_before_compile subroutine test_writer_1_after_compile (writer, id) class(test_writer_1_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_1_after_compile @ %def test_writer_1_type_name @ %def test_writer_1_mk test_writer_1_if @ %def test_writer_1_md5sum test_writer_1_int_sub @ %def test_writer_1_col_state test_writer_1_col_factors @ %def test_writer_1_before_compile test_writer_1_after_compile @ \subsubsection{Process library driver file} Test 2: Write the driver file for a test case with two processes. The first process needs no wrapper (C library), the second one needs wrappers (Fortran module library). <>= call test (prclib_interfaces_2, "prclib_interfaces_2", & "write driver file", & u, results) <>= public :: prclib_interfaces_2 <>= subroutine prclib_interfaces_2 (u) integer, intent(in) :: u class(prclib_driver_t), allocatable :: driver character(32), parameter :: md5sum = "prclib_interfaces_2_md5sum " class(prc_writer_t), pointer :: test_writer_1, test_writer_2 write (u, "(A)") "* Test output: prclib_interfaces_2" write (u, "(A)") "* Purpose: check the generated driver source code" write (u, "(A)") write (u, "(A)") "* Create a prclib driver object (2 processes)" write (u, "(A)") call dispatch_prclib_driver (driver, var_str ("prclib2"), var_str ("")) call driver%init (2) call driver%set_md5sum (md5sum) allocate (test_writer_1_t :: test_writer_1) allocate (test_writer_2_t :: test_writer_2) call driver%set_record (1, var_str ("test1"), var_str ("Test_model"), & [var_str ("proc1")], test_writer_1) call driver%set_record (2, var_str ("test2"), var_str ("Test_model"), & [var_str ("proc1"), var_str ("proc2")], test_writer_2) call driver%write (u) write (u, "(A)") write (u, "(A)") "* Write the driver file" write (u, "(A)") "* File contents:" write (u, "(A)") call driver%generate_driver_code (u) deallocate (test_writer_1) deallocate (test_writer_2) write (u, "(A)") write (u, "(A)") "* Test output end: prclib_interfaces_2" end subroutine prclib_interfaces_2 @ %def prclib_interfaces_2 @ A writer with wrapper code: the procedures again write just comment lines. Since all procedures are NOPASS, we can reuse two of the TBP. <>= type, extends (prc_writer_f_module_t) :: test_writer_2_t contains procedure, nopass :: type_name => test_writer_2_type_name procedure :: write_makefile_code => test_writer_2_mk procedure :: write_source_code => test_writer_2_src procedure :: write_interface => test_writer_2_if procedure :: write_wrapper => test_writer_2_wr procedure :: before_compile => test_writer_2_before_compile procedure :: after_compile => test_writer_2_after_compile end type test_writer_2_t @ %def test_writer_2 @ <>= function test_writer_2_type_name () result (string) type(string_t) :: string string = "test_2" end function test_writer_2_type_name subroutine test_writer_2_mk & (writer, unit, id, os_data, verbose, testflag) class(test_writer_2_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag write (unit, "(5A)") "# Makefile code for process ", char (id), & " goes here." end subroutine test_writer_2_mk subroutine test_writer_2_src (writer, id) class(test_writer_2_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_2_src subroutine test_writer_2_if (writer, unit, id, feature) class(test_writer_2_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, "(2x,9A)") "! Interface code for ", & char (writer%get_module_name (id)), "_", & char (writer%get_procname (feature)), " goes here." end subroutine test_writer_2_if subroutine test_writer_2_wr (writer, unit, id, feature) class(test_writer_2_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, *) write (unit, "(9A)") "! Wrapper code for ", & char (writer%get_c_procname (id, feature)), " goes here." end subroutine test_writer_2_wr subroutine test_writer_2_before_compile (writer, id) class(test_writer_2_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_2_before_compile subroutine test_writer_2_after_compile (writer, id) class(test_writer_2_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_2_after_compile @ %def test_writer_2_type_name test_writer_2_wr @ %def test_writer_2_before_compile test_writer_2_after_compile @ \subsubsection{Process library makefile} Test 3: Write the makefile for compiling and linking the process library (processes and driver code). There are two processes, one with one method, one with two methods. To have predictable output, we reset the system-dependent initial components of [[os_data]] to known values. <>= call test (prclib_interfaces_3, "prclib_interfaces_3", & "write makefile", & u, results) <>= public :: prclib_interfaces_3 <>= subroutine prclib_interfaces_3 (u) integer, intent(in) :: u class(prclib_driver_t), allocatable :: driver type(os_data_t) :: os_data character(32), parameter :: md5sum = "prclib_interfaces_3_md5sum " class(prc_writer_t), pointer :: test_writer_1, test_writer_2 call os_data%init () os_data%fc = "fortran-compiler" os_data%whizard_includes = "-I module-dir" os_data%fcflags = "-C=all" os_data%fcflags_pic = "-PIC" os_data%cc = "c-compiler" os_data%cflags = "-I include-dir" os_data%cflags_pic = "-PIC" os_data%whizard_ldflags = "" os_data%ldflags = "" os_data%whizard_libtool = "my-libtool" os_data%latex = "latex -halt-on-error" os_data%mpost = "mpost --math=scaled -halt-on-error" os_data%dvips = "dvips" os_data%ps2pdf = "ps2pdf14" os_data%whizard_texpath = "" write (u, "(A)") "* Test output: prclib_interfaces_3" write (u, "(A)") "* Purpose: check the generated Makefile" write (u, *) write (u, "(A)") "* Create a prclib driver object (2 processes)" write (u, "(A)") call dispatch_prclib_driver (driver, var_str ("prclib3"), var_str ("")) call driver%init (2) call driver%set_md5sum (md5sum) allocate (test_writer_1_t :: test_writer_1) allocate (test_writer_2_t :: test_writer_2) call driver%set_record (1, var_str ("test1"), var_str ("Test_model"), & [var_str ("proc1")], test_writer_1) call driver%set_record (2, var_str ("test2"), var_str ("Test_model"), & [var_str ("proc1"), var_str ("proc2")], test_writer_2) call driver%write (u) write (u, "(A)") write (u, "(A)") "* Write Makefile" write (u, "(A)") "* File contents:" write (u, "(A)") call driver%generate_makefile (u, os_data, verbose = .true.) deallocate (test_writer_1) deallocate (test_writer_2) write (u, "(A)") write (u, "(A)") "* Test output end: prclib_interfaces_3" end subroutine prclib_interfaces_3 @ %def prclib_interfaces_3 @ \subsubsection{Compile test with Fortran module} Test 4: Write driver and makefile and try to compile and link the library driver. There is a single test process with a single feature. The process code is provided as a Fortran module, therefore we need a wrapper for the featured procedure. <>= call test (prclib_interfaces_4, "prclib_interfaces_4", & "compile and link (Fortran module)", & u, results) <>= public :: prclib_interfaces_4 <>= subroutine prclib_interfaces_4 (u) integer, intent(in) :: u class(prclib_driver_t), allocatable :: driver class(prc_writer_t), pointer :: test_writer_4 type(os_data_t) :: os_data integer :: u_file integer, dimension(:,:), allocatable :: flv_state integer, dimension(:,:), allocatable :: hel_state integer, dimension(:,:,:), allocatable :: col_state logical, dimension(:,:), allocatable :: ghost_flag integer, dimension(:,:), allocatable :: cf_index complex(default), dimension(:), allocatable :: color_factors character(32), parameter :: md5sum = "prclib_interfaces_4_md5sum " character(32) :: md5sum_file type(c_funptr) :: proc1_ptr interface subroutine proc1_t (n) bind(C) import integer(c_int), intent(out) :: n end subroutine proc1_t end interface procedure(proc1_t), pointer :: proc1 integer(c_int) :: n write (u, "(A)") "* Test output: prclib_interfaces_4" write (u, "(A)") "* Purpose: compile, link, and load process library" write (u, "(A)") "* with (fake) matrix-element code & &as a Fortran module" write (u, *) write (u, "(A)") "* Create a prclib driver object (1 process)" write (u, "(A)") call os_data%init () allocate (test_writer_4_t :: test_writer_4) call test_writer_4%init_test () call dispatch_prclib_driver (driver, var_str ("prclib4"), var_str ("")) call driver%init (1) call driver%set_md5sum (md5sum) call driver%set_record (1, var_str ("test4"), var_str ("Test_model"), & [var_str ("proc1")], test_writer_4) call driver%write (u) write (u, *) write (u, "(A)") "* Write Makefile" u_file = free_unit () open (u_file, file="prclib4.makefile", status="replace", action="write") call driver%generate_makefile (u_file, os_data, verbose = .false.) close (u_file) write (u, "(A)") write (u, "(A)") "* Recall MD5 sum from Makefile" write (u, "(A)") md5sum_file = driver%get_md5sum_makefile () write (u, "(1x,A,A,A)") "MD5 sum = '", md5sum_file, "'" write (u, "(A)") write (u, "(A)") "* Write driver source code" u_file = free_unit () open (u_file, file="prclib4.f90", status="replace", action="write") call driver%generate_driver_code (u_file) close (u_file) write (u, "(A)") write (u, "(A)") "* Recall MD5 sum from driver source" write (u, "(A)") md5sum_file = driver%get_md5sum_driver () write (u, "(1x,A,A,A)") "MD5 sum = '", md5sum_file, "'" write (u, "(A)") write (u, "(A)") "* Write matrix-element source code" call driver%make_source (os_data) write (u, "(A)") write (u, "(A)") "* Recall MD5 sum from matrix-element source" write (u, "(A)") md5sum_file = driver%get_md5sum_source (1) write (u, "(1x,A,A,A)") "MD5 sum = '", md5sum_file, "'" write (u, "(A)") write (u, "(A)") "* Compile source code" call driver%make_compile (os_data) write (u, "(A)") "* Link library" call driver%make_link (os_data) write (u, "(A)") "* Load library" call driver%load (os_data) write (u, *) call driver%write (u) write (u, *) if (driver%loaded) then write (u, "(A)") "* Call library functions:" write (u, *) write (u, "(1x,A,I0)") "n_processes = ", driver%get_n_processes () write (u, "(1x,A,A,A)") "process_id = '", & char (driver%get_process_id (1)), "'" write (u, "(1x,A,A,A)") "model_name = '", & char (driver%get_model_name (1)), "'" write (u, "(1x,A,A,A)") "md5sum (lib) = '", & char (driver%get_md5sum (0)), "'" write (u, "(1x,A,A,A)") "md5sum (proc) = '", & char (driver%get_md5sum (1)), "'" write (u, "(1x,A,L1)") "openmp_status = ", driver%get_openmp_status (1) write (u, "(1x,A,I0)") "n_in = ", driver%get_n_in (1) write (u, "(1x,A,I0)") "n_out = ", driver%get_n_out (1) write (u, "(1x,A,I0)") "n_flv = ", driver%get_n_flv (1) write (u, "(1x,A,I0)") "n_hel = ", driver%get_n_hel (1) write (u, "(1x,A,I0)") "n_col = ", driver%get_n_col (1) write (u, "(1x,A,I0)") "n_cin = ", driver%get_n_cin (1) write (u, "(1x,A,I0)") "n_cf = ", driver%get_n_cf (1) call driver%set_flv_state (1, flv_state) write (u, "(1x,A,10(1x,I0))") "flv_state =", flv_state call driver%set_hel_state (1, hel_state) write (u, "(1x,A,10(1x,I0))") "hel_state =", hel_state call driver%set_col_state (1, col_state, ghost_flag) write (u, "(1x,A,10(1x,I0))") "col_state =", col_state write (u, "(1x,A,10(1x,L1))") "ghost_flag =", ghost_flag call driver%set_color_factors (1, color_factors, cf_index) write (u, "(1x,A,10(1x,F5.3))") "color_factors =", color_factors write (u, "(1x,A,10(1x,I0))") "cf_index =", cf_index call driver%get_fptr (1, 1, proc1_ptr) call c_f_procpointer (proc1_ptr, proc1) if (associated (proc1)) then write (u, *) call proc1 (n) write (u, "(1x,A,I0)") "proc1(1) = ", n end if end if deallocate (test_writer_4) write (u, "(A)") write (u, "(A)") "* Test output end: prclib_interfaces_4" end subroutine prclib_interfaces_4 @ %def prclib_interfaces_4 @ This version of test-code writer actually writes an interface and wrapper code. The wrapped function is a no-parameter function with integer result. The stored MD5 sum may be modified. We will reuse this later, therefore public. <>= public :: test_writer_4_t <>= type, extends (prc_writer_f_module_t) :: test_writer_4_t contains procedure, nopass :: type_name => test_writer_4_type_name procedure, nopass :: get_module_name => & test_writer_4_get_module_name procedure :: write_makefile_code => test_writer_4_mk procedure :: write_source_code => test_writer_4_src procedure :: write_interface => test_writer_4_if procedure :: write_wrapper => test_writer_4_wr procedure :: before_compile => test_writer_4_before_compile procedure :: after_compile => test_writer_4_after_compile end type test_writer_4_t @ %def test_writer_4 @ <>= function test_writer_4_type_name () result (string) type(string_t) :: string string = "test_4" end function test_writer_4_type_name function test_writer_4_get_module_name (id) result (name) type(string_t), intent(in) :: id type(string_t) :: name name = "tpr_" // id end function test_writer_4_get_module_name subroutine test_writer_4_mk & (writer, unit, id, os_data, verbose, testflag) class(test_writer_4_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag write (unit, "(5A)") "SOURCES += ", char (id), ".f90" write (unit, "(5A)") "OBJECTS += ", char (id), ".lo" write (unit, "(5A)") "CLEAN_SOURCES += ", char (id), ".f90" write (unit, "(5A)") "CLEAN_OBJECTS += tpr_", char (id), ".mod" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (id), ".lo" write (unit, "(5A)") char (id), ".lo: ", char (id), ".f90" if (.not. verbose) then write (unit, "(5A)") TAB // '@echo " FC " $@' end if write (unit, "(5A)") TAB, "$(LTFCOMPILE) $<" end subroutine test_writer_4_mk subroutine test_writer_4_src (writer, id) class(test_writer_4_t), intent(in) :: writer type(string_t), intent(in) :: id call write_test_module_file (id, var_str ("proc1"), writer%md5sum) end subroutine test_writer_4_src subroutine test_writer_4_if (writer, unit, id, feature) class(test_writer_4_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "subroutine ", & char (writer%get_c_procname (id, feature)), & " (n) bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "integer(c_int), intent(out) :: n" write (unit, "(5x,9A)") "end subroutine ", & char (writer%get_c_procname (id, feature)) write (unit, "(2x,9A)") "end interface" end subroutine test_writer_4_if subroutine test_writer_4_wr (writer, unit, id, feature) class(test_writer_4_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, *) write (unit, "(9A)") "subroutine ", & char (writer%get_c_procname (id, feature)), & " (n) bind(C)" write (unit, "(2x,9A)") "use iso_c_binding" write (unit, "(2x,9A)") "use tpr_", char (id), ", only: ", & char (writer%get_procname (feature)) write (unit, "(2x,9A)") "implicit none" write (unit, "(2x,9A)") "integer(c_int), intent(out) :: n" write (unit, "(2x,9A)") "call ", char (feature), " (n)" write (unit, "(9A)") "end subroutine ", & char (writer%get_c_procname (id, feature)) end subroutine test_writer_4_wr subroutine test_writer_4_before_compile (writer, id) class(test_writer_4_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_4_before_compile subroutine test_writer_4_after_compile (writer, id) class(test_writer_4_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_4_after_compile @ %def test_writer_2_type_name test_writer_4_wr @ %def test_writer_4_before_compile test_writer_4_after_compile @ We need a test module file (actually, one for each process in the test above) that allows us to check compilation and linking. The test module implements a colorless $1\to 2$ process, and it implements one additional function (feature), the name given as an argument. <>= subroutine write_test_module_file (basename, feature, md5sum) type(string_t), intent(in) :: basename type(string_t), intent(in) :: feature character(32), intent(in) :: md5sum integer :: u u = free_unit () open (u, file = char (basename) // ".f90", & status = "replace", action = "write") write (u, "(A)") "! (Pseudo) matrix element code file & &for WHIZARD self-test" write (u, *) write (u, "(A)") "module tpr_" // char (basename) write (u, *) write (u, "(2x,A)") "use kinds" write (u, "(2x,A)") "use omega_color, OCF => omega_color_factor" write (u, *) write (u, "(2x,A)") "implicit none" write (u, "(2x,A)") "private" write (u, *) call write_test_me_code_1 (u) write (u, *) write (u, "(2x,A)") "public :: " // char (feature) write (u, *) write (u, "(A)") "contains" write (u, *) call write_test_me_code_2 (u, md5sum) write (u, *) write (u, "(2x,A)") "subroutine " // char (feature) // " (n)" write (u, "(2x,A)") " integer, intent(out) :: n" write (u, "(2x,A)") " n = 42" write (u, "(2x,A)") "end subroutine " // char (feature) write (u, *) write (u, "(A)") "end module tpr_" // char (basename) close (u) end subroutine write_test_module_file @ %def write_test_module_file @ The following two subroutines provide building blocks for a matrix-element source code file, useful only for testing the workflow. The first routine writes the header part, the other routine the implementation of the procedures listed in the header. <>= subroutine write_test_me_code_1 (u) integer, intent(in) :: u write (u, "(2x,A)") "public :: md5sum" write (u, "(2x,A)") "public :: openmp_supported" write (u, *) write (u, "(2x,A)") "public :: n_in" write (u, "(2x,A)") "public :: n_out" write (u, "(2x,A)") "public :: n_flv" write (u, "(2x,A)") "public :: n_hel" write (u, "(2x,A)") "public :: n_cin" write (u, "(2x,A)") "public :: n_col" write (u, "(2x,A)") "public :: n_cf" write (u, *) write (u, "(2x,A)") "public :: flv_state" write (u, "(2x,A)") "public :: hel_state" write (u, "(2x,A)") "public :: col_state" write (u, "(2x,A)") "public :: color_factors" end subroutine write_test_me_code_1 subroutine write_test_me_code_2 (u, md5sum) integer, intent(in) :: u character(32), intent(in) :: md5sum write (u, "(2x,A)") "pure function md5sum ()" write (u, "(2x,A)") " character(len=32) :: md5sum" write (u, "(2x,A)") " md5sum = '" // md5sum // "'" write (u, "(2x,A)") "end function md5sum" write (u, *) write (u, "(2x,A)") "pure function openmp_supported () result (status)" write (u, "(2x,A)") " logical :: status" write (u, "(2x,A)") " status = .false." write (u, "(2x,A)") "end function openmp_supported" write (u, *) write (u, "(2x,A)") "pure function n_in () result (n)" write (u, "(2x,A)") " integer :: n" write (u, "(2x,A)") " n = 1" write (u, "(2x,A)") "end function n_in" write (u, *) write (u, "(2x,A)") "pure function n_out () result (n)" write (u, "(2x,A)") " integer :: n" write (u, "(2x,A)") " n = 2" write (u, "(2x,A)") "end function n_out" write (u, *) write (u, "(2x,A)") "pure function n_flv () result (n)" write (u, "(2x,A)") " integer :: n" write (u, "(2x,A)") " n = 1" write (u, "(2x,A)") "end function n_flv" write (u, *) write (u, "(2x,A)") "pure function n_hel () result (n)" write (u, "(2x,A)") " integer :: n" write (u, "(2x,A)") " n = 1" write (u, "(2x,A)") "end function n_hel" write (u, *) write (u, "(2x,A)") "pure function n_cin () result (n)" write (u, "(2x,A)") " integer :: n" write (u, "(2x,A)") " n = 2" write (u, "(2x,A)") "end function n_cin" write (u, *) write (u, "(2x,A)") "pure function n_col () result (n)" write (u, "(2x,A)") " integer :: n" write (u, "(2x,A)") " n = 1" write (u, "(2x,A)") "end function n_col" write (u, *) write (u, "(2x,A)") "pure function n_cf () result (n)" write (u, "(2x,A)") " integer :: n" write (u, "(2x,A)") " n = 1" write (u, "(2x,A)") "end function n_cf" write (u, *) write (u, "(2x,A)") "pure subroutine flv_state (a)" write (u, "(2x,A)") " integer, dimension(:,:), intent(out) :: a" write (u, "(2x,A)") " a = reshape ([1,2,3], [3,1])" write (u, "(2x,A)") "end subroutine flv_state" write (u, *) write (u, "(2x,A)") "pure subroutine hel_state (a)" write (u, "(2x,A)") " integer, dimension(:,:), intent(out) :: a" write (u, "(2x,A)") " a = reshape ([0,0,0], [3,1])" write (u, "(2x,A)") "end subroutine hel_state" write (u, *) write (u, "(2x,A)") "pure subroutine col_state (a, g)" write (u, "(2x,A)") " integer, dimension(:,:,:), intent(out) :: a" write (u, "(2x,A)") " logical, dimension(:,:), intent(out) :: g" write (u, "(2x,A)") " a = reshape ([0,0, 0,0, 0,0], [2,3,1])" write (u, "(2x,A)") " g = reshape ([.false., .false., .false.], [3,1])" write (u, "(2x,A)") "end subroutine col_state" write (u, *) write (u, "(2x,A)") "pure subroutine color_factors (cf)" write (u, "(2x,A)") " type(OCF), dimension(:), intent(out) :: cf" write (u, "(2x,A)") " cf = [ OCF(1,1,+1._default) ]" write (u, "(2x,A)") "end subroutine color_factors" end subroutine write_test_me_code_2 @ %def write_test_me_code_1 write_test_me_code_2 @ \subsubsection{Compile test with Fortran bind(C) library} Test 5: Write driver and makefile and try to compile and link the library driver. There is a single test process with a single feature. The process code is provided as a Fortran library of independent procedures. These procedures are bind(C). <>= call test (prclib_interfaces_5, "prclib_interfaces_5", & "compile and link (Fortran library)", & u, results) <>= public :: prclib_interfaces_5 <>= subroutine prclib_interfaces_5 (u) integer, intent(in) :: u class(prclib_driver_t), allocatable :: driver class(prc_writer_t), pointer :: test_writer_5 type(os_data_t) :: os_data integer :: u_file integer, dimension(:,:), allocatable :: flv_state integer, dimension(:,:), allocatable :: hel_state integer, dimension(:,:,:), allocatable :: col_state logical, dimension(:,:), allocatable :: ghost_flag integer, dimension(:,:), allocatable :: cf_index complex(default), dimension(:), allocatable :: color_factors character(32), parameter :: md5sum = "prclib_interfaces_5_md5sum " type(c_funptr) :: proc1_ptr interface subroutine proc1_t (n) bind(C) import integer(c_int), intent(out) :: n end subroutine proc1_t end interface procedure(proc1_t), pointer :: proc1 integer(c_int) :: n write (u, "(A)") "* Test output: prclib_interfaces_5" write (u, "(A)") "* Purpose: compile, link, and load process library" write (u, "(A)") "* with (fake) matrix-element code & &as a Fortran bind(C) library" write (u, *) write (u, "(A)") "* Create a prclib driver object (1 process)" write (u, "(A)") call os_data%init () allocate (test_writer_5_t :: test_writer_5) call dispatch_prclib_driver (driver, var_str ("prclib5"), var_str ("")) call driver%init (1) call driver%set_md5sum (md5sum) call driver%set_record (1, var_str ("test5"), var_str ("Test_model"), & [var_str ("proc1")], test_writer_5) call driver%write (u) write (u, *) write (u, "(A)") "* Write makefile" u_file = free_unit () open (u_file, file="prclib5.makefile", status="replace", action="write") call driver%generate_makefile (u_file, os_data, verbose = .false.) close (u_file) write (u, "(A)") "* Write driver source code" u_file = free_unit () open (u_file, file="prclib5.f90", status="replace", action="write") call driver%generate_driver_code (u_file) close (u_file) write (u, "(A)") "* Write matrix-element source code" call driver%make_source (os_data) write (u, "(A)") "* Compile source code" call driver%make_compile (os_data) write (u, "(A)") "* Link library" call driver%make_link (os_data) write (u, "(A)") "* Load library" call driver%load (os_data) write (u, *) call driver%write (u) write (u, *) if (driver%loaded) then write (u, "(A)") "* Call library functions:" write (u, *) write (u, "(1x,A,I0)") "n_processes = ", driver%get_n_processes () write (u, "(1x,A,A)") "process_id = ", & char (driver%get_process_id (1)) write (u, "(1x,A,A)") "model_name = ", & char (driver%get_model_name (1)) write (u, "(1x,A,A)") "md5sum = ", & char (driver%get_md5sum (1)) write (u, "(1x,A,L1)") "openmp_status = ", driver%get_openmp_status (1) write (u, "(1x,A,I0)") "n_in = ", driver%get_n_in (1) write (u, "(1x,A,I0)") "n_out = ", driver%get_n_out (1) write (u, "(1x,A,I0)") "n_flv = ", driver%get_n_flv (1) write (u, "(1x,A,I0)") "n_hel = ", driver%get_n_hel (1) write (u, "(1x,A,I0)") "n_col = ", driver%get_n_col (1) write (u, "(1x,A,I0)") "n_cin = ", driver%get_n_cin (1) write (u, "(1x,A,I0)") "n_cf = ", driver%get_n_cf (1) call driver%set_flv_state (1, flv_state) write (u, "(1x,A,10(1x,I0))") "flv_state =", flv_state call driver%set_hel_state (1, hel_state) write (u, "(1x,A,10(1x,I0))") "hel_state =", hel_state call driver%set_col_state (1, col_state, ghost_flag) write (u, "(1x,A,10(1x,I0))") "col_state =", col_state write (u, "(1x,A,10(1x,L1))") "ghost_flag =", ghost_flag call driver%set_color_factors (1, color_factors, cf_index) write (u, "(1x,A,10(1x,F5.3))") "color_factors =", color_factors write (u, "(1x,A,10(1x,I0))") "cf_index =", cf_index call driver%get_fptr (1, 1, proc1_ptr) call c_f_procpointer (proc1_ptr, proc1) if (associated (proc1)) then write (u, *) call proc1 (n) write (u, "(1x,A,I0)") "proc1(1) = ", n end if end if deallocate (test_writer_5) write (u, "(A)") write (u, "(A)") "* Test output end: prclib_interfaces_5" end subroutine prclib_interfaces_5 @ %def prclib_interfaces_5 @ This version of test-code writer writes interfaces for all standard features plus one specific feature. The interfaces are all bind(C), so no wrapper is needed. <>= type, extends (prc_writer_c_lib_t) :: test_writer_5_t contains procedure, nopass :: type_name => test_writer_5_type_name procedure :: write_makefile_code => test_writer_5_mk procedure :: write_source_code => test_writer_5_src procedure :: write_interface => test_writer_5_if procedure :: before_compile => test_writer_5_before_compile procedure :: after_compile => test_writer_5_after_compile end type test_writer_5_t @ %def test_writer_5 @ The <>= function test_writer_5_type_name () result (string) type(string_t) :: string string = "test_5" end function test_writer_5_type_name subroutine test_writer_5_mk & (writer, unit, id, os_data, verbose, testflag) class(test_writer_5_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag write (unit, "(5A)") "SOURCES += ", char (id), ".f90" write (unit, "(5A)") "OBJECTS += ", char (id), ".lo" write (unit, "(5A)") char (id), ".lo: ", char (id), ".f90" if (.not. verbose) then write (unit, "(5A)") TAB // '@echo " FC " $@' end if write (unit, "(5A)") TAB, "$(LTFCOMPILE) $<" end subroutine test_writer_5_mk subroutine test_writer_5_src (writer, id) class(test_writer_5_t), intent(in) :: writer type(string_t), intent(in) :: id call write_test_f_lib_file (id, var_str ("proc1")) end subroutine test_writer_5_src subroutine test_writer_5_if (writer, unit, id, feature) class(test_writer_5_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature select case (char (feature)) case ("proc1") write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "subroutine ", & char (writer%get_c_procname (id, feature)), & " (n) bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "integer(c_int), intent(out) :: n" write (unit, "(5x,9A)") "end subroutine ", & char (writer%get_c_procname (id, feature)) write (unit, "(2x,9A)") "end interface" case default call writer%write_standard_interface (unit, id, feature) end select end subroutine test_writer_5_if subroutine test_writer_5_before_compile (writer, id) class(test_writer_5_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_5_before_compile subroutine test_writer_5_after_compile (writer, id) class(test_writer_5_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_5_after_compile @ %def test_writer_5_type_name test_writer_5_mk @ %def test_writer_5_if @ %def test_writer_5_before_compile test_writer_5_after_compile @ We need a test module file (actually, one for each process in the test above) that allows us to check compilation and linking. The test module implements a colorless $1\to 2$ process, and it implements one additional function (feature), the name given as an argument. <>= subroutine write_test_f_lib_file (basename, feature) type(string_t), intent(in) :: basename type(string_t), intent(in) :: feature integer :: u u = free_unit () open (u, file = char (basename) // ".f90", & status = "replace", action = "write") write (u, "(A)") "! (Pseudo) matrix element code file & &for WHIZARD self-test" call write_test_me_code_3 (u, char (basename)) write (u, *) write (u, "(A)") "subroutine " // char (basename) // "_" & // char (feature) // " (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int), intent(out) :: n" write (u, "(A)") " n = 42" write (u, "(A)") "end subroutine " // char (basename) // "_" & // char (feature) close (u) end subroutine write_test_f_lib_file @ %def write_test_module_file @ The following matrix-element source code is identical to the previous one, but modified such as to provide independent procedures without a module envelope. <>= subroutine write_test_me_code_3 (u, id) integer, intent(in) :: u character(*), intent(in) :: id write (u, "(A)") "function " // id // "_get_md5sum () & &result (cptr) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " type(c_ptr) :: cptr" write (u, "(A)") " character(c_char), dimension(32), & &target, save :: md5sum" write (u, "(A)") " md5sum = copy (c_char_& &'1234567890abcdef1234567890abcdef')" write (u, "(A)") " cptr = c_loc (md5sum)" write (u, "(A)") "contains" write (u, "(A)") " function copy (md5sum)" write (u, "(A)") " character(c_char), dimension(32) :: copy" write (u, "(A)") " character(c_char), dimension(32), intent(in) :: & &md5sum" write (u, "(A)") " copy = md5sum" write (u, "(A)") " end function copy" write (u, "(A)") "end function " // id // "_get_md5sum" write (u, *) write (u, "(A)") "function " // id // "_openmp_supported () & &result (status) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " logical(c_bool) :: status" write (u, "(A)") " status = .false." write (u, "(A)") "end function " // id // "_openmp_supported" write (u, *) write (u, "(A)") "function " // id // "_n_in () result (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int) :: n" write (u, "(A)") " n = 1" write (u, "(A)") "end function " // id // "_n_in" write (u, *) write (u, "(A)") "function " // id // "_n_out () result (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int) :: n" write (u, "(A)") " n = 2" write (u, "(A)") "end function " // id // "_n_out" write (u, *) write (u, "(A)") "function " // id // "_n_flv () result (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int) :: n" write (u, "(A)") " n = 1" write (u, "(A)") "end function " // id // "_n_flv" write (u, *) write (u, "(A)") "function " // id // "_n_hel () result (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int) :: n" write (u, "(A)") " n = 1" write (u, "(A)") "end function " // id // "_n_hel" write (u, *) write (u, "(A)") "function " // id // "_n_cin () result (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int) :: n" write (u, "(A)") " n = 2" write (u, "(A)") "end function " // id // "_n_cin" write (u, *) write (u, "(A)") "function " // id // "_n_col () result (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int) :: n" write (u, "(A)") " n = 1" write (u, "(A)") "end function " // id // "_n_col" write (u, *) write (u, "(A)") "function " // id // "_n_cf () result (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int) :: n" write (u, "(A)") " n = 1" write (u, "(A)") "end function " // id // "_n_cf" write (u, *) write (u, "(A)") "subroutine " // id // "_flv_state (flv_state) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int), dimension(*), intent(out) :: flv_state" write (u, "(A)") " flv_state(1:3) = [1,2,3]" write (u, "(A)") "end subroutine " // id // "_flv_state" write (u, *) write (u, "(A)") "subroutine " // id // "_hel_state (hel_state) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int), dimension(*), intent(out) :: hel_state" write (u, "(A)") " hel_state(1:3) = [0,0,0]" write (u, "(A)") "end subroutine " // id // "_hel_state" write (u, *) write (u, "(A)") "subroutine " // id // "_col_state & &(col_state, ghost_flag) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int), dimension(*), intent(out) & &:: col_state" write (u, "(A)") " logical(c_bool), dimension(*), intent(out) & &:: ghost_flag" write (u, "(A)") " col_state(1:6) = [0,0, 0,0, 0,0]" write (u, "(A)") " ghost_flag(1:3) = [.false., .false., .false.]" write (u, "(A)") "end subroutine " // id // "_col_state" write (u, *) write (u, "(A)") "subroutine " // id // "_color_factors & &(cf_index1, cf_index2, color_factors) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " use kinds" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int), dimension(*), intent(out) :: cf_index1" write (u, "(A)") " integer(c_int), dimension(*), intent(out) :: cf_index2" write (u, "(A)") " complex(c_default_complex), dimension(*), & &intent(out) :: color_factors" write (u, "(A)") " cf_index1(1:1) = [1]" write (u, "(A)") " cf_index2(1:1) = [1]" write (u, "(A)") " color_factors(1:1) = [1]" write (u, "(A)") "end subroutine " // id // "_color_factors" end subroutine write_test_me_code_3 @ %def write_test_me_code_3 @ \subsubsection{Compile test with genuine C library} Test 6: Write driver and makefile and try to compile and link the library driver. There is a single test process with a single feature. The process code is provided as a C library of independent procedures. These procedures should match the Fortran bind(C) interface. <>= if (default == double .or. (CC_IS_GNU .and. CC_HAS_QUADMATH)) then call test (prclib_interfaces_6, "prclib_interfaces_6", & "compile and link (C library)", & u, results) end if <>= public :: prclib_interfaces_6 <>= subroutine prclib_interfaces_6 (u) integer, intent(in) :: u class(prclib_driver_t), allocatable :: driver class(prc_writer_t), pointer :: test_writer_6 type(os_data_t) :: os_data integer :: u_file integer, dimension(:,:), allocatable :: flv_state integer, dimension(:,:), allocatable :: hel_state integer, dimension(:,:,:), allocatable :: col_state logical, dimension(:,:), allocatable :: ghost_flag integer, dimension(:,:), allocatable :: cf_index complex(default), dimension(:), allocatable :: color_factors character(32), parameter :: md5sum = "prclib_interfaces_6_md5sum " type(c_funptr) :: proc1_ptr interface subroutine proc1_t (n) bind(C) import integer(c_int), intent(out) :: n end subroutine proc1_t end interface procedure(proc1_t), pointer :: proc1 integer(c_int) :: n write (u, "(A)") "* Test output: prclib_interfaces_6" write (u, "(A)") "* Purpose: compile, link, and load process library" write (u, "(A)") "* with (fake) matrix-element code & &as a C library" write (u, *) write (u, "(A)") "* Create a prclib driver object (1 process)" write (u, "(A)") call os_data%init () allocate (test_writer_6_t :: test_writer_6) call dispatch_prclib_driver (driver, var_str ("prclib6"), var_str ("")) call driver%init (1) call driver%set_md5sum (md5sum) call driver%set_record (1, var_str ("test6"), var_str ("Test_model"), & [var_str ("proc1")], test_writer_6) call driver%write (u) write (u, *) write (u, "(A)") "* Write makefile" u_file = free_unit () open (u_file, file="prclib6.makefile", status="replace", action="write") call driver%generate_makefile (u_file, os_data, verbose = .false.) close (u_file) write (u, "(A)") "* Write driver source code" u_file = free_unit () open (u_file, file="prclib6.f90", status="replace", action="write") call driver%generate_driver_code (u_file) close (u_file) write (u, "(A)") "* Write matrix-element source code" call driver%make_source (os_data) write (u, "(A)") "* Compile source code" call driver%make_compile (os_data) write (u, "(A)") "* Link library" call driver%make_link (os_data) write (u, "(A)") "* Load library" call driver%load (os_data) write (u, *) call driver%write (u) write (u, *) if (driver%loaded) then write (u, "(A)") "* Call library functions:" write (u, *) write (u, "(1x,A,I0)") "n_processes = ", driver%get_n_processes () write (u, "(1x,A,A)") "process_id = ", & char (driver%get_process_id (1)) write (u, "(1x,A,A)") "model_name = ", & char (driver%get_model_name (1)) write (u, "(1x,A,A)") "md5sum = ", & char (driver%get_md5sum (1)) write (u, "(1x,A,L1)") "openmp_status = ", driver%get_openmp_status (1) write (u, "(1x,A,I0)") "n_in = ", driver%get_n_in (1) write (u, "(1x,A,I0)") "n_out = ", driver%get_n_out (1) write (u, "(1x,A,I0)") "n_flv = ", driver%get_n_flv (1) write (u, "(1x,A,I0)") "n_hel = ", driver%get_n_hel (1) write (u, "(1x,A,I0)") "n_col = ", driver%get_n_col (1) write (u, "(1x,A,I0)") "n_cin = ", driver%get_n_cin (1) write (u, "(1x,A,I0)") "n_cf = ", driver%get_n_cf (1) call driver%set_flv_state (1, flv_state) write (u, "(1x,A,10(1x,I0))") "flv_state =", flv_state call driver%set_hel_state (1, hel_state) write (u, "(1x,A,10(1x,I0))") "hel_state =", hel_state call driver%set_col_state (1, col_state, ghost_flag) write (u, "(1x,A,10(1x,I0))") "col_state =", col_state write (u, "(1x,A,10(1x,L1))") "ghost_flag =", ghost_flag call driver%set_color_factors (1, color_factors, cf_index) write (u, "(1x,A,10(1x,F5.3))") "color_factors =", color_factors write (u, "(1x,A,10(1x,I0))") "cf_index =", cf_index call driver%get_fptr (1, 1, proc1_ptr) call c_f_procpointer (proc1_ptr, proc1) if (associated (proc1)) then write (u, *) call proc1 (n) write (u, "(1x,A,I0)") "proc1(1) = ", n end if end if deallocate (test_writer_6) write (u, "(A)") write (u, "(A)") "* Test output end: prclib_interfaces_6" end subroutine prclib_interfaces_6 @ %def prclib_interfaces_6 @ This version of test-code writer writes interfaces for all standard features plus one specific feature. The interfaces are all bind(C), so no wrapper is needed. The driver part is identical to the Fortran case, so we simply extend the previous [[test_writer_5]] type. We only have to override the Makefile writer. <>= type, extends (test_writer_5_t) :: test_writer_6_t contains procedure, nopass :: type_name => test_writer_6_type_name procedure :: write_makefile_code => test_writer_6_mk procedure :: write_source_code => test_writer_6_src end type test_writer_6_t @ %def test_writer_6 @ <>= function test_writer_6_type_name () result (string) type(string_t) :: string string = "test_6" end function test_writer_6_type_name subroutine test_writer_6_mk & (writer, unit, id, os_data, verbose, testflag) class(test_writer_6_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag write (unit, "(5A)") "SOURCES += ", char (id), ".c" write (unit, "(5A)") "OBJECTS += ", char (id), ".lo" write (unit, "(5A)") char (id), ".lo: ", char (id), ".c" if (.not. verbose) then write (unit, "(5A)") TAB // '@echo " FC " $@' end if write (unit, "(5A)") TAB, "$(LTCCOMPILE) $<" end subroutine test_writer_6_mk subroutine test_writer_6_src (writer, id) class(test_writer_6_t), intent(in) :: writer type(string_t), intent(in) :: id call write_test_c_lib_file (id, var_str ("proc1")) end subroutine test_writer_6_src @ %def test_writer_6_type_name test_writer_6_mk @ We need a test module file (actually, one for each process in the test above) that allows us to check compilation and linking. The test module implements a colorless $1\to 2$ process, and it implements one additional function (feature), the name given as an argument. <>= subroutine write_test_c_lib_file (basename, feature) type(string_t), intent(in) :: basename type(string_t), intent(in) :: feature integer :: u u = free_unit () open (u, file = char (basename) // ".c", & status = "replace", action = "write") write (u, "(A)") "/* (Pseudo) matrix element code file & &for WHIZARD self-test */" write (u, "(A)") "#include " if (CC_HAS_QUADMATH) then write (u, "(A)") "#include " end if write (u, *) call write_test_me_code_4 (u, char (basename)) write (u, *) write (u, "(A)") "void " // char (basename) // "_" & // char (feature) // "(int* n) {" write (u, "(A)") " *n = 42;" write (u, "(A)") "}" close (u) end subroutine write_test_c_lib_file @ %def write_test_module_file @ The following matrix-element source code is equivalent to the code in the previous example, but coded in C. <>= subroutine write_test_me_code_4 (u, id) integer, intent(in) :: u character(*), intent(in) :: id write (u, "(A)") "char* " // id // "_get_md5sum() {" write (u, "(A)") " return ""1234567890abcdef1234567890abcdef"";" write (u, "(A)") "}" write (u, *) write (u, "(A)") "bool " // id // "_openmp_supported() {" write (u, "(A)") " return false;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "int " // id // "_n_in() {" write (u, "(A)") " return 1;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "int " // id // "_n_out() {" write (u, "(A)") " return 2;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "int " // id // "_n_flv() {" write (u, "(A)") " return 1;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "int " // id // "_n_hel() {" write (u, "(A)") " return 1;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "int " // id // "_n_cin() {" write (u, "(A)") " return 2;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "int " // id // "_n_col() {" write (u, "(A)") " return 1;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "int " // id // "_n_cf() {" write (u, "(A)") " return 1;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "void " // id // "_flv_state( int (*a)[] ) {" write (u, "(A)") " static int flv_state[1][3] = { { 1, 2, 3 } };" write (u, "(A)") " int j;" write (u, "(A)") " for (j = 0; j < 3; j++) { (*a)[j] & &= flv_state[0][j]; }" write (u, "(A)") "}" write (u, *) write (u, "(A)") "void " // id // "_hel_state( int (*a)[] ) {" write (u, "(A)") " static int hel_state[1][3] = { { 0, 0, 0 } };" write (u, "(A)") " int j;" write (u, "(A)") " for (j = 0; j < 3; j++) { (*a)[j] & &= hel_state[0][j]; }" write (u, "(A)") "}" write (u, *) write (u, "(A)") "void " // id // "_col_state& &( int (*a)[], bool (*g)[] ) {" write (u, "(A)") " static int col_state[1][3][2] = & &{ { {0, 0}, {0, 0}, {0, 0} } };" write (u, "(A)") " static bool ghost_flag[1][3] = & &{ { false, false, false } };" write (u, "(A)") " int j,k;" write (u, "(A)") " for (j = 0; j < 3; j++) {" write (u, "(A)") " for (k = 0; k < 2; k++) {" write (u, "(A)") " (*a)[j*2+k] = col_state[0][j][k];" write (u, "(A)") " }" write (u, "(A)") " (*g)[j] = ghost_flag[0][j];" write (u, "(A)") " }" write (u, "(A)") "}" write (u, *) select case (DEFAULT_FC_PRECISION) case ("quadruple") write (u, "(A)") "void " // id // "_color_factors& &( int (*cf_index1)[], int (*cf_index2)[], & &__complex128 (*color_factors)[] ) {" case ("extended") write (u, "(A)") "void " // id // "_color_factors& &( int (*cf_index1)[], int (*cf_index2)[], & &long double _Complex (*color_factors)[] ) {" case default write (u, "(A)") "void " // id // "_color_factors& &( int (*cf_index1)[], int (*cf_index2)[], & &double _Complex (*color_factors)[] ) {" end select write (u, "(A)") " (*color_factors)[0] = 1;" write (u, "(A)") " (*cf_index1)[0] = 1;" write (u, "(A)") " (*cf_index2)[0] = 1;" write (u, "(A)") "}" end subroutine write_test_me_code_4 @ %def write_test_me_code_4 @ \subsubsection{Test cleanup targets} Test 7: Repeat test 4 (create, compile, link Fortran module and driver) and properly clean up all generated files. <>= call test (prclib_interfaces_7, "prclib_interfaces_7", & "cleanup", & u, results) <>= public :: prclib_interfaces_7 <>= subroutine prclib_interfaces_7 (u) integer, intent(in) :: u class(prclib_driver_t), allocatable :: driver class(prc_writer_t), pointer :: test_writer_4 type(os_data_t) :: os_data integer :: u_file character(32), parameter :: md5sum = "1234567890abcdef1234567890abcdef" write (u, "(A)") "* Test output: prclib_interfaces_7" write (u, "(A)") "* Purpose: compile and link process library" write (u, "(A)") "* with (fake) matrix-element code & &as a Fortran module" write (u, "(A)") "* then clean up generated files" write (u, *) write (u, "(A)") "* Create a prclib driver object (1 process)" allocate (test_writer_4_t :: test_writer_4) call os_data%init () call dispatch_prclib_driver (driver, var_str ("prclib7"), var_str ("")) call driver%init (1) call driver%set_md5sum (md5sum) call driver%set_record (1, var_str ("test7"), var_str ("Test_model"), & [var_str ("proc1")], test_writer_4) write (u, "(A)") "* Write makefile" u_file = free_unit () open (u_file, file="prclib7.makefile", status="replace", action="write") call driver%generate_makefile (u_file, os_data, verbose = .false.) close (u_file) write (u, "(A)") "* Write driver source code" u_file = free_unit () open (u_file, file="prclib7.f90", status="replace", action="write") call driver%generate_driver_code (u_file) close (u_file) write (u, "(A)") "* Write matrix-element source code" call driver%make_source (os_data) write (u, "(A)") "* Compile source code" call driver%make_compile (os_data) write (u, "(A)") "* Link library" call driver%make_link (os_data) write (u, "(A)") "* File check" write (u, *) call check_file (u, "test7.f90") call check_file (u, "tpr_test7.mod") call check_file (u, "test7.lo") call check_file (u, "prclib7.makefile") call check_file (u, "prclib7.f90") call check_file (u, "prclib7.lo") call check_file (u, "prclib7.la") write (u, *) write (u, "(A)") "* Delete library" write (u, *) call driver%clean_library (os_data) call check_file (u, "prclib7.la") write (u, *) write (u, "(A)") "* Delete object code" write (u, *) call driver%clean_objects (os_data) call check_file (u, "test7.lo") call check_file (u, "tpr_test7.mod") call check_file (u, "prclib7.lo") write (u, *) write (u, "(A)") "* Delete source code" write (u, *) call driver%clean_source (os_data) call check_file (u, "test7.f90") write (u, *) write (u, "(A)") "* Delete driver source code" write (u, *) call driver%clean_driver (os_data) call check_file (u, "prclib7.f90") write (u, *) write (u, "(A)") "* Delete makefile" write (u, *) call driver%clean_makefile (os_data) call check_file (u, "prclib7.makefile") deallocate (test_writer_4) write (u, *) write (u, "(A)") "* Test output end: prclib_interfaces_7" end subroutine prclib_interfaces_7 @ %def prclib_interfaces_7 @ Auxiliary routine: check and report existence of a file <>= subroutine check_file (u, file) integer, intent(in) :: u character(*), intent(in) :: file logical :: exist inquire (file=file, exist=exist) write (u, "(2x,A,A,L1)") file, " = ", exist end subroutine check_file @ %def check_file @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Abstract process core configuration} In this module, we define abstract data types that handle the method-specific part of defining a process (including all of its options) and accessing an external matrix element. There are no unit tests, these are deferred to the [[process_libraries]] module below. <<[[prc_core_def.f90]]>>= <> module prc_core_def <> use process_constants use prclib_interfaces <> <> <> <> interface <> end interface end module prc_core_def @ %def prc_core_def @ <<[[prc_core_def_sub.f90]]>>= <> submodule (prc_core_def) prc_core_def_s use io_units use diagnostics implicit none contains <> end submodule prc_core_def_s @ %def prc_core_def_s @ \subsection{Process core definition type} For storing configuration data that depend on the specific process variant, we introduce a polymorphic type. At this point, we just declare an abstract base type. This allows us to defer the implementation to later modules. There should be no components that need explicit finalization, otherwise we would have to call a finalizer from the [[process_component_def_t]] wrapper. @ Translate a [[prc_core_def_t]] to above named integers <>= public :: prc_core_def_t <>= type, abstract :: prc_core_def_t class(prc_writer_t), allocatable :: writer contains <> end type prc_core_def_t @ %def prc_core_def_t @ Interfaces for the deferred methods. This returns a string. No passed argument; the string is constant and depends just on the type. <>= procedure (prc_core_def_get_string), nopass, deferred :: type_string <>= abstract interface function prc_core_def_get_string () result (string) import type(string_t) :: string end function prc_core_def_get_string end interface @ %def prc_core_def_get_string @ The [[write]] method should display the content completely. <>= procedure (prc_core_def_write), deferred :: write <>= abstract interface subroutine prc_core_def_write (object, unit) import class(prc_core_def_t), intent(in) :: object integer, intent(in) :: unit end subroutine prc_core_def_write end interface @ %def prc_core_def_write @ The [[read]] method should fill the content completely. <>= procedure (prc_core_def_read), deferred :: read <>= abstract interface subroutine prc_core_def_read (object, unit) import class(prc_core_def_t), intent(out) :: object integer, intent(in) :: unit end subroutine prc_core_def_read end interface @ %def prc_core_def_read @ This communicates a MD5 checksum to the writer inside the [[core_def]] object, if there is any. Usually, this checksum is not yet known at the time when the writer is initialized. <>= procedure :: set_md5sum => prc_core_def_set_md5sum <>= module subroutine prc_core_def_set_md5sum (core_def, md5sum) class(prc_core_def_t), intent(inout) :: core_def character(32) :: md5sum end subroutine prc_core_def_set_md5sum <>= module subroutine prc_core_def_set_md5sum (core_def, md5sum) class(prc_core_def_t), intent(inout) :: core_def character(32) :: md5sum if (allocated (core_def%writer)) core_def%writer%md5sum = md5sum end subroutine prc_core_def_set_md5sum @ %def prc_core_def_set_md5sum @ Allocate an appropriate driver object which corresponds to the chosen process core definition. For internal matrix element (i.e., those which do not need external code), the driver should have access to all matrix element information from the beginning. In short, it is the matrix-element code. For external matrix elements, the driver will get access to the external matrix element code. <>= procedure(prc_core_def_allocate_driver), deferred :: allocate_driver <>= abstract interface subroutine prc_core_def_allocate_driver (object, driver, basename) import class(prc_core_def_t), intent(in) :: object class(prc_core_driver_t), intent(out), allocatable :: driver type(string_t), intent(in) :: basename end subroutine prc_core_def_allocate_driver end interface @ %def prc_core_def_allocate_driver @ This flag tells whether the particular variant needs external code. We implement a default function which returns false. The flag depends only on the type, therefore we implement it as [[nopass]]. <>= procedure, nopass :: needs_code => prc_core_def_needs_code <>= module function prc_core_def_needs_code () result (flag) logical :: flag end function prc_core_def_needs_code <>= module function prc_core_def_needs_code () result (flag) logical :: flag flag = .false. end function prc_core_def_needs_code @ %def prc_core_def_needs_code @ This subroutine allocates an array which holds the name of all features that this process core implements. This feature applies to matrix element code that is not coded as a Fortran module but communicates via independent library functions, which follow the C calling conventions. The addresses of those functions are returned as C function pointers, which can be converted into Fortran procedure pointers. The conversion is done in code specific for the process variant; here we just retrieve the C function pointer. The array returned here serves the purpose of writing specific driver code. The driver interfaces only those C functions which are supported for the given process core. If the process core does not require external code, this array is meaningless. <>= procedure(prc_core_def_get_features), nopass, deferred & :: get_features <>= abstract interface subroutine prc_core_def_get_features (features) import type(string_t), dimension(:), allocatable, intent(out) :: features end subroutine prc_core_def_get_features end interface @ %def prc_core_def_get_features @ Assign pointers to the process-specific procedures to the driver, if the process is external. <>= procedure(prc_core_def_connect), deferred :: connect <>= abstract interface subroutine prc_core_def_connect (def, lib_driver, i, proc_driver) import class(prc_core_def_t), intent(in) :: def class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver end subroutine prc_core_def_connect end interface @ %def prc_core_def_connect @ \subsection{Process core template} We must be able to automatically allocate a process core definition object with the appropriate type, given only the type name. To this end, we introduce a [[prc_template_t]] type which is simply a wrapper for an empty [[prc_core_def_t]] object. Choosing one of the templates from an array, we can allocate the target object. <>= public :: prc_template_t <>= type :: prc_template_t class(prc_core_def_t), allocatable :: core_def end type prc_template_t @ %def prc_template_t @ The allocation routine. We use the [[source]] option of the [[allocate]] statement. The [[mold]] option would probably more appropriate, but is a F2008 feature. <>= public :: allocate_core_def <>= module subroutine allocate_core_def (template, name, core_def) type(prc_template_t), dimension(:), intent(in) :: template type(string_t), intent(in) :: name class(prc_core_def_t), allocatable :: core_def end subroutine allocate_core_def <>= module subroutine allocate_core_def (template, name, core_def) type(prc_template_t), dimension(:), intent(in) :: template type(string_t), intent(in) :: name class(prc_core_def_t), allocatable :: core_def integer :: i do i = 1, size (template) if (template(i)%core_def%type_string () == name) then allocate (core_def, source = template(i)%core_def) return end if end do end subroutine allocate_core_def @ %def allocate_core_def @ \subsection{Process driver} For each process component, we implement a driver object which holds the calls to the matrix element and various auxiliary routines as procedure pointers. Any actual calculation will use this object to communicate with the process. Depending on the type of process (as described by a corresponding [[prc_core_def]] object), the procedure pointers may refer to external or internal code, and there may be additional procedures for certain types. The base type defined here is abstract. <>= public :: prc_core_driver_t <>= type, abstract :: prc_core_driver_t contains <> end type prc_core_driver_t @ %def prc_core_driver_t @ This returns the process type. No reference to contents. <>= procedure(prc_core_driver_type_name), nopass, deferred :: type_name <>= abstract interface function prc_core_driver_type_name () result (type) import type(string_t) :: type end function prc_core_driver_type_name end interface @ %def prc_core_driver_type_name @ \subsection{Process driver for intrinsic process} This is an abstract extension for the driver type. It has one additional method, namely a subroutine that fills the record of constant process data. For an external process, this task is performed by the external library driver instead. <>= public :: process_driver_internal_t <>= type, extends (prc_core_driver_t), abstract :: process_driver_internal_t contains <> end type process_driver_internal_t @ %def process_driver_internal_t <>= procedure(process_driver_fill_constants), deferred :: fill_constants <>= abstract interface subroutine process_driver_fill_constants (driver, data) import class(process_driver_internal_t), intent(in) :: driver type(process_constants_t), intent(out) :: data end subroutine process_driver_fill_constants end interface @ %def process_driver_fill_constants @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process library access} \label{sec:process_libraries} Processes (the code and data that are necessary for evaluating matrix elements of a particular process or process component) are organized in process libraries. In full form, process libraries contain generated and dynamically compiled and linked code, so they are actual libraries on the OS level. Alternatively, there may be simple processes that can be generated without referring to external libraries, and external libraries that are just linked in. This module interfaces the OS to create, build, and use process libraries. We work with two related data structures. There is the list of process configurations that stores the user input and data derived from it. A given process configuration list is scanned for creating a process library, which consists of both data and code. The creation step involves calling external programs and incorporating external code. For the subsequent integration and event generation steps, we read the process library. We also support partial (re)creation of the process library. To this end, we should be able to reconstruct the configuration data records from the process library. <<[[process_libraries.f90]]>>= <> module process_libraries use, intrinsic :: iso_c_binding !NODEP! <> use physics_defs use os_interface use model_data use particle_specifiers use process_constants use prclib_interfaces use prc_core_def <> <> <> <> interface <> end interface end module process_libraries @ %def process_libraries @ <<[[process_libraries_sub.f90]]>>= <> submodule (process_libraries) process_libraries_s use io_units use diagnostics use md5 implicit none contains <> end submodule process_libraries_s @ %def process_libraries_s @ \subsection{Auxiliary stuff} Here is a small subroutine that strips the left-hand side and the equals sign off an equation. <>= public :: strip_equation_lhs <>= module subroutine strip_equation_lhs (buffer) character(*), intent(inout) :: buffer end subroutine strip_equation_lhs <>= module subroutine strip_equation_lhs (buffer) character(*), intent(inout) :: buffer type(string_t) :: string, prefix string = buffer call split (string, prefix, "=") buffer = string end subroutine strip_equation_lhs @ %def strip_equation_lhs @ \subsection{Process definition objects} We collect process configuration data in a derived type, [[process_def_t]]. A process can be a collection of several components which are treated as a single entity for the purpose of observables and event generation. Multiple process components may initially be defined by the user. The system may add additional components, e.g., subtraction terms. The common data type is [[process_component_def_t]]. Within each component, there are several universal data items, and a part which depend on the particular process variant. The latter is covered by an abstract type [[prc_core_def_t]] and its extensions. @ \subsubsection{Wrapper for components} We define a wrapper type for the configuration of individual components. The string [[basename]] is used for building file, module, and function names for the current process component. Initially, it will be built from the corresponding process basename by appending an alphanumeric suffix. The logical [[initial]] tells whether this is a user-defined (true) or system-generated (false) configuration. The numbers [[n_in]], [[n_out]], and [[n_tot]] denote the incoming, outgoing and total number of particles (partons) participating in the process component, respectively. These are the nominal particles, as input by the user (recombination may change the particle content, for the output events). The string arrays [[prt_in]] and [[prt_out]] hold the particle specifications as provided by the user. For a system-generated process component, they remain deallocated. The [[method]] string is used to determine the type of process matrix element and how it is obtained. The [[description]] string collects the information about particle content and method in a single human-readable string. The pointer object [[core_def]] is allocated according to the actual process variant, which depends on the method. The subobject holds any additional configuration data that is relevant for the process component. We assume that no finalizer is needed. <>= public :: process_component_def_t <>= 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 character(32) :: md5sum = "" integer :: nlo_type = BORN integer, dimension(N_ASSOCIATED_COMPONENTS) :: associated_components = 0 logical :: active integer :: fixed_emitter = -1 integer :: alpha_power = 0 integer :: alphas_power = 0 contains <> end type process_component_def_t @ %def process_component_def_t @ Display the complete content. <>= procedure :: write => process_component_def_write <>= module subroutine process_component_def_write (object, unit) class(process_component_def_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine process_component_def_write <>= module subroutine process_component_def_write (object, unit) class(process_component_def_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A,A)") "Component ID = ", char (object%basename) write (u, "(3x,A,L1)") "Initial component = ", object%initial write (u, "(3x,A,I0,1x,I0,1x,I0)") "N (in, out, tot) = ", & object%n_in, object%n_out, object%n_tot write (u, "(3x,A)", advance="no") "Particle content = " if (allocated (object%prt_in)) then call prt_spec_write (object%prt_in, u, advance="no") else write (u, "(A)", advance="no") "[undefined]" end if write (u, "(A)", advance="no") " => " if (allocated (object%prt_out)) then call prt_spec_write (object%prt_out, u, advance="no") else write (u, "(A)", advance="no") "[undefined]" end if write (u, "(A)") if (object%method /= "") then write (u, "(3x,A,A)") "Method = ", & char (object%method) else write (u, "(3x,A)") "Method = [undefined]" end if if (allocated (object%core_def)) then write (u, "(3x,A,A)") "Process variant = ", & char (object%core_def%type_string ()) call object%core_def%write (u) else write (u, "(3x,A)") "Process variant = [undefined]" end if write (u, "(3x,A,A,A)") "MD5 sum (def) = '", object%md5sum, "'" end subroutine process_component_def_write @ %def process_component_def_write @ Read the process component definition. Allocate the process variant definition with appropriate type, matching the type name on file with the provided templates. <>= procedure :: read => process_component_def_read <>= module subroutine process_component_def_read (component, unit, core_def_templates) class(process_component_def_t), intent(out) :: component integer, intent(in) :: unit type(prc_template_t), dimension(:), intent(in) :: core_def_templates end subroutine process_component_def_read <>= module subroutine process_component_def_read (component, unit, core_def_templates) class(process_component_def_t), intent(out) :: component integer, intent(in) :: unit type(prc_template_t), dimension(:), intent(in) :: core_def_templates character(80) :: buffer type(string_t) :: var_buffer, prefix, in_state, out_state type(string_t) :: variant_type read (unit, "(A)") buffer call strip_equation_lhs (buffer) component%basename = trim (adjustl (buffer)) read (unit, "(A)") buffer call strip_equation_lhs (buffer) read (buffer, *) component%initial read (unit, "(A)") buffer call strip_equation_lhs (buffer) read (buffer, *) component%n_in, component%n_out, component%n_tot call get (unit, var_buffer) call split (var_buffer, prefix, "=") ! keeps 'in => out' call split (var_buffer, prefix, "=") ! actually: separator is '=>' in_state = prefix if (component%n_in > 0) then call prt_spec_read (component%prt_in, in_state) end if out_state = extract (var_buffer, 2) if (component%n_out > 0) then call prt_spec_read (component%prt_out, out_state) end if read (unit, "(A)") buffer call strip_equation_lhs (buffer) component%method = trim (adjustl (buffer)) if (component%method == "[undefined]") & component%method = "" read (unit, "(A)") buffer call strip_equation_lhs (buffer) variant_type = trim (adjustl (buffer)) call allocate_core_def & (core_def_templates, variant_type, component%core_def) if (allocated (component%core_def)) then call component%core_def%read (unit) end if read (unit, "(A)") buffer call strip_equation_lhs (buffer) read (buffer(3:34), "(A32)") component%md5sum end subroutine process_component_def_read @ %def process_component_def_read @ Short account. <>= procedure :: show => process_component_def_show <>= module subroutine process_component_def_show (object, unit) class(process_component_def_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine process_component_def_show <>= module subroutine process_component_def_show (object, unit) class(process_component_def_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(6x,A)", advance="no") char (object%basename) if (.not. object%initial) & write (u, "('*')", advance="no") write (u, "(':',1x)", advance="no") if (allocated (object%prt_in)) then call prt_spec_write (object%prt_in, u, advance="no") else write (u, "(A)", advance="no") "[undefined]" end if write (u, "(A)", advance="no") " => " if (allocated (object%prt_out)) then call prt_spec_write (object%prt_out, u, advance="no") else write (u, "(A)", advance="no") "[undefined]" end if if (object%method /= "") then write (u, "(2x,'[',A,']')") char (object%method) else write (u, *) end if end subroutine process_component_def_show @ %def process_component_def_show @ Compute the MD5 sum of a process component. We reset the stored MD5 sum to the empty string (so a previous value is not included in the calculation), then write a temporary file and calculate the MD5 sum of that file. This implies that all data that are displayed by the [[write]] method become part of the MD5 sum calculation. The [[model]] is not part of the object, but must be included in the MD5 sum. Otherwise, modifying the model and nothing else would not trigger remaking the process-component source. Note that the model parameters may change later and therefore are not incorporated. After the MD5 sum of the component has been computed, we communicate it to the [[writer]] subobject of the specific [[core_def]] component. Although these types are abstract, the MD5-related features are valid for the abstract types. <>= procedure :: compute_md5sum => process_component_def_compute_md5sum <>= module subroutine process_component_def_compute_md5sum (component, model) class(process_component_def_t), intent(inout) :: component class(model_data_t), intent(in), optional, target :: model end subroutine process_component_def_compute_md5sum <>= module subroutine process_component_def_compute_md5sum (component, model) class(process_component_def_t), intent(inout) :: component class(model_data_t), intent(in), optional, target :: model integer :: u component%md5sum = "" u = free_unit () open (u, status = "scratch", action = "readwrite") if (present (model)) write (u, "(A32)") model%get_md5sum () call component%write (u) rewind (u) component%md5sum = md5sum (u) close (u) if (allocated (component%core_def)) then call component%core_def%set_md5sum (component%md5sum) end if end subroutine process_component_def_compute_md5sum @ %def process_component_def_compute_md5sum @ <>= procedure :: get_def_type_string => process_component_def_get_def_type_string <>= module function process_component_def_get_def_type_string (component) result (type_string) type(string_t) :: type_string class(process_component_def_t), intent(in) :: component end function process_component_def_get_def_type_string <>= module function process_component_def_get_def_type_string (component) result (type_string) type(string_t) :: type_string class(process_component_def_t), intent(in) :: component type_string = component%core_def%type_string () end function process_component_def_get_def_type_string @ %def process_component_def_get_def_type_string @ Allocate the process driver (with a suitable type) for a process component. For internal processes, we may set all data already at this stage. <>= procedure :: allocate_driver => process_component_def_allocate_driver <>= module subroutine process_component_def_allocate_driver (component, driver) class(process_component_def_t), intent(in) :: component class(prc_core_driver_t), intent(out), allocatable :: driver end subroutine process_component_def_allocate_driver <>= module subroutine process_component_def_allocate_driver (component, driver) class(process_component_def_t), intent(in) :: component class(prc_core_driver_t), intent(out), allocatable :: driver if (allocated (component%core_def)) then call component%core_def%allocate_driver (driver, component%basename) end if end subroutine process_component_def_allocate_driver @ %def process_component_def_allocate_driver @ Tell whether the process core needs external code. <>= procedure :: needs_code => process_component_def_needs_code <>= module function process_component_def_needs_code (component) result (flag) class(process_component_def_t), intent(in) :: component logical :: flag end function process_component_def_needs_code <>= module function process_component_def_needs_code (component) result (flag) class(process_component_def_t), intent(in) :: component logical :: flag flag = component%core_def%needs_code () end function process_component_def_needs_code @ %def process_component_def_needs_code @ If there is external code, the [[core_def]] subobject should provide a writer object. This method returns a pointer to the writer. <>= procedure :: get_writer_ptr => process_component_def_get_writer_ptr <>= module function process_component_def_get_writer_ptr (component) result (writer) class(process_component_def_t), intent(in), target :: component class(prc_writer_t), pointer :: writer end function process_component_def_get_writer_ptr <>= module function process_component_def_get_writer_ptr (component) result (writer) class(process_component_def_t), intent(in), target :: component class(prc_writer_t), pointer :: writer writer => component%core_def%writer end function process_component_def_get_writer_ptr @ %def process_component_def_get_writer_ptr @ Return an array which holds the names of all C functions that this process component implements. <>= procedure :: get_features => process_component_def_get_features <>= module function process_component_def_get_features (component) result (features) class(process_component_def_t), intent(in) :: component type(string_t), dimension(:), allocatable :: features end function process_component_def_get_features <>= module function process_component_def_get_features (component) result (features) class(process_component_def_t), intent(in) :: component type(string_t), dimension(:), allocatable :: features call component%core_def%get_features (features) end function process_component_def_get_features @ %def process_component_def_get_features @ Assign procedure pointers in the [[driver]] component (external processes). For internal processes, this is meaningless. <>= procedure :: connect => process_component_def_connect <>= module subroutine process_component_def_connect & (component, lib_driver, i, proc_driver) class(process_component_def_t), intent(in) :: component class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver end subroutine process_component_def_connect <>= module subroutine process_component_def_connect & (component, lib_driver, i, proc_driver) class(process_component_def_t), intent(in) :: component class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver select type (proc_driver) class is (process_driver_internal_t) !!! Nothing to do class default call component%core_def%connect (lib_driver, i, proc_driver) end select end subroutine process_component_def_connect @ %def process_component_def_connect @ Return a pointer to the process core definition, which is of abstract type. <>= procedure :: get_core_def_ptr => process_component_get_core_def_ptr <>= module function process_component_get_core_def_ptr (component) result (ptr) class(process_component_def_t), intent(in), target :: component class(prc_core_def_t), pointer :: ptr end function process_component_get_core_def_ptr <>= module function process_component_get_core_def_ptr (component) result (ptr) class(process_component_def_t), intent(in), target :: component class(prc_core_def_t), pointer :: ptr ptr => component%core_def end function process_component_get_core_def_ptr @ %def process_component_get_core_def_ptr @ Return nominal particle counts, as input by the user. <>= procedure :: get_n_in => process_component_def_get_n_in procedure :: get_n_out => process_component_def_get_n_out procedure :: get_n_tot => process_component_def_get_n_tot <>= module function process_component_def_get_n_in (component) result (n_in) class(process_component_def_t), intent(in) :: component integer :: n_in end function process_component_def_get_n_in module function process_component_def_get_n_out (component) result (n_out) class(process_component_def_t), intent(in) :: component integer :: n_out end function process_component_def_get_n_out module function process_component_def_get_n_tot (component) result (n_tot) class(process_component_def_t), intent(in) :: component integer :: n_tot end function process_component_def_get_n_tot <>= module 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 module function process_component_def_get_n_out (component) result (n_out) class(process_component_def_t), intent(in) :: component integer :: n_out n_out = component%n_out end function process_component_def_get_n_out module function process_component_def_get_n_tot (component) result (n_tot) class(process_component_def_t), intent(in) :: component integer :: n_tot n_tot = component%n_tot end function process_component_def_get_n_tot @ %def process_component_def_get_n_in @ %def process_component_def_get_n_out @ %def process_component_def_get_n_tot @ Allocate and return string arrays for the incoming and outgoing particles. <>= procedure :: get_prt_in => process_component_def_get_prt_in procedure :: get_prt_out => process_component_def_get_prt_out <>= module subroutine process_component_def_get_prt_in (component, prt) class(process_component_def_t), intent(in) :: component type(string_t), dimension(:), intent(out), allocatable :: prt end subroutine process_component_def_get_prt_in module subroutine process_component_def_get_prt_out (component, prt) class(process_component_def_t), intent(in) :: component type(string_t), dimension(:), intent(out), allocatable :: prt end subroutine process_component_def_get_prt_out <>= module subroutine process_component_def_get_prt_in (component, prt) class(process_component_def_t), intent(in) :: component type(string_t), dimension(:), intent(out), allocatable :: prt integer :: i allocate (prt (component%n_in)) do i = 1, component%n_in prt(i) = component%prt_in(i)%to_string () end do end subroutine process_component_def_get_prt_in module subroutine process_component_def_get_prt_out (component, prt) class(process_component_def_t), intent(in) :: component type(string_t), dimension(:), intent(out), allocatable :: prt integer :: i allocate (prt (component%n_out)) do i = 1, component%n_out prt(i) = component%prt_out(i)%to_string () end do end subroutine process_component_def_get_prt_out @ %def process_component_def_get_prt_in @ %def process_component_def_get_prt_out @ Return the incoming and outgoing particle specifiers as-is. <>= procedure :: get_prt_spec_in => process_component_def_get_prt_spec_in procedure :: get_prt_spec_out => process_component_def_get_prt_spec_out <>= module function process_component_def_get_prt_spec_in (component) result (prt) class(process_component_def_t), intent(in) :: component type(prt_spec_t), dimension(:), allocatable :: prt end function process_component_def_get_prt_spec_in module function process_component_def_get_prt_spec_out (component) result (prt) class(process_component_def_t), intent(in) :: component type(prt_spec_t), dimension(:), allocatable :: prt end function process_component_def_get_prt_spec_out <>= module function process_component_def_get_prt_spec_in (component) result (prt) class(process_component_def_t), intent(in) :: component type(prt_spec_t), dimension(:), allocatable :: prt allocate (prt (component%n_in)) prt(:) = component%prt_in(:) end function process_component_def_get_prt_spec_in module function process_component_def_get_prt_spec_out (component) result (prt) class(process_component_def_t), intent(in) :: component type(prt_spec_t), dimension(:), allocatable :: prt allocate (prt (component%n_out)) prt(:) = component%prt_out(:) end function process_component_def_get_prt_spec_out @ %def process_component_def_get_prt_spec_in @ %def process_component_def_get_prt_spec_out @ Return the combination of incoming particles as a PDG code <>= procedure :: get_pdg_in => process_component_def_get_pdg_in <>= module subroutine process_component_def_get_pdg_in (component, model, pdg) class(process_component_def_t), intent(in) :: component class(model_data_t), intent(in), target :: model integer, intent(out), dimension(:) :: pdg end subroutine process_component_def_get_pdg_in <>= module subroutine process_component_def_get_pdg_in (component, model, pdg) class(process_component_def_t), intent(in) :: component class(model_data_t), intent(in), target :: model integer, intent(out), dimension(:) :: pdg integer :: i do i = 1, size (pdg) pdg(i) = model%get_pdg (component%prt_in(i)%to_string ()) end do end subroutine process_component_def_get_pdg_in @ %def process_component_def_get_pdg_in @ Return the MD5 sum. <>= procedure :: get_md5sum => process_component_def_get_md5sum <>= pure module function process_component_def_get_md5sum (component) result (md5sum) class(process_component_def_t), intent(in) :: component character(32) :: md5sum end function process_component_def_get_md5sum <>= pure module function process_component_def_get_md5sum (component) result (md5sum) class(process_component_def_t), intent(in) :: component character(32) :: md5sum md5sum = component%md5sum end function process_component_def_get_md5sum @ %def process_component_def_get_md5sum @ Get NLO data <>= procedure :: get_nlo_type => process_component_def_get_nlo_type procedure :: get_associated_born & => process_component_def_get_associated_born procedure :: get_associated_real_fin & => process_component_def_get_associated_real_fin procedure :: get_associated_real_sing & => process_component_def_get_associated_real_sing procedure :: get_associated_subtraction & => process_component_def_get_associated_subtraction procedure :: get_association_list & => process_component_def_get_association_list procedure :: can_be_integrated & => process_component_def_can_be_integrated procedure :: get_associated_real => process_component_def_get_associated_real <>= elemental module function process_component_def_get_nlo_type & (component) result (nlo_type) integer :: nlo_type class(process_component_def_t), intent(in) :: component end function process_component_def_get_nlo_type elemental module function process_component_def_get_associated_born & (component) result (i_born) integer :: i_born class(process_component_def_t), intent(in) :: component end function process_component_def_get_associated_born elemental module function process_component_def_get_associated_real_fin & (component) result (i_rfin) integer :: i_rfin class(process_component_def_t), intent(in) :: component end function process_component_def_get_associated_real_fin elemental module function process_component_def_get_associated_real_sing & (component) result (i_rsing) integer :: i_rsing class(process_component_def_t), intent(in) :: component end function process_component_def_get_associated_real_sing elemental module function process_component_def_get_associated_subtraction & (component) result (i_sub) integer :: i_sub class(process_component_def_t), intent(in) :: component end function process_component_def_get_associated_subtraction elemental module function process_component_def_can_be_integrated & (component) result (active) logical :: active class(process_component_def_t), intent(in) :: component end function process_component_def_can_be_integrated module function process_component_def_get_association_list & (component, i_skip_in) result (list) integer, dimension(:), allocatable :: list class(process_component_def_t), intent(in) :: component integer, intent(in), optional :: i_skip_in end function process_component_def_get_association_list module function process_component_def_get_associated_real & (component) result (i_real) integer :: i_real class(process_component_def_t), intent(in) :: component end function process_component_def_get_associated_real <>= elemental module function process_component_def_get_nlo_type & (component) result (nlo_type) integer :: nlo_type class(process_component_def_t), intent(in) :: component nlo_type = component%nlo_type end function process_component_def_get_nlo_type elemental module function process_component_def_get_associated_born & (component) result (i_born) integer :: i_born class(process_component_def_t), intent(in) :: component i_born = component%associated_components(ASSOCIATED_BORN) end function process_component_def_get_associated_born elemental module function process_component_def_get_associated_real_fin & (component) result (i_rfin) integer :: i_rfin class(process_component_def_t), intent(in) :: component i_rfin = component%associated_components(ASSOCIATED_REAL_FIN) end function process_component_def_get_associated_real_fin elemental module function process_component_def_get_associated_real_sing & (component) result (i_rsing) integer :: i_rsing class(process_component_def_t), intent(in) :: component i_rsing = component%associated_components(ASSOCIATED_REAL_SING) end function process_component_def_get_associated_real_sing elemental module function process_component_def_get_associated_subtraction & (component) result (i_sub) integer :: i_sub class(process_component_def_t), intent(in) :: component i_sub = component%associated_components(ASSOCIATED_SUB) end function process_component_def_get_associated_subtraction elemental module function process_component_def_can_be_integrated & (component) result (active) logical :: active class(process_component_def_t), intent(in) :: component active = component%active end function process_component_def_can_be_integrated module function process_component_def_get_association_list & (component, i_skip_in) result (list) integer, dimension(:), allocatable :: list class(process_component_def_t), intent(in) :: component integer, intent(in), optional :: i_skip_in integer :: i, j, n, i_skip logical :: valid i_skip = 0; if (present (i_skip_in)) i_skip = i_skip_in n = count (component%associated_components /= 0) - 1 if (i_skip > 0) then if (component%associated_components(i_skip) > 0) n = n - 1 end if allocate (list (n)) j = 1 do i = 1, size(component%associated_components) valid = component%associated_components(i) /= 0 & .and. i /= ASSOCIATED_SUB .and. i /= i_skip if (valid) then list(j) = component%associated_components(i) j = j + 1 end if end do end function process_component_def_get_association_list module function process_component_def_get_associated_real & (component) result (i_real) integer :: i_real class(process_component_def_t), intent(in) :: component i_real = component%associated_components(ASSOCIATED_REAL) end function process_component_def_get_associated_real @ %def process_component_def_get_nlo_type, process_component_def_get_associated_born @ %def process_component_def_can_be_integrated @ %def process_component_def_get_association_list @ %def process_component_def_get_associated_real @ %def process_component_def_get_associated_real_fin @ %def process_component_def_get_associated_subtraction @ <>= procedure :: get_me_method => process_component_def_get_me_method <>= elemental module function process_component_def_get_me_method (component) result (method) type(string_t) :: method class(process_component_def_t), intent(in) :: component end function process_component_def_get_me_method <>= elemental module function process_component_def_get_me_method (component) result (method) type(string_t) :: method class(process_component_def_t), intent(in) :: component method = component%method end function process_component_def_get_me_method @ %def process_component_def_get_me_method @ <>= procedure :: get_fixed_emitter => process_component_def_get_fixed_emitter <>= module function process_component_def_get_fixed_emitter (component) result (emitter) integer :: emitter class(process_component_def_t), intent(in) :: component end function process_component_def_get_fixed_emitter <>= module function process_component_def_get_fixed_emitter (component) result (emitter) integer :: emitter class(process_component_def_t), intent(in) :: component emitter = component%fixed_emitter end function process_component_def_get_fixed_emitter @ %def process_component_def_get_fixed_emitter @ <>= procedure :: get_coupling_powers => process_component_def_get_coupling_powers <>= pure module subroutine process_component_def_get_coupling_powers & (component, alpha_power, alphas_power) class(process_component_def_t), intent(in) :: component integer, intent(out) :: alpha_power, alphas_power end subroutine process_component_def_get_coupling_powers <>= pure module subroutine process_component_def_get_coupling_powers & (component, alpha_power, alphas_power) class(process_component_def_t), intent(in) :: component integer, intent(out) :: alpha_power, alphas_power alpha_power = component%alpha_power alphas_power = component%alphas_power end subroutine process_component_def_get_coupling_powers @ %def process_component_def_get_coupling_powers @ \subsubsection{Process definition} The process component definitions are collected in a common process definition object. The [[id]] is the ID string that the user has provided for identifying this process. It must be a string that is allowed as part of a Fortran variable name, since it may be used for generating code. The number [[n_in]] is 1 or 2 for a decay or scattering process, respectively. This must be identical to [[n_in]] for all components. The initial and extra component definitions (see above) are allocated as the [[initial]] and [[extra]] arrays, respectively. The latter are determined from the former. The [[md5sum]] is used to verify the integrity of the configuration. <>= public :: process_def_t <>= type :: process_def_t private type(string_t) :: id integer :: num_id = 0 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 character(32) :: md5sum = "" logical :: nlo_process = .false. logical :: negative_sf = .false. logical :: requires_resonances = .false. contains <> end type process_def_t @ %def process_def_t @ Write the process definition including components: <>= procedure :: write => process_def_write <>= module subroutine process_def_write (object, unit) class(process_def_t), intent(in) :: object integer, intent(in) :: unit end subroutine process_def_write <>= module subroutine process_def_write (object, unit) class(process_def_t), intent(in) :: object integer, intent(in) :: unit integer :: i write (unit, "(1x,A,A,A)") "ID = '", char (object%id), "'" if (object%num_id /= 0) & write (unit, "(1x,A,I0)") "ID(num) = ", object%num_id select case (object%n_in) case (1); write (unit, "(1x,A)") "Decay" case (2); write (unit, "(1x,A)") "Scattering" case default write (unit, "(1x,A)") "[Undefined process]" return end select if (object%model_name /= "") then write (unit, "(1x,A,A)") "Model = ", char (object%model_name) else write (unit, "(1x,A)") "Model = [undefined]" end if write (unit, "(1x,A,I0)") "Initially defined component(s) = ", & object%n_initial write (unit, "(1x,A,I0)") "Extra generated component(s) = ", & object%n_extra if (object%requires_resonances) then ! This line has to matched with the reader below! write (unit, "(1x,A,I0)") "Resonant subprocesses required" end if write (unit, "(1x,A,A,A)") "MD5 sum = '", object%md5sum, "'" if (allocated (object%initial)) then do i = 1, size (object%initial) write (unit, "(1x,A,I0)") "Component #", i call object%initial(i)%write (unit) end do end if if (allocated (object%extra)) then do i = 1, size (object%extra) write (unit, "(1x,A,I0)") "Component #", object%n_initial + i call object%extra(i)%write (unit) end do end if end subroutine process_def_write @ %def process_def_write @ Read the process definition including components. <>= procedure :: read => process_def_read <>= module subroutine process_def_read (object, unit, core_def_templates) class(process_def_t), intent(out) :: object integer, intent(in) :: unit type(prc_template_t), dimension(:), intent(in) :: core_def_templates end subroutine process_def_read <>= module subroutine process_def_read (object, unit, core_def_templates) class(process_def_t), intent(out) :: object integer, intent(in) :: unit type(prc_template_t), dimension(:), intent(in) :: core_def_templates integer :: i, i1, i2 character(80) :: buffer, ref read (unit, "(A)") buffer call strip_equation_lhs (buffer) i1 = scan (buffer, "'") i2 = scan (buffer, "'", back=.true.) if (i2 > i1) then object%id = buffer(i1+1:i2-1) else object%id = "" end if read (unit, "(A)") buffer select case (buffer(2:11)) case ("Decay "); object%n_in = 1 case ("Scattering"); object%n_in = 2 case default return end select read (unit, "(A)") buffer call strip_equation_lhs (buffer) object%model_name = trim (adjustl (buffer)) if (object%model_name == "[undefined]") object%model_name = "" read (unit, "(A)") buffer call strip_equation_lhs (buffer) read (buffer, *) object%n_initial read (unit, "(A)") buffer call strip_equation_lhs (buffer) read (buffer, *) object%n_extra read (unit, "(A)") buffer if (buffer(1:9) == " Resonant") then object%requires_resonances = .true. read (unit, "(A)") buffer else object%requires_resonances = .false. end if call strip_equation_lhs (buffer) read (buffer(3:34), "(A32)") object%md5sum if (object%n_initial > 0) then allocate (object%initial (object%n_initial)) do i = 1, object%n_initial read (unit, "(A)") buffer write (ref, "(1x,A,I0)") "Component #", i if (buffer /= ref) return ! Wrong component header call object%initial(i)%read (unit, core_def_templates) end do end if end subroutine process_def_read @ %def process_def_read @ Short account. <>= procedure :: show => process_def_show <>= module subroutine process_def_show (object, unit) class(process_def_t), intent(in) :: object integer, intent(in) :: unit end subroutine process_def_show <>= module subroutine process_def_show (object, unit) class(process_def_t), intent(in) :: object integer, intent(in) :: unit integer :: i write (unit, "(4x,A)", advance="no") char (object%id) if (object%num_id /= 0) & write (unit, "(1x,'(',I0,')')", advance="no") object%num_id if (object%model_name /= "") & write (unit, "(1x,'[',A,']')", advance="no") char (object%model_name) if (object%requires_resonances) then write (unit, "(1x,A)", advance="no") "[+ resonant subprocesses]" end if write (unit, *) if (allocated (object%initial)) then do i = 1, size (object%initial) call object%initial(i)%show (unit) end do end if if (allocated (object%extra)) then do i = 1, size (object%extra) call object%extra(i)%show (unit) end do end if end subroutine process_def_show @ %def process_def_show @ Initialize an entry (initialize the process definition inside). We allocate the 'initial' set of components. Extra components remain unallocated. The model should be present as a pointer. This allows us to retrieve the model's MD5 sum. However, for various tests it is sufficient to have the name. We create the basenames for the process components by appending a suffix which we increment for each component. <>= procedure :: init => process_def_init <>= module subroutine process_def_init (def, id, & model, model_name, n_in, n_components, num_id, & nlo_process, negative_sf, requires_resonances) 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 integer, intent(in), optional :: num_id logical, intent(in), optional :: nlo_process logical, intent(in), optional :: negative_sf logical, intent(in), optional :: requires_resonances end subroutine process_def_init <>= module subroutine process_def_init (def, id, & model, model_name, n_in, n_components, num_id, & nlo_process, negative_sf, requires_resonances) 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 integer, intent(in), optional :: num_id logical, intent(in), optional :: nlo_process logical, intent(in), optional :: negative_sf logical, intent(in), optional :: requires_resonances character(16) :: suffix integer :: i if (present (id)) then def%id = id else def%id = "" end if if (present (num_id)) then def%num_id = num_id end if if (present (model)) then def%model => model def%model_name = model%get_name () 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 if (present (nlo_process)) then def%nlo_process = nlo_process end if if (present (negative_sf)) then def%negative_sf = negative_sf end if if (present (requires_resonances)) then def%requires_resonances = requires_resonances 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 @ %def process_def_init @ Explicitly set the model name (for unit test). <>= procedure :: set_model_name => process_def_set_model_name <>= module subroutine process_def_set_model_name (def, model_name) class(process_def_t), intent(inout) :: def type(string_t), intent(in) :: model_name end subroutine process_def_set_model_name <>= module subroutine process_def_set_model_name (def, model_name) class(process_def_t), intent(inout) :: def type(string_t), intent(in) :: model_name def%model_name = model_name end subroutine process_def_set_model_name @ %def process_def_set_model_name @ Initialize an initial component. The particle content must be specified. The process core block is not (yet) allocated. We assume that the particle arrays match the [[n_in]] and [[n_out]] values in size. The model is referred to by name; it is identified as an existing model later. The index [[i]] must refer to an existing element of the component array. Data specific for the process core of a component are imported as the [[core_def]] argument. We should allocate an object of class [[prc_core_def_t]] with the appropriate specific type, fill it, and transfer it to the process component definition here. The allocation is moved, so the original allocated object is returned empty. <>= procedure :: import_component => process_def_import_component <>= module subroutine process_def_import_component (def, & i, n_out, prt_in, prt_out, method, variant, & nlo_type, can_be_integrated) 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 integer, intent(in), optional :: nlo_type logical, intent(in), optional :: can_be_integrated class(prc_core_def_t), & intent(inout), allocatable, optional :: variant end subroutine process_def_import_component <>= module subroutine process_def_import_component (def, & i, n_out, prt_in, prt_out, method, variant, & nlo_type, can_be_integrated) 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 integer, intent(in), optional :: nlo_type logical, intent(in), optional :: can_be_integrated type(string_t) :: nlo_type_string 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 if (present (nlo_type)) then comp%nlo_type = nlo_type end if if (present (can_be_integrated)) then comp%active = can_be_integrated else comp%active = .true. end if 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 if (comp%method /= "") then if ((def%nlo_process .and. .not. comp%active) .or. & comp%nlo_type == NLO_SUBTRACTION) then d = d // " [inactive]" else d = d // " [" // comp%method // "]" end if end if nlo_type_string = component_status (comp%nlo_type) if (nlo_type_string /= "born") then d = d // ", [" // nlo_type_string // "]" end if end associate end if end associate end subroutine process_def_import_component @ %def process_def_import_component @ <>= procedure :: get_n_components => process_def_get_n_components <>= module function process_def_get_n_components (def) result (n) class(process_def_t), intent(in) :: def integer :: n end function process_def_get_n_components <>= module function process_def_get_n_components (def) result (n) class(process_def_t), intent(in) :: def integer :: n n = size (def%initial) end function process_def_get_n_components @ %def process_def_get_n_components @ <>= procedure :: set_fixed_emitter => process_def_set_fixed_emitter <>= module subroutine process_def_set_fixed_emitter (def, i, emitter) class(process_def_t), intent(inout) :: def integer, intent(in) :: i, emitter end subroutine process_def_set_fixed_emitter <>= module subroutine process_def_set_fixed_emitter (def, i, emitter) class(process_def_t), intent(inout) :: def integer, intent(in) :: i, emitter def%initial(i)%fixed_emitter = emitter end subroutine process_def_set_fixed_emitter @ %def process_def_set_fixed_emitter @ <>= procedure :: set_coupling_powers => process_def_set_coupling_powers <>= module subroutine process_def_set_coupling_powers (def, alpha_power, alphas_power) class(process_def_t), intent(inout) :: def integer, intent(in) :: alpha_power, alphas_power end subroutine process_def_set_coupling_powers <>= module subroutine process_def_set_coupling_powers (def, alpha_power, alphas_power) class(process_def_t), intent(inout) :: def integer, intent(in) :: alpha_power, alphas_power def%initial(1)%alpha_power = alpha_power def%initial(1)%alphas_power = alphas_power end subroutine process_def_set_coupling_powers @ %def process_def_set_coupling_powers @ <>= procedure :: set_associated_components => & process_def_set_associated_components <>= module subroutine process_def_set_associated_components (def, i, & i_list, remnant, real_finite, mismatch) class(process_def_t), intent(inout) :: def logical, intent(in) :: remnant, real_finite, mismatch integer, intent(in) :: i integer, dimension(:), intent(in) :: i_list end subroutine process_def_set_associated_components <>= module subroutine process_def_set_associated_components (def, i, & i_list, remnant, real_finite, mismatch) class(process_def_t), intent(inout) :: def logical, intent(in) :: remnant, real_finite, mismatch integer, intent(in) :: i integer, dimension(:), intent(in) :: i_list integer :: add_index add_index = 0 associate (comp => def%initial(i)%associated_components) comp(ASSOCIATED_BORN) = i_list(1) comp(ASSOCIATED_REAL) = i_list(2) comp(ASSOCIATED_VIRT) = i_list(3) comp(ASSOCIATED_SUB) = i_list(4) if (remnant) then comp(ASSOCIATED_PDF) = i_list(5) add_index = add_index + 1 end if if (real_finite) then comp(ASSOCIATED_REAL_FIN) = i_list(5+add_index) add_index = add_index + 1 end if if (mismatch) then !!! incomplete end if end associate end subroutine process_def_set_associated_components @ %def process_def_set_associated_components @ Compute the MD5 sum for this process definition. We compute the MD5 sums for all components individually, than concatenate a string of those and compute the MD5 sum of this string. We also include the model name. All other data part of the component definitions. <>= procedure :: compute_md5sum => process_def_compute_md5sum <>= module subroutine process_def_compute_md5sum (def, model) class(process_def_t), intent(inout) :: def class(model_data_t), intent(in), optional, target :: model end subroutine process_def_compute_md5sum <>= module subroutine process_def_compute_md5sum (def, model) class(process_def_t), intent(inout) :: def class(model_data_t), intent(in), optional, target :: model integer :: i type(string_t) :: buffer buffer = def%model_name do i = 1, def%n_initial call def%initial(i)%compute_md5sum (model) buffer = buffer // def%initial(i)%md5sum end do do i = 1, def%n_extra call def%extra(i)%compute_md5sum (model) buffer = buffer // def%initial(i)%md5sum end do def%md5sum = md5sum (char (buffer)) end subroutine process_def_compute_md5sum @ %def process_def_compute_md5sum @ Return the MD5 sum of the process or of a process component. <>= procedure :: get_md5sum => process_def_get_md5sum <>= module function process_def_get_md5sum (def, i_component) result (md5sum) class(process_def_t), intent(in) :: def integer, intent(in), optional :: i_component character(32) :: md5sum end function process_def_get_md5sum <>= module function process_def_get_md5sum (def, i_component) result (md5sum) class(process_def_t), intent(in) :: def integer, intent(in), optional :: i_component character(32) :: md5sum if (present (i_component)) then md5sum = def%initial(i_component)%md5sum else md5sum = def%md5sum end if end function process_def_get_md5sum @ %def process_def_get_md5sum @ Return a pointer to the definition of a particular component (for test purposes). <>= procedure :: get_core_def_ptr => process_def_get_core_def_ptr <>= module function process_def_get_core_def_ptr (def, i_component) result (ptr) class(process_def_t), intent(in), target :: def integer, intent(in) :: i_component class(prc_core_def_t), pointer :: ptr end function process_def_get_core_def_ptr <>= module function process_def_get_core_def_ptr (def, i_component) result (ptr) class(process_def_t), intent(in), target :: def integer, intent(in) :: i_component class(prc_core_def_t), pointer :: ptr ptr => def%initial(i_component)%get_core_def_ptr () end function process_def_get_core_def_ptr @ %def process_def_get_core_def_ptr @ This query tells whether a specific process component relies on external code. This includes all traditional WHIZARD matrix elements which rely on \oMega\ for code generation. Other process components (trivial decays, subtraction terms) do not require external code. NOTE: Implemented only for initial component. The query is passed to the process component. <>= procedure :: needs_code => process_def_needs_code <>= module function process_def_needs_code (def, i_component) result (flag) class(process_def_t), intent(in) :: def integer, intent(in) :: i_component logical :: flag end function process_def_needs_code <>= module function process_def_needs_code (def, i_component) result (flag) class(process_def_t), intent(in) :: def integer, intent(in) :: i_component logical :: flag flag = def%initial(i_component)%needs_code () end function process_def_needs_code @ %def process_def_needs_code @ Return the first entry for the incoming particle(s), PDG code, of this process. <>= procedure :: get_pdg_in_1 => process_def_get_pdg_in_1 <>= module subroutine process_def_get_pdg_in_1 (def, pdg) class(process_def_t), intent(in), target :: def integer, dimension(:), intent(out) :: pdg end subroutine process_def_get_pdg_in_1 <>= module subroutine process_def_get_pdg_in_1 (def, pdg) class(process_def_t), intent(in), target :: def integer, dimension(:), intent(out) :: pdg call def%initial(1)%get_pdg_in (def%model, pdg) end subroutine process_def_get_pdg_in_1 @ %def process_def_get_pdg_in_1 @ <>= procedure :: is_nlo => process_def_is_nlo <>= elemental module function process_def_is_nlo (def) result (flag) logical :: flag class(process_def_t), intent(in) :: def end function process_def_is_nlo <>= elemental module function process_def_is_nlo (def) result (flag) logical :: flag class(process_def_t), intent(in) :: def flag = def%nlo_process end function process_def_is_nlo @ %def process_def_is_nlo @ <>= procedure :: get_nlo_type => process_def_get_nlo_type <>= elemental module function process_def_get_nlo_type (def, i_component) result (nlo_type) integer :: nlo_type class(process_def_t), intent(in) :: def integer, intent(in) :: i_component end function process_def_get_nlo_type <>= elemental module function process_def_get_nlo_type (def, i_component) result (nlo_type) integer :: nlo_type class(process_def_t), intent(in) :: def integer, intent(in) :: i_component nlo_type = def%initial(i_component)%nlo_type end function process_def_get_nlo_type @ %def process_def_get_nlo_type @ <>= procedure :: get_negative_sf => process_def_get_negative_sf <>= elemental module function process_def_get_negative_sf (def) result (neg_sf) logical :: neg_sf class(process_def_t), intent(in) :: def end function process_def_get_negative_sf <>= elemental module function process_def_get_negative_sf (def) result (neg_sf) logical :: neg_sf class(process_def_t), intent(in) :: def neg_sf = def%negative_sf end function process_def_get_negative_sf @ %def process_def_get_negative_sf @ Number of incoming particles, common to all components. <>= procedure :: get_n_in => process_def_get_n_in <>= module function process_def_get_n_in (def) result (n_in) class(process_def_t), intent(in) :: def integer :: n_in end function process_def_get_n_in <>= module 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 @ %def process_def_get_n_in @ Pointer to a particular component definition record. <>= procedure :: get_component_def_ptr => process_def_get_component_def_ptr <>= module function process_def_get_component_def_ptr (def, i) result (component) type(process_component_def_t), pointer :: component class(process_def_t), intent(in), target :: def integer, intent(in) :: i end function process_def_get_component_def_ptr <>= module function process_def_get_component_def_ptr (def, i) result (component) type(process_component_def_t), pointer :: component class(process_def_t), intent(in), target :: def integer, intent(in) :: i if (i <= def%n_initial) then component => def%initial(i) else component => null () end if end function process_def_get_component_def_ptr @ %def process_def_get_component_def_ptr @ \subsubsection{Process definition list} A list of process definitions is the starting point for creating a process library. The list is built when reading the user input. When reading an existing process library, the list is used for cross-checking and updating the configuration. We need a type for the list entry. The simplest way is to extend the process definition type, so all methods apply to the process definition directly. <>= public :: process_def_entry_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 @ %def process_def_entry_t @ This is the type for the list itself. <>= public :: process_def_list_t <>= type :: process_def_list_t private type(process_def_entry_t), pointer :: first => null () type(process_def_entry_t), pointer :: last => null () contains <> end type process_def_list_t @ %def process_def_list_t @ The deallocates the list iteratively. We assume that the list entries do not need finalization themselves. <>= procedure :: final => process_def_list_final <>= module subroutine process_def_list_final (list) class(process_def_list_t), intent(inout) :: list end subroutine process_def_list_final <>= module subroutine process_def_list_final (list) class(process_def_list_t), intent(inout) :: list type(process_def_entry_t), pointer :: current nullify (list%last) do while (associated (list%first)) current => list%first list%first => current%next deallocate (current) end do end subroutine process_def_list_final @ %def process_def_list_final @ Write the complete list. <>= procedure :: write => process_def_list_write <>= module subroutine process_def_list_write (object, unit, libpath) class(process_def_list_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: libpath end subroutine process_def_list_write <>= module subroutine process_def_list_write (object, unit, libpath) class(process_def_list_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: libpath type(process_def_entry_t), pointer :: entry integer :: i, u u = given_output_unit (unit) if (associated (object%first)) then i = 1 entry => object%first do while (associated (entry)) write (u, "(1x,A,I0,A)") "Process #", i, ":" call entry%write (u) i = i + 1 entry => entry%next if (associated (entry)) write (u, *) end do else write (u, "(1x,A)") "Process definition list: [empty]" end if end subroutine process_def_list_write @ %def process_def_list_write @ Short account. <>= procedure :: show => process_def_list_show <>= module subroutine process_def_list_show (object, unit) class(process_def_list_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine process_def_list_show <>= module subroutine process_def_list_show (object, unit) class(process_def_list_t), intent(in) :: object integer, intent(in), optional :: unit type(process_def_entry_t), pointer :: entry integer :: u u = given_output_unit (unit) if (associated (object%first)) then write (u, "(2x,A)") "Processes:" entry => object%first do while (associated (entry)) call entry%show (u) entry => entry%next end do else write (u, "(2x,A)") "Processes: [empty]" end if end subroutine process_def_list_show @ %def process_def_list_show @ Read the complete list. We need an array of templates for the component subobjects of abstract [[prc_core_t]] type, to allocate them with the correct specific type. NOTE: Error handling is missing. Reading will just be aborted on error, or an I/O error occurs. <>= procedure :: read => process_def_list_read <>= module subroutine process_def_list_read (object, unit, core_def_templates) class(process_def_list_t), intent(out) :: object integer, intent(in) :: unit type(prc_template_t), dimension(:), intent(in) :: core_def_templates end subroutine process_def_list_read <>= module subroutine process_def_list_read (object, unit, core_def_templates) class(process_def_list_t), intent(out) :: object integer, intent(in) :: unit type(prc_template_t), dimension(:), intent(in) :: core_def_templates type(process_def_entry_t), pointer :: entry character(80) :: buffer, ref integer :: i read (unit, "(A)") buffer write (ref, "(1x,A)") "Process definition list: [empty]" if (buffer == ref) return ! OK: empty library backspace (unit) - READ_ENTRIES: do i = 1, huge (0) + READ_ENTRIES: do i = 1, huge(0)-1 if (i > 1) read (unit, *, end=1) read (unit, "(A)") buffer write (ref, "(1x,A,I0,A)") "Process #", i, ":" if (buffer /= ref) return ! Wrong process header: done. allocate (entry) call entry%read (unit, core_def_templates) call object%append (entry) end do READ_ENTRIES 1 continue ! EOF: done end subroutine process_def_list_read @ %def process_def_list_read @ Append an entry to the list. The entry should be allocated as a pointer, and the pointer allocation is transferred. The original pointer is returned null. <>= procedure :: append => process_def_list_append <>= module subroutine process_def_list_append (list, entry) class(process_def_list_t), intent(inout) :: list type(process_def_entry_t), intent(inout), pointer :: entry end subroutine process_def_list_append <>= module 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 (list%contains (entry%id)) then call msg_fatal ("Recording process: '" // char (entry%id) & // "' has already been defined") end if 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 @ %def process_def_list_append @ \subsubsection{Probe the process definition list} Return the number of processes supported by the library. <>= procedure :: get_n_processes => process_def_list_get_n_processes <>= module function process_def_list_get_n_processes (list) result (n) integer :: n class(process_def_list_t), intent(in) :: list end function process_def_list_get_n_processes <>= module function process_def_list_get_n_processes (list) result (n) integer :: n class(process_def_list_t), intent(in) :: list type(process_def_entry_t), pointer :: current n = 0 current => list%first do while (associated (current)) n = n + 1 current => current%next end do end function process_def_list_get_n_processes @ %def process_def_list_get_n_processes @ Allocate an array with the process IDs supported by the library. <>= procedure :: get_process_id_list => process_def_list_get_process_id_list <>= module subroutine process_def_list_get_process_id_list (list, id) class(process_def_list_t), intent(in) :: list type(string_t), dimension(:), allocatable, intent(out) :: id end subroutine process_def_list_get_process_id_list <>= module subroutine process_def_list_get_process_id_list (list, id) class(process_def_list_t), intent(in) :: list type(string_t), dimension(:), allocatable, intent(out) :: id type(process_def_entry_t), pointer :: current integer :: i allocate (id (list%get_n_processes ())) i = 0 current => list%first do while (associated (current)) i = i + 1 id(i) = current%id current => current%next end do end subroutine process_def_list_get_process_id_list @ %def process_def_list_get_process_id_list @ Return just the processes which require resonant subprocesses. <>= procedure :: get_process_id_req_resonant => & process_def_list_get_process_id_req_resonant <>= module subroutine process_def_list_get_process_id_req_resonant (list, id) class(process_def_list_t), intent(in) :: list type(string_t), dimension(:), allocatable, intent(out) :: id end subroutine process_def_list_get_process_id_req_resonant <>= module subroutine process_def_list_get_process_id_req_resonant (list, id) class(process_def_list_t), intent(in) :: list type(string_t), dimension(:), allocatable, intent(out) :: id type(process_def_entry_t), pointer :: current integer :: i allocate (id (list%get_n_processes ())) i = 0 current => list%first do while (associated (current)) if (current%requires_resonances) then i = i + 1 id(i) = current%id end if current => current%next end do id = id(1:i) end subroutine process_def_list_get_process_id_req_resonant @ %def process_def_list_get_process_id_list @ Return a pointer to a particular process entry. <>= procedure :: get_process_def_ptr => process_def_list_get_process_def_ptr <>= module 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 end function process_def_list_get_process_def_ptr <>= module 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 @ %def process_def_list_get_process_def_ptr @ Return true if a given process is in the library. <>= procedure :: contains => process_def_list_contains <>= module function process_def_list_contains (list, id) result (flag) logical :: flag class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id end function process_def_list_contains <>= module function process_def_list_contains (list, id) result (flag) logical :: flag 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) flag = associated (current) end function process_def_list_contains @ %def process_def_list_contains @ Return the index of the entry that corresponds to a given process. <>= procedure :: get_entry_index => process_def_list_get_entry_index <>= module function process_def_list_get_entry_index (list, id) result (n) integer :: n class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id end function process_def_list_get_entry_index <>= module function process_def_list_get_entry_index (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 n = 0 current => list%first do while (associated (current)) n = n + 1 if (id == current%id) then return end if current => current%next end do n = 0 end function process_def_list_get_entry_index @ %def process_def_list_get_entry_index @ Return the numerical ID for a process. <>= procedure :: get_num_id => process_def_list_get_num_id <>= module function process_def_list_get_num_id (list, id) result (num_id) integer :: num_id class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id end function process_def_list_get_num_id <>= module function process_def_list_get_num_id (list, id) result (num_id) integer :: num_id 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 num_id = current%num_id else num_id = 0 end if end function process_def_list_get_num_id @ %def process_def_list_get_num_id @ Return the model name for a given process in the library. <>= procedure :: get_model_name => process_def_list_get_model_name <>= module function process_def_list_get_model_name (list, id) result (model_name) type(string_t) :: model_name class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id end function process_def_list_get_model_name <>= module function process_def_list_get_model_name (list, id) result (model_name) type(string_t) :: model_name 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 model_name = current%model_name else model_name = "" end if end function process_def_list_get_model_name @ %def process_def_list_get_model_name @ Return the number of incoming particles of a given process in the library. This tells us whether the process is a decay or a scattering. <>= procedure :: get_n_in => process_def_list_get_n_in <>= module 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 end function process_def_list_get_n_in <>= module 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 @ %def process_def_list_get_n_in @ Return the incoming particle pdg codesnumber of incoming particles of a given process in the library. If there is a PDG array, return only the first code for each beam. This serves as a quick way for (re)constructing beam properties. <>= procedure :: get_pdg_in_1 => process_def_list_get_pdg_in_1 <>= module subroutine process_def_list_get_pdg_in_1 (list, id, pdg) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id integer, dimension(:), intent(out) :: pdg end subroutine process_def_list_get_pdg_in_1 <>= module subroutine process_def_list_get_pdg_in_1 (list, id, pdg) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id integer, dimension(:), intent(out) :: pdg type(process_def_entry_t), pointer :: current current => list%get_process_def_ptr (id) if (associated (current)) then call current%get_pdg_in_1 (pdg) else pdg = 0 end if end subroutine process_def_list_get_pdg_in_1 @ %def process_def_list_get_pdg_in_1 @ Return the list of component IDs of a given process in the library. <>= procedure :: get_component_list => process_def_list_get_component_list <>= module subroutine process_def_list_get_component_list (list, id, cid) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(string_t), dimension(:), allocatable, intent(out) :: cid end subroutine process_def_list_get_component_list <>= module subroutine process_def_list_get_component_list (list, id, cid) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(string_t), dimension(:), allocatable, intent(out) :: cid type(process_def_entry_t), pointer :: current integer :: i, n current => list%get_process_def_ptr (id) if (associated (current)) then allocate (cid (current%n_initial + current%n_extra)) do i = 1, current%n_initial cid(i) = current%initial(i)%basename end do n = current%n_initial do i = 1, current%n_extra cid(n + i) = current%extra(i)%basename end do end if end subroutine process_def_list_get_component_list @ %def process_def_list_get_component_list @ Return the list of component description strings for a given process in the library. <>= procedure :: get_component_description_list => & process_def_list_get_component_description_list <>= module subroutine process_def_list_get_component_description_list & (list, id, description) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(string_t), dimension(:), allocatable, intent(out) :: description end subroutine process_def_list_get_component_description_list <>= module subroutine process_def_list_get_component_description_list & (list, id, description) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(string_t), dimension(:), allocatable, intent(out) :: description type(process_def_entry_t), pointer :: current integer :: i, n current => list%get_process_def_ptr (id) if (associated (current)) then allocate (description (current%n_initial + current%n_extra)) do i = 1, current%n_initial description(i) = current%initial(i)%description end do n = current%n_initial do i = 1, current%n_extra description(n + i) = current%extra(i)%description end do end if end subroutine process_def_list_get_component_description_list @ %def process_def_list_get_component_description_list @ Return whether the entry requires construction of a resonanct subprocess set. <>= procedure :: req_resonant => process_def_list_req_resonant <>= module function process_def_list_req_resonant (list, id) result (flag) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id logical :: flag end function process_def_list_req_resonant <>= module function process_def_list_req_resonant (list, id) result (flag) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id logical :: flag type(process_def_entry_t), pointer :: current current => list%get_process_def_ptr (id) if (associated (current)) then flag = current%requires_resonances else flag = .false. end if end function process_def_list_req_resonant @ %def process_def_list_req_resonant @ \subsection{Process library} The process library object is the interface between the process definition data, as provided by the user, generated or linked process code on file, and the process run data that reference the process code. \subsubsection{Process library entry} For each process component that is part of the library, there is a separate library entry ([[process_library_entry_t]]. The library entry connects a process definition with the specific code (if any) in the compiled driver library. The [[status]] indicates how far the process has been processed by the system (definition, code generation, compilation, linking). A process with status [[STAT_LOADED]] is accessible for computing matrix elements. The [[def]] pointer identifies the corresponding process definition. The process component within that definition is identified by the [[i_component]] index. The [[i_external]] index refers to the compiled library driver. If it is zero, there is no associated matrix-element code. The [[driver]] component holds the pointers to the matrix-element specific functions, in particular the matrix element function itself. <>= 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 <> end type process_library_entry_t @ %def process_library_entry_t @ Here are the available status codes. An entry starts with [[UNKNOWN]] status. Once the association with a valid process definition is established, the status becomes [[CONFIGURED]]. If matrix element source code is to be generated by the system or provided from elsewhere, [[CODE_GENERATED]] indicates that this is done. The [[COMPILED]] status is next, it also applies to processes which are accessed as precompiled binaries. Finally, the library is linked and process pointers are set; this is marked as [[LOADED]]. For a process library, the initial status is [[OPEN]], since process definitions may be added. After configuration, the process content is fixed and the status becomes [[CONFIGURED]]. The further states are as above, always referring to the lowest status among the process entries. <>= 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 integer, parameter, public :: ASSOCIATED_BORN = 1 integer, parameter, public :: ASSOCIATED_REAL = 2 integer, parameter, public :: ASSOCIATED_VIRT = 3 integer, parameter, public :: ASSOCIATED_SUB = 4 integer, parameter, public :: ASSOCIATED_PDF = 5 integer, parameter, public :: ASSOCIATED_REAL_SING = 6 integer, parameter, public :: ASSOCIATED_REAL_FIN = 7 integer, parameter, public :: N_ASSOCIATED_COMPONENTS = 7 @ %def STAT_UNKNOWN STAT_OPEN STAT_CONFIGURED @ %def STAT_SOURCE STAT_COMPILED STAT_LINKED STAT_ACTIVE @ These are the associated code letters, for output: <>= character, dimension(0:6), parameter :: STATUS_LETTER = & ["?", "o", "f", "s", "c", "l", "a"] @ %def STATUS_LETTER @ This produces a condensed account of the library entry. The status is indicated by a letter in brackets, then the ID and component index of the associated process definition, finally the library index, if available. <>= procedure :: to_string => process_library_entry_to_string <>= module function process_library_entry_to_string (object) result (string) type(string_t) :: string class(process_library_entry_t), intent(in) :: object end function process_library_entry_to_string <>= module function process_library_entry_to_string (object) result (string) type(string_t) :: string class(process_library_entry_t), intent(in) :: object character(32) :: buffer string = "[" // STATUS_LETTER(object%status) // "]" select case (object%status) case (STAT_UNKNOWN) case default if (associated (object%def)) then write (buffer, "(I0)") object%i_component string = string // " " // object%def%id // "." // trim (buffer) end if if (object%i_external /= 0) then write (buffer, "(I0)") object%i_external string = string // " = ext:" // trim (buffer) else string = string // " = int" end if if (allocated (object%driver)) then string = string // " (" // object%driver%type_name () // ")" end if end select end function process_library_entry_to_string @ %def process_library_entry_to_string @ Initialize with data. Used for the unit tests. <>= procedure :: init => process_library_entry_init <>= module 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 end subroutine process_library_entry_init <>= module 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 @ %def process_library_entry_init @ Assign pointers for all process-specific features. We have to combine the method from the [[core_def]] specification, the assigned pointers within the library driver, the index within that driver, and the process driver which should receive the links. <>= procedure :: connect => process_library_entry_connect <>= module subroutine process_library_entry_connect (entry, lib_driver, i) class(process_library_entry_t), intent(inout) :: entry class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i end subroutine process_library_entry_connect <>= module subroutine process_library_entry_connect (entry, lib_driver, i) class(process_library_entry_t), intent(inout) :: entry class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i call entry%def%initial(entry%i_component)%connect & (lib_driver, i, entry%driver) end subroutine process_library_entry_connect @ %def process_library_entry_connect @ \subsubsection{The process library object} The [[process_library_t]] type is an extension of the [[process_def_list_t]] type. Thus, it automatically contains the process definition list. The [[basename]] identifies the library generically. The [[external]] flag is true if any process within the library needs external code, so the library must correspond to an actual code library (statically or dynamically linked). The [[entry]] array contains all process components that can be handled by this library. Each entry refers to the process (component) definition and to the associated external matrix element code, if there is any. The [[driver]] object is needed only if [[external]] is true. This object handles all interactions with external matrix-element code. The [[md5sum]] summarizes the complete [[process_def_list_t]] base object. It can be used to check if the library configuration has changed. <>= public :: process_library_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 character(32) :: md5sum = "" contains <> end type process_library_t @ %def process_library_t @ For the output, we write first the metadata and the DL access record, then the library entries in short form, and finally the process definition list which is the base object. Don't write the MD5 sum since this is used to generate it. <>= procedure :: write => process_library_write <>= module subroutine process_library_write (object, unit, libpath) class(process_library_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: libpath end subroutine process_library_write <>= module subroutine process_library_write (object, unit, libpath) class(process_library_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: libpath integer :: i, u u = given_output_unit (unit) write (u, "(1x,A,A)") "Process library: ", char (object%basename) write (u, "(3x,A,L1)") "external = ", object%external write (u, "(3x,A,L1)") "makefile exists = ", object%makefile_exists write (u, "(3x,A,L1)") "driver exists = ", object%driver_exists write (u, "(3x,A,A1)") "code status = ", & STATUS_LETTER (object%status) write (u, *) if (allocated (object%entry)) then write (u, "(1x,A)", advance="no") "Process library entries:" write (u, "(1x,I0)") object%n_entries do i = 1, size (object%entry) write (u, "(1x,A,I0,A,A)") "Entry #", i, ": ", & char (object%entry(i)%to_string ()) end do write (u, *) end if if (object%external) then call object%driver%write (u, libpath) write (u, *) end if call object%process_def_list_t%write (u) end subroutine process_library_write @ %def process_library_write @ Condensed version for screen output. <>= procedure :: show => process_library_show <>= module subroutine process_library_show (object, unit) class(process_library_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine process_library_show <>= module subroutine process_library_show (object, unit) class(process_library_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(A,A)") "Process library: ", char (object%basename) write (u, "(2x,A,L1)") "external = ", object%external if (object%static) then write (u, "(2x,A,L1)") "static = ", .true. else write (u, "(2x,A,L1)") "makefile exists = ", object%makefile_exists write (u, "(2x,A,L1)") "driver exists = ", object%driver_exists end if write (u, "(2x,A,A1)", advance="no") "code status = " select case (object%status) case (STAT_UNKNOWN); write (u, "(A)") "[unknown]" case (STAT_OPEN); write (u, "(A)") "open" case (STAT_CONFIGURED); write (u, "(A)") "configured" case (STAT_SOURCE); write (u, "(A)") "source code exists" case (STAT_COMPILED); write (u, "(A)") "compiled" case (STAT_LINKED); write (u, "(A)") "linked" case (STAT_ACTIVE); write (u, "(A)") "active" end select call object%process_def_list_t%show (u) end subroutine process_library_show @ %def process_library_show @ The initializer defines just the basename. We may now add process definitions to the library. <>= procedure :: init => process_library_init <>= module subroutine process_library_init (lib, basename) class(process_library_t), intent(out) :: lib type(string_t), intent(in) :: basename end subroutine process_library_init <>= module 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 call msg_message ("Process library '" // char (basename) & // "': initialized") end subroutine process_library_init @ %def process_library_init @ This alternative initializer declares the library as static. We should now add process definitions to the library, but all external process code exists already. We need the driver object, and we should check the defined processes against the stored ones. <>= procedure :: init_static => process_library_init_static <>= module subroutine process_library_init_static (lib, basename) class(process_library_t), intent(out) :: lib type(string_t), intent(in) :: basename end subroutine process_library_init_static <>= module subroutine process_library_init_static (lib, basename) class(process_library_t), intent(out) :: lib type(string_t), intent(in) :: basename lib%basename = basename lib%status = STAT_OPEN lib%static = .true. call msg_message ("Static process library '" // char (basename) & // "': initialized") end subroutine process_library_init_static @ %def process_library_init_static @ The [[configure]] procedure scans the allocated entries in the process definition list. The configuration proceeds in three passes. In the first pass, we scan the process definition list and count the number of process components and the number of components which need external code. This is used to allocate the [[entry]] array. In the second pass, we initialize the [[entry]] elements which connect process definitions, process driver objects, and external code. In the third pass, we initialize the library driver object, allocating an entry for each external matrix element. NOTE: Currently we handle only [[initial]] process components; [[extra]] components are ignored. <>= procedure :: configure => process_library_configure <>= module subroutine process_library_configure (lib, os_data) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data end subroutine process_library_configure <>= module subroutine process_library_configure (lib, os_data) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data 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 if (def_entry%initial(i_component)%needs_code ()) then n_external = n_external + 1 lib%external = .true. end if 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 if (def_entry%initial(i_component)%needs_code ()) then i_external = i_external + 1 lib_entry%i_external = i_external end if call def_entry%initial(i_component)%allocate_driver & (lib_entry%driver) end associate end do def_entry => def_entry%next end do call dispatch_prclib_driver (lib%driver, & lib%basename, lib%get_modellibs_ldflags (os_data)) call lib%driver%init (n_external) 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 associate (def => lib_entry%def%initial(i_component)) if (def%needs_code ()) then call lib%driver%set_record (lib_entry%i_external, & def%basename, & model_name, & def%get_features (), def%get_writer_ptr ()) end if end associate end associate end do if (lib%static) then if (lib%n_entries /= 0) lib%entry%status = STAT_LINKED lib%status = STAT_LINKED else if (lib%external) then where (lib%entry%i_external == 0) lib%entry%status = STAT_LINKED lib%status = STAT_CONFIGURED lib%makefile_exists = .false. lib%driver_exists = .false. else if (lib%n_entries /= 0) lib%entry%status = STAT_LINKED lib%status = STAT_LINKED end if end subroutine process_library_configure @ %def process_library_configure @ Basic setup: allocate the [[entry]] array. <>= procedure :: allocate_entries => process_library_allocate_entries <>= module subroutine process_library_allocate_entries (lib, n_entries) class(process_library_t), intent(inout) :: lib integer, intent(in) :: n_entries end subroutine process_library_allocate_entries <>= module 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 @ %def process_library_allocate_entries @ Initialize an entry with data (used by unit tests). <>= procedure :: init_entry => process_library_init_entry <>= module subroutine process_library_init_entry (lib, i, & status, def, i_component, i_external, driver_template) class(process_library_t), intent(inout) :: lib integer, intent(in) :: i 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 end subroutine process_library_init_entry <>= module subroutine process_library_init_entry (lib, i, & status, def, i_component, i_external, driver_template) class(process_library_t), intent(inout) :: lib integer, intent(in) :: i 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 call lib%entry(i)%init (status, def, i_component, i_external, & driver_template) end subroutine process_library_init_entry @ %def process_library_init_entry @ Compute the MD5 sum. We concatenate the individual MD5 sums of all processes (which, in turn, are derived from the MD5 sums of their components) and compute the MD5 sum of that. This should be executed \emph{after} configuration, where the driver was initialized, since otherwise the MD5 sum stored in the driver would be overwritten. <>= procedure :: compute_md5sum => process_library_compute_md5sum <>= module subroutine process_library_compute_md5sum (lib, model) class(process_library_t), intent(inout) :: lib class(model_data_t), intent(in), optional, target :: model end subroutine process_library_compute_md5sum <>= module subroutine process_library_compute_md5sum (lib, model) class(process_library_t), intent(inout) :: lib class(model_data_t), intent(in), optional, target :: model type(process_def_entry_t), pointer :: def_entry type(string_t) :: buffer buffer = lib%basename def_entry => lib%first do while (associated (def_entry)) call def_entry%compute_md5sum (model) buffer = buffer // def_entry%md5sum def_entry => def_entry%next end do lib%md5sum = md5sum (char (buffer)) call lib%driver%set_md5sum (lib%md5sum) end subroutine process_library_compute_md5sum @ %def process_library_compute_md5sum @ Write an appropriate makefile, if there are external processes. Unless [[force]] is in effect, first check if there is already a makefile with the correct MD5 sum. If yes, do nothing. The [[workspace]] optional argument puts any library code in a subdirectory. <>= procedure :: write_makefile => process_library_write_makefile <>= module subroutine process_library_write_makefile & (lib, os_data, force, verbose, testflag, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in) :: force, verbose logical, intent(in), optional :: testflag type(string_t), intent(in), optional :: workspace end subroutine process_library_write_makefile <>= module subroutine process_library_write_makefile & (lib, os_data, force, verbose, testflag, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in) :: force, verbose logical, intent(in), optional :: testflag type(string_t), intent(in), optional :: workspace character(32) :: md5sum_file logical :: generate integer :: unit if (lib%external .and. .not. lib%static) then generate = .true. if (.not. force) then md5sum_file = lib%driver%get_md5sum_makefile (workspace) if (lib%md5sum == md5sum_file) then call msg_message ("Process library '" // char (lib%basename) & // "': keeping makefile") generate = .false. end if end if if (generate) then call msg_message ("Process library '" // char (lib%basename) & // "': writing makefile") unit = free_unit () open (unit, & file = char (workspace_prefix (workspace) & & // lib%driver%basename // ".makefile"), & status="replace", action="write") call lib%driver%generate_makefile (unit, os_data, verbose, testflag) close (unit) end if lib%makefile_exists = .true. end if end subroutine process_library_write_makefile @ %def process_library_write_makefile @ @ Write the driver source code for the library to file, if there are external processes. <>= procedure :: write_driver => process_library_write_driver <>= module subroutine process_library_write_driver (lib, force, workspace) class(process_library_t), intent(inout) :: lib logical, intent(in) :: force type(string_t), intent(in), optional :: workspace end subroutine process_library_write_driver <>= module subroutine process_library_write_driver (lib, force, workspace) class(process_library_t), intent(inout) :: lib logical, intent(in) :: force type(string_t), intent(in), optional :: workspace character(32) :: md5sum_file logical :: generate integer :: unit if (lib%external .and. .not. lib%static) then generate = .true. if (.not. force) then md5sum_file = lib%driver%get_md5sum_driver (workspace) if (lib%md5sum == md5sum_file) then call msg_message ("Process library '" // char (lib%basename) & // "': keeping driver") generate = .false. end if end if if (generate) then call msg_message ("Process library '" // char (lib%basename) & // "': writing driver") unit = free_unit () open (unit, & file = char (workspace_prefix (workspace) & & // lib%driver%basename // ".f90"), & status="replace", action="write") call lib%driver%generate_driver_code (unit) close (unit) end if lib%driver_exists = .true. end if end subroutine process_library_write_driver @ %def process_library_write_driver @ Update the compilation status of an external library. Strictly speaking, this is not necessary for a one-time run, since the individual library methods will update the status themselves. However, it allows us to identify compilation steps that we can skip because the file exists or is already loaded, for the whole library or for particular entries. Independently, the building process is controlled by a makefile. Thus, previous files are reused if they are not modified by the current compilation. \begin{enumerate} \item If it is not already loaded, attempt to load the library. If successful, check the overall MD5 sum. If it matches, just keep it loaded and mark as ACTIVE. If not, check the MD5 sum for all linked process components. Where it matches, mark the entry as COMPILED. Then, unload the library and mark as CONFIGURED. Thus, we can identify compiled files for all matrix elements which are accessible via the previous compiled library, even if it is no longer up to date. \item If the library is now in CONFIGURED state, look for valid source files. Each entry that is just in CONFIGURED state will advance to SOURCE if the MD5 sum matches. Finally, advance the whole library to SOURCE if all entries are at least in this condition. \end{enumerate} <>= procedure :: update_status => process_library_update_status <>= module subroutine process_library_update_status (lib, os_data, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine process_library_update_status <>= module subroutine process_library_update_status (lib, os_data, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace character(32) :: md5sum_file integer :: i, i_external, i_component if (lib%external) then select case (lib%status) case (STAT_CONFIGURED:STAT_LINKED) call lib%driver%load (os_data, noerror=.true., workspace=workspace) end select if (lib%driver%loaded) then md5sum_file = lib%driver%get_md5sum (0) if (lib%md5sum == md5sum_file) then call lib%load_entries () lib%entry%status = STAT_ACTIVE lib%status = STAT_ACTIVE call msg_message ("Process library '" // char (lib%basename) & // "': active") else do i = 1, lib%n_entries associate (entry => lib%entry(i)) i_external = entry%i_external i_component = entry%i_component if (i_external /= 0) then md5sum_file = lib%driver%get_md5sum (i_external) if (entry%def%get_md5sum (i_component) == md5sum_file) then entry%status = STAT_COMPILED else entry%status = STAT_CONFIGURED end if end if end associate end do call lib%driver%unload () lib%status = STAT_CONFIGURED end if end if select case (lib%status) case (STAT_CONFIGURED) do i = 1, lib%n_entries associate (entry => lib%entry(i)) i_external = entry%i_external i_component = entry%i_component if (i_external /= 0) then select case (entry%status) case (STAT_CONFIGURED) md5sum_file = lib%driver%get_md5sum_source & (i_external, workspace) if (entry%def%get_md5sum (i_component) == md5sum_file) then entry%status = STAT_SOURCE end if end select end if end associate end do if (all (lib%entry%status >= STAT_SOURCE)) then md5sum_file = lib%driver%get_md5sum_driver (workspace) if (lib%md5sum == md5sum_file) then lib%status = STAT_SOURCE end if end if end select end if end subroutine process_library_update_status @ %def process_library_update_status @ This procedure triggers code generation for all processes where this is possible. We generate code only for external processes of status [[STAT_CONFIGURED]], which then advance to [[STAT_SOURCE]]. If, for a particular process, the status is already advanced, we do not remove previous files, so [[make]] will consider them as up to date if they exist. Otherwise, we remove those files to force a fresh [[make]]. Finally, if any source code has been generated, we need a driver file. <>= procedure :: make_source => process_library_make_source <>= module subroutine process_library_make_source & (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace end subroutine process_library_make_source <>= module subroutine process_library_make_source & (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace logical :: keep_old integer :: i, i_external keep_old = .false. if (present (keep_old_source)) keep_old = keep_old_source if (lib%external .and. .not. lib%static) then select case (lib%status) case (STAT_CONFIGURED) if (keep_old) then call msg_message ("Process library '" // char (lib%basename) & // "': keeping source code") else call msg_message ("Process library '" // char (lib%basename) & // "': creating source code") do i = 1, size (lib%entry) associate (entry => lib%entry(i)) i_external = entry%i_external if (i_external /= 0 & .and. lib%entry(i)%status == STAT_CONFIGURED) then call lib%driver%clean_proc & (i_external, os_data, workspace) end if end associate if (signal_is_pending ()) return end do call lib%driver%make_source (os_data, workspace) end if lib%status = STAT_SOURCE where (lib%entry%i_external /= 0 & .and. lib%entry%status == STAT_CONFIGURED) lib%entry%status = STAT_SOURCE end where lib%status = STAT_SOURCE end select end if end subroutine process_library_make_source @ %def process_library_make_source @ Compile the generated code and update the status codes. Try to make the sources first, just in case. This includes compiling possible \LaTeX Feynman diagram files. <>= procedure :: make_compile => process_library_make_compile <>= module subroutine process_library_make_compile & (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace end subroutine process_library_make_compile <>= module subroutine process_library_make_compile & (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace if (lib%external .and. .not. lib%static) then select case (lib%status) case (STAT_CONFIGURED) call lib%make_source (os_data, keep_old_source, workspace) end select if (signal_is_pending ()) return select case (lib%status) case (STAT_SOURCE) call msg_message ("Process library '" // char (lib%basename) & // "': compiling sources") call lib%driver%make_compile (os_data, workspace) where (lib%entry%i_external /= 0 & .and. lib%entry%status == STAT_SOURCE) lib%entry%status = STAT_COMPILED end where lib%status = STAT_COMPILED end select end if end subroutine process_library_make_compile @ %def process_library_make_compile @ Link the process library. Try to compile first, just in case. <>= procedure :: make_link => process_library_make_link <>= module subroutine process_library_make_link & (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace end subroutine process_library_make_link <>= module subroutine process_library_make_link & (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace if (lib%external .and. .not. lib%static) then select case (lib%status) case (STAT_CONFIGURED:STAT_SOURCE) call lib%make_compile (os_data, keep_old_source, workspace) end select if (signal_is_pending ()) return select case (lib%status) case (STAT_COMPILED) call msg_message ("Process library '" // char (lib%basename) & // "': linking") call lib%driver%make_link (os_data, workspace) lib%entry%status = STAT_LINKED lib%status = STAT_LINKED end select end if end subroutine process_library_make_link @ %def process_library_make_link @ Load the process library, i.e., assign pointers to the library functions. <>= procedure :: load => process_library_load <>= module subroutine process_library_load (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace end subroutine process_library_load <>= module subroutine process_library_load (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace select case (lib%status) case (STAT_CONFIGURED:STAT_COMPILED) call lib%make_link (os_data, keep_old_source, workspace) end select if (signal_is_pending ()) return select case (lib%status) case (STAT_LINKED) if (lib%external) then call msg_message ("Process library '" // char (lib%basename) & // "': loading") call lib%driver%load (os_data, workspace=workspace) call lib%load_entries () end if lib%entry%status = STAT_ACTIVE lib%status = STAT_ACTIVE end select end subroutine process_library_load @ %def process_library_load @ This is the actual loading part for the process methods. <>= procedure :: load_entries => process_library_load_entries <>= module subroutine process_library_load_entries (lib) class(process_library_t), intent(inout) :: lib end subroutine process_library_load_entries <>= module subroutine process_library_load_entries (lib) class(process_library_t), intent(inout) :: lib integer :: i do i = 1, size (lib%entry) associate (entry => lib%entry(i)) if (entry%i_external /= 0) then call entry%connect (lib%driver, entry%i_external) end if end associate end do end subroutine process_library_load_entries @ %def process_library_load_entries @ Unload the library, if possible. This reverts the status to ``linked''. <>= procedure :: unload => process_library_unload <>= module subroutine process_library_unload (lib) class(process_library_t), intent(inout) :: lib end subroutine process_library_unload <>= module subroutine process_library_unload (lib) class(process_library_t), intent(inout) :: lib select case (lib%status) case (STAT_ACTIVE) if (lib%external) then call msg_message ("Process library '" // char (lib%basename) & // "': unloading") call lib%driver%unload () end if lib%entry%status = STAT_LINKED lib%status = STAT_LINKED end select end subroutine process_library_unload @ %def process_library_unload @ Unload, clean all generated files and revert the library status. If [[distclean]] is set, also remove the makefile and the driver source. <>= procedure :: clean => process_library_clean <>= module subroutine process_library_clean (lib, os_data, distclean, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in) :: distclean type(string_t), intent(in), optional :: workspace end subroutine process_library_clean <>= module subroutine process_library_clean (lib, os_data, distclean, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in) :: distclean type(string_t), intent(in), optional :: workspace call lib%unload () if (lib%external .and. .not. lib%static) then call msg_message ("Process library '" // char (lib%basename) & // "': removing old files") if (distclean) then call lib%driver%distclean (os_data, workspace) else call lib%driver%clean (os_data, workspace) end if end if where (lib%entry%i_external /= 0) lib%entry%status = STAT_CONFIGURED elsewhere lib%entry%status = STAT_LINKED end where if (lib%external) then lib%status = STAT_CONFIGURED else lib%status = STAT_LINKED end if end subroutine process_library_clean @ %def process_library_clean @ Unload and revert the library status to INITIAL. This allows for appending new processes. No files are deleted. <>= procedure :: open => process_library_open <>= module subroutine process_library_open (lib) class(process_library_t), intent(inout) :: lib end subroutine process_library_open <>= module subroutine process_library_open (lib) class(process_library_t), intent(inout) :: lib select case (lib%status) case (STAT_OPEN) case default call lib%unload () if (.not. lib%static) then lib%entry%status = STAT_OPEN lib%status = STAT_OPEN if (lib%external) lib%update_counter = lib%update_counter + 1 call msg_message ("Process library '" // char (lib%basename) & // "': open") else call msg_error ("Static process library '" // char (lib%basename) & // "': processes can't be appended") end if end select end subroutine process_library_open @ %def process_library_open @ \subsection{Use the library} Return the base name of the library <>= procedure :: get_name => process_library_get_name <>= module function process_library_get_name (lib) result (name) class(process_library_t), intent(in) :: lib type(string_t) :: name end function process_library_get_name <>= module function process_library_get_name (lib) result (name) class(process_library_t), intent(in) :: lib type(string_t) :: name name = lib%basename end function process_library_get_name @ %def process_library_get_name @ Once activated, we view the process library object as an interface for accessing the matrix elements. <>= procedure :: is_active => process_library_is_active <>= module function process_library_is_active (lib) result (flag) logical :: flag class(process_library_t), intent(in) :: lib end function process_library_is_active <>= module function process_library_is_active (lib) result (flag) logical :: flag class(process_library_t), intent(in) :: lib flag = lib%status == STAT_ACTIVE end function process_library_is_active @ %def process_library_is_active @ Return the current status code of the library. If an index is provided, return the status of that entry. <>= procedure :: get_status => process_library_get_status <>= module function process_library_get_status (lib, i) result (status) class(process_library_t), intent(in) :: lib integer, intent(in), optional :: i integer :: status end function process_library_get_status <>= module function process_library_get_status (lib, i) result (status) class(process_library_t), intent(in) :: lib integer, intent(in), optional :: i integer :: status if (present (i)) then status = lib%entry(i)%status else status = lib%status end if end function process_library_get_status @ %def process_library_get_status @ Return the update counter. Since this is incremented each time the library is re-opened, we can use this to check if existing pointers to matrix element code are still valid. <>= procedure :: get_update_counter => process_library_get_update_counter <>= module function process_library_get_update_counter (lib) result (counter) class(process_library_t), intent(in) :: lib integer :: counter end function process_library_get_update_counter <>= module function process_library_get_update_counter (lib) result (counter) class(process_library_t), intent(in) :: lib integer :: counter counter = lib%update_counter end function process_library_get_update_counter @ %def process_library_get_update_counter @ Manually set the current status code of the library. If the optional flag is set, set also the entry status codes. This is used for unit tests. <>= procedure :: set_status => process_library_set_status <>= module subroutine process_library_set_status (lib, status, entries) class(process_library_t), intent(inout) :: lib integer, intent(in) :: status logical, intent(in), optional :: entries end subroutine process_library_set_status <>= module subroutine process_library_set_status (lib, status, entries) class(process_library_t), intent(inout) :: lib integer, intent(in) :: status logical, intent(in), optional :: entries lib%status = status if (present (entries)) then if (entries) lib%entry%status = status end if end subroutine process_library_set_status @ %def process_library_set_status @ Return the load status of the associated driver. <>= procedure :: is_loaded => process_library_is_loaded <>= module function process_library_is_loaded (lib) result (flag) class(process_library_t), intent(in) :: lib logical :: flag end function process_library_is_loaded <>= module function process_library_is_loaded (lib) result (flag) class(process_library_t), intent(in) :: lib logical :: flag flag = lib%driver%loaded end function process_library_is_loaded @ %def process_library_is_loaded @ Retrieve constants using the process library driver. We assume that the process code has been loaded, if external. <>= procedure :: fill_constants => process_library_entry_fill_constants <>= module subroutine process_library_entry_fill_constants (entry, driver, data) class(process_library_entry_t), intent(in) :: entry class(prclib_driver_t), intent(in) :: driver type(process_constants_t), intent(out) :: data end subroutine process_library_entry_fill_constants <>= module subroutine process_library_entry_fill_constants (entry, driver, data) class(process_library_entry_t), intent(in) :: entry class(prclib_driver_t), intent(in) :: driver type(process_constants_t), intent(out) :: data integer :: i if (entry%i_external /= 0) then i = entry%i_external data%id = driver%get_process_id (i) data%model_name = driver%get_model_name (i) data%md5sum = driver%get_md5sum (i) data%openmp_supported = driver%get_openmp_status (i) data%n_in = driver%get_n_in (i) data%n_out = driver%get_n_out (i) data%n_flv = driver%get_n_flv (i) data%n_hel = driver%get_n_hel (i) data%n_col = driver%get_n_col (i) data%n_cin = driver%get_n_cin (i) data%n_cf = driver%get_n_cf (i) call driver%set_flv_state (i, data%flv_state) call driver%set_hel_state (i, data%hel_state) call driver%set_col_state (i, data%col_state, data%ghost_flag) call driver%set_color_factors (i, data%color_factors, data%cf_index) else select type (proc_driver => entry%driver) class is (process_driver_internal_t) call proc_driver%fill_constants (data) end select end if end subroutine process_library_entry_fill_constants @ %def process_library_entry_fill_constants @ Retrieve the constants for a process <>= procedure :: fill_constants => process_library_fill_constants <>= module subroutine process_library_fill_constants (lib, id, i_component, data) class(process_library_t), intent(in) :: lib type(string_t), intent(in) :: id integer, intent(in) :: i_component type(process_constants_t), intent(out) :: data end subroutine process_library_fill_constants <>= module subroutine process_library_fill_constants (lib, id, i_component, data) class(process_library_t), intent(in) :: lib type(string_t), intent(in) :: id integer, intent(in) :: i_component type(process_constants_t), intent(out) :: data integer :: i do i = 1, size (lib%entry) associate (entry => lib%entry(i)) if (entry%def%id == id .and. entry%i_component == i_component) then call entry%fill_constants (lib%driver, data) return end if end associate end do end subroutine process_library_fill_constants @ %def process_library_fill_constants @ Retrieve the constants and a connected driver for a process, identified by a process ID and a subprocess index. We scan the process entries until we have found a match. <>= procedure :: connect_process => process_library_connect_process <>= module subroutine process_library_connect_process & (lib, id, i_component, data, proc_driver) class(process_library_t), intent(in) :: lib type(string_t), intent(in) :: id integer, intent(in) :: i_component type(process_constants_t), intent(out) :: data class(prc_core_driver_t), allocatable, intent(out) :: proc_driver end subroutine process_library_connect_process <>= module subroutine process_library_connect_process & (lib, id, i_component, data, proc_driver) class(process_library_t), intent(in) :: lib type(string_t), intent(in) :: id integer, intent(in) :: i_component type(process_constants_t), intent(out) :: data class(prc_core_driver_t), allocatable, intent(out) :: proc_driver integer :: i do i = 1, size (lib%entry) associate (entry => lib%entry(i)) if (entry%def%id == id .and. entry%i_component == i_component) then call entry%fill_constants (lib%driver, data) allocate (proc_driver, source = entry%driver) return end if end associate end do call msg_fatal ("Process library '" // char (lib%basename) & // "': process '" // char (id) // "' not found") end subroutine process_library_connect_process @ %def process_library_connect_process @ Shortcut for use in unit tests: fetch the MD5sum from a specific library entry and inject it into the writer of a specific record. <>= procedure :: test_transfer_md5sum => process_library_test_transfer_md5sum <>= module subroutine process_library_test_transfer_md5sum (lib, r, e, c) class(process_library_t), intent(inout) :: lib integer, intent(in) :: r, e, c end subroutine process_library_test_transfer_md5sum <>= module subroutine process_library_test_transfer_md5sum (lib, r, e, c) class(process_library_t), intent(inout) :: lib integer, intent(in) :: r, e, c associate (writer => lib%driver%record(r)%writer) writer%md5sum = lib%entry(e)%def%get_md5sum (c) end associate end subroutine process_library_test_transfer_md5sum @ %def process_library_test_transfer_md5sum @ <>= procedure :: get_nlo_type => process_library_get_nlo_type <>= module function process_library_get_nlo_type (lib, id, i_component) result (nlo_type) integer :: nlo_type class(process_library_t), intent(in) :: lib type(string_t), intent(in) :: id integer, intent(in) :: i_component end function process_library_get_nlo_type <>= module function process_library_get_nlo_type (lib, id, i_component) result (nlo_type) integer :: nlo_type class(process_library_t), intent(in) :: lib type(string_t), intent(in) :: id integer, intent(in) :: i_component integer :: i do i = 1, size (lib%entry) if (lib%entry(i)%def%id == id .and. lib%entry(i)%i_component == i_component) then nlo_type = lib%entry(i)%def%get_nlo_type (i_component) exit end if end do end function process_library_get_nlo_type @ %def process_library_get_nlo_type @ \subsection{Collect model-specific libraries} This returns appropriate linker flags for the model parameter libraries that are used by the generated matrix element. At the end, the main libwhizard is appended (again), because functions from that may be reqired. Extra models in the local user space need to be treated individually. <>= procedure :: get_modellibs_ldflags => process_library_get_modellibs_ldflags <>= module function process_library_get_modellibs_ldflags (prc_lib, os_data) result (flags) class(process_library_t), intent(in) :: prc_lib type(os_data_t), intent(in) :: os_data type(string_t) :: flags end function process_library_get_modellibs_ldflags <>= module function process_library_get_modellibs_ldflags (prc_lib, os_data) result (flags) class(process_library_t), intent(in) :: prc_lib type(os_data_t), intent(in) :: os_data type(string_t) :: flags type(string_t), dimension(:), allocatable :: models type(string_t) :: modelname, modellib, modellib_full logical :: exist integer :: i, j, mi flags = " -lomega" if ((.not. os_data%use_testfiles) .and. & os_dir_exist (os_data%whizard_models_libpath_local)) & flags = flags // " -L" // os_data%whizard_models_libpath_local flags = flags // " -L" // os_data%whizard_models_libpath allocate (models(prc_lib%n_entries + 1)) models = "" mi = 1 if (allocated (prc_lib%entry)) then SCAN: do i = 1, prc_lib%n_entries if (associated (prc_lib%entry(i)%def)) then if (prc_lib%entry(i)%def%model_name /= "") then modelname = prc_lib%entry(i)%def%model_name else cycle SCAN end if else cycle SCAN end if do j = 1, mi if (models(mi) == modelname) cycle SCAN end do models(mi) = modelname mi = mi + 1 if (os_data%use_libtool) then modellib = "libparameters_" // modelname // ".la" else modellib = "libparameters_" // modelname // ".a" end if exist = .false. if (.not. os_data%use_testfiles) then modellib_full = os_data%whizard_models_libpath_local & // "/" // modellib inquire (file=char (modellib_full), exist=exist) end if if (.not. exist) then modellib_full = os_data%whizard_models_libpath & // "/" // modellib inquire (file=char (modellib_full), exist=exist) end if if (exist) flags = flags // " -lparameters_" // modelname end do SCAN end if deallocate (models) flags = flags // " -lwhizard" end function process_library_get_modellibs_ldflags @ %def process_library_get_modellibs_ldflags @ <>= procedure :: get_static_modelname => process_library_get_static_modelname <>= module function process_library_get_static_modelname (prc_lib, os_data) result (name) class(process_library_t), intent(in) :: prc_lib type(os_data_t), intent(in) :: os_data type(string_t) :: name end function process_library_get_static_modelname <>= module function process_library_get_static_modelname (prc_lib, os_data) result (name) class(process_library_t), intent(in) :: prc_lib type(os_data_t), intent(in) :: os_data type(string_t) :: name type(string_t), dimension(:), allocatable :: models type(string_t) :: modelname, modellib, modellib_full logical :: exist integer :: i, j, mi name = "" allocate (models(prc_lib%n_entries + 1)) models = "" mi = 1 if (allocated (prc_lib%entry)) then SCAN: do i = 1, prc_lib%n_entries if (associated (prc_lib%entry(i)%def)) then if (prc_lib%entry(i)%def%model_name /= "") then modelname = prc_lib%entry(i)%def%model_name else cycle SCAN end if else cycle SCAN end if do j = 1, mi if (models(mi) == modelname) cycle SCAN end do models(mi) = modelname mi = mi + 1 modellib = "libparameters_" // modelname // ".a" exist = .false. if (.not. os_data%use_testfiles) then modellib_full = os_data%whizard_models_libpath_local & // "/" // modellib inquire (file=char (modellib_full), exist=exist) end if if (.not. exist) then modellib_full = os_data%whizard_models_libpath & // "/" // modellib inquire (file=char (modellib_full), exist=exist) end if if (exist) name = name // " " // modellib_full end do SCAN end if deallocate (models) end function process_library_get_static_modelname @ %def process_library_get_static_modelname @ \subsection{Unit Test} Test module, followed by the corresponding implementation module. <<[[process_libraries_ut.f90]]>>= <> module process_libraries_ut use unit_tests use process_libraries_uti <> <> contains <> end module process_libraries_ut @ %def process_libraries_ut @ <<[[process_libraries_uti.f90]]>>= <> module process_libraries_uti use, intrinsic :: iso_c_binding !NODEP! <> use io_units use os_interface use particle_specifiers, only: new_prt_spec use process_constants use prclib_interfaces use prc_core_def use process_libraries use prclib_interfaces_ut, only: test_writer_4_t <> <> <> contains <> <> end module process_libraries_uti @ %def process_libraries_ut @ API: driver for the unit tests below. <>= public :: process_libraries_test <>= subroutine process_libraries_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine process_libraries_test @ %def process_libraries_test @ \subsubsection{Empty process list} Test 1: Write an empty process list. <>= call test (process_libraries_1, "process_libraries_1", & "empty process list", & u, results) <>= public :: process_libraries_1 <>= subroutine process_libraries_1 (u) integer, intent(in) :: u type(process_def_list_t) :: process_def_list write (u, "(A)") "* Test output: process_libraries_1" write (u, "(A)") "* Purpose: Display an empty process definition list" write (u, "(A)") call process_def_list%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_1" end subroutine process_libraries_1 @ %def process_libraries_1 @ \subsubsection{Process definition list} Test 2: Process definition list with processes and components. Construct the list, write to file, read it in again, and display. Finalize and delete the list after use. We define a trivial 'test' type for the process variant. The test type contains just one (meaningless) data item, which is an integer. <>= type, extends (prc_core_def_t) :: prcdef_2_t integer :: data = 0 logical :: file = .false. contains <> end type prcdef_2_t @ %def prcdef_2_t @ The process variant is named 'test'. <>= procedure, nopass :: type_string => prcdef_2_type_string <>= function prcdef_2_type_string () result (string) type(string_t) :: string string = "test" end function prcdef_2_type_string @ %def prcdef_2_type_string @ Write the contents (the integer value). <>= procedure :: write => prcdef_2_write <>= subroutine prcdef_2_write (object, unit) class(prcdef_2_t), intent(in) :: object integer, intent(in) :: unit write (unit, "(3x,A,I0)") "Test data = ", object%data end subroutine prcdef_2_write @ %def prcdef_2_write @ Recover the integer value. <>= procedure :: read => prcdef_2_read <>= subroutine prcdef_2_read (object, unit) class(prcdef_2_t), intent(out) :: object integer, intent(in) :: unit character(80) :: buffer read (unit, "(A)") buffer call strip_equation_lhs (buffer) read (buffer, *) object%data end subroutine prcdef_2_read @ %def prcdef_2_read @ No external procedures. <>= procedure, nopass :: get_features => prcdef_2_get_features <>= subroutine prcdef_2_get_features (features) type(string_t), dimension(:), allocatable, intent(out) :: features allocate (features (0)) end subroutine prcdef_2_get_features @ %def prcdef_2_get_features @ No code generated. <>= procedure :: generate_code => prcdef_2_generate_code <>= subroutine prcdef_2_generate_code (object, & basename, model_name, prt_in, prt_out) class(prcdef_2_t), intent(in) :: object type(string_t), intent(in) :: basename type(string_t), intent(in) :: model_name type(string_t), dimension(:), intent(in) :: prt_in type(string_t), dimension(:), intent(in) :: prt_out end subroutine prcdef_2_generate_code @ %def prcdef_2_generate_code @ Allocate the driver with the appropriate type. <>= procedure :: allocate_driver => prcdef_2_allocate_driver <>= subroutine prcdef_2_allocate_driver (object, driver, basename) class(prcdef_2_t), intent(in) :: object class(prc_core_driver_t), intent(out), allocatable :: driver type(string_t), intent(in) :: basename allocate (prctest_2_t :: driver) end subroutine prcdef_2_allocate_driver @ %def prcdef_2_allocate_driver @ Nothing to connect. <>= procedure :: connect => prcdef_2_connect <>= subroutine prcdef_2_connect (def, lib_driver, i, proc_driver) class(prcdef_2_t), intent(in) :: def class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver end subroutine prcdef_2_connect @ %def prcdef_2_connect @ The associated driver type. <>= type, extends (process_driver_internal_t) :: prctest_2_t contains <> end type prctest_2_t @ %def prctest_2_t @ Return the type name. <>= procedure, nopass :: type_name => prctest_2_type_name <>= function prctest_2_type_name () result (type) type(string_t) :: type type = "test" end function prctest_2_type_name @ %def prctest_2_type_name @ This should fill constant process data. We do not check those here, however, therefore nothing done. <>= procedure :: fill_constants => prctest_2_fill_constants <>= subroutine prctest_2_fill_constants (driver, data) class(prctest_2_t), intent(in) :: driver type(process_constants_t), intent(out) :: data end subroutine prctest_2_fill_constants @ %def prctest_2_fill_constants @ Here is the actual test. For reading, we need a list of templates, i.e., an array containing allocated objects for all available process variants. This is the purpose of [[process_core_templates]]. Here, we have only a single template for the 'test' variant. <>= call test (process_libraries_2, "process_libraries_2", & "process definition list", & u, results) <>= public :: process_libraries_2 <>= subroutine process_libraries_2 (u) integer, intent(in) :: u type(prc_template_t), dimension(:), allocatable :: process_core_templates type(process_def_list_t) :: process_def_list type(process_def_entry_t), pointer :: entry => null () class(prc_core_def_t), allocatable :: test_def integer :: scratch_unit write (u, "(A)") "* Test output: process_libraries_2" write (u, "(A)") "* Purpose: Construct a process definition list," write (u, "(A)") "* write it to file and reread it" write (u, "(A)") "" write (u, "(A)") "* Construct a process definition list" write (u, "(A)") "* First process definition: empty" write (u, "(A)") "* Second process definition: two components" write (u, "(A)") "* First component: empty" write (u, "(A)") "* Second component: test data" write (u, "(A)") "* Third process definition:" write (u, "(A)") "* Embedded decays and polarization" write (u, "(A)") allocate (process_core_templates (1)) allocate (prcdef_2_t :: process_core_templates(1)%core_def) allocate (entry) call entry%init (var_str ("first"), n_in = 0, n_components = 0) call entry%compute_md5sum () call process_def_list%append (entry) allocate (entry) call entry%init (var_str ("second"), model_name = var_str ("Test"), & n_in = 1, n_components = 2) allocate (prcdef_2_t :: test_def) select type (test_def) type is (prcdef_2_t); test_def%data = 42 end select call entry%import_component (2, n_out = 2, & prt_in = new_prt_spec ([var_str ("a")]), & prt_out = new_prt_spec ([var_str ("b"), var_str ("c")]), & method = var_str ("test"), & variant = test_def) call entry%compute_md5sum () call process_def_list%append (entry) allocate (entry) call entry%init (var_str ("third"), model_name = var_str ("Test"), & n_in = 2, n_components = 1) allocate (prcdef_2_t :: test_def) call entry%import_component (1, n_out = 3, & prt_in = & new_prt_spec ([var_str ("a"), var_str ("b")]), & prt_out = & [new_prt_spec (var_str ("c")), & new_prt_spec (var_str ("d"), .true.), & new_prt_spec (var_str ("e"), [var_str ("e_decay")])], & method = var_str ("test"), & variant = test_def) call entry%compute_md5sum () call process_def_list%append (entry) call process_def_list%write (u) write (u, "(A)") "" write (u, "(A)") "* Write the process definition list to (scratch) file" scratch_unit = free_unit () open (unit = scratch_unit, status="scratch", action = "readwrite") call process_def_list%write (scratch_unit) call process_def_list%final () write (u, "(A)") "* Reread it" write (u, "(A)") "" rewind (scratch_unit) call process_def_list%read (scratch_unit, process_core_templates) close (scratch_unit) call process_def_list%write (u) call process_def_list%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_2" end subroutine process_libraries_2 @ %def process_libraries_2 @ \subsubsection{Process library object} Test 3: Process library object with several process definitions and library entries. Just construct the object, modify some initial content, and write the result. The modifications are mostly applied directly, so we do not test anything but the contents and the output routine. <>= call test (process_libraries_3, "process_libraries_3", & "recover process definition list from file", & u, results) <>= public :: process_libraries_3 <>= subroutine process_libraries_3 (u) integer, intent(in) :: u type(process_library_t) :: lib type(process_def_entry_t), pointer :: entry class(prc_core_driver_t), allocatable :: driver_template write (u, "(A)") "* Test output: process_libraries_3" write (u, "(A)") "* Purpose: Construct a process library object & &with entries" write (u, "(A)") "" write (u, "(A)") "* Construct and display a process library object" write (u, "(A)") "* with 5 entries" write (u, "(A)") "* associated with 3 matrix element codes" write (u, "(A)") "* corresponding to 3 process definitions" write (u, "(A)") "* with 2, 1, 1 components, respectively" write (u, "(A)") call lib%init (var_str ("testlib")) call lib%set_status (STAT_ACTIVE) call lib%allocate_entries (5) allocate (entry) call entry%init (var_str ("test_a"), n_in = 2, n_components = 2) allocate (prctest_2_t :: driver_template) call lib%init_entry (3, STAT_SOURCE, entry%process_def_t, 2, 2, & driver_template) call lib%init_entry (4, STAT_COMPILED, entry%process_def_t, 1, 0) call lib%append (entry) allocate (entry) call entry%init (var_str ("test_b"), n_in = 2, n_components = 1) call lib%init_entry (2, STAT_CONFIGURED, entry%process_def_t, 1, 1) call lib%append (entry) allocate (entry) call entry%init (var_str ("test_c"), n_in = 2, n_components = 1) allocate (prctest_2_t :: driver_template) call lib%init_entry (5, STAT_LINKED, entry%process_def_t, 1, 3, & driver_template) call lib%append (entry) call lib%write (u) call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_3" end subroutine process_libraries_3 @ %def process_libraries_3 @ \subsubsection{Process library for test matrix element (no file)} Test 4: We proceed through the library generation and loading phases with a test matrix element type that needs no code written on file. <>= call test (process_libraries_4, "process_libraries_4", & "build and load internal process library", & u, results) <>= public :: process_libraries_4 <>= subroutine process_libraries_4 (u) integer, intent(in) :: u type(process_library_t) :: lib type(process_def_entry_t), pointer :: entry class(prc_core_def_t), allocatable :: core_def type(os_data_t) :: os_data write (u, "(A)") "* Test output: process_libraries_4" write (u, "(A)") "* Purpose: build a process library with an & &internal (pseudo) matrix element" write (u, "(A)") "* No Makefile or code should be generated" write (u, "(A)") write (u, "(A)") "* Initialize a process library with one entry & &(no external code)" write (u, "(A)") call os_data%init () call lib%init (var_str ("proclibs4")) allocate (prcdef_2_t :: core_def) allocate (entry) call entry%init (var_str ("proclibs4_a"), n_in = 1, n_components = 1) call entry%import_component (1, n_out = 2, variant = core_def) call lib%append (entry) write (u, "(A)") "* Configure library" write (u, "(A)") call lib%configure (os_data) write (u, "(A)") "* Compute MD5 sum" write (u, "(A)") call lib%compute_md5sum () write (u, "(A)") "* Write makefile (no-op)" write (u, "(A)") call lib%write_makefile (os_data, force = .true., verbose = .true.) write (u, "(A)") "* Write driver source code (no-op)" write (u, "(A)") call lib%write_driver (force = .true.) write (u, "(A)") "* Write process source code (no-op)" write (u, "(A)") call lib%make_source (os_data) write (u, "(A)") "* Compile (no-op)" write (u, "(A)") call lib%make_compile (os_data) write (u, "(A)") "* Link (no-op)" write (u, "(A)") call lib%make_link (os_data) write (u, "(A)") "* Load (no-op)" write (u, "(A)") call lib%load (os_data) call lib%write (u) call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_4" end subroutine process_libraries_4 @ %def process_libraries_4 @ \subsubsection{Build workflow for test matrix element} Test 5: We write source code for a dummy process. We define another trivial type for the process variant. The test type contains just no variable data, but produces code on file. <>= type, extends (prc_core_def_t) :: prcdef_5_t contains <> end type prcdef_5_t @ %def prcdef_5_t @ The process variant is named [[test_file]]. <>= procedure, nopass :: type_string => prcdef_5_type_string <>= function prcdef_5_type_string () result (string) type(string_t) :: string string = "test_file" end function prcdef_5_type_string @ %def prcdef_5_type_string @ We reuse the writer [[test_writer_4]] from the previous module. <>= procedure :: init => prcdef_5_init <>= subroutine prcdef_5_init (object) class(prcdef_5_t), intent(out) :: object allocate (test_writer_4_t :: object%writer) end subroutine prcdef_5_init @ %def prcdef_5_init @ Nothing to write. <>= procedure :: write => prcdef_5_write <>= subroutine prcdef_5_write (object, unit) class(prcdef_5_t), intent(in) :: object integer, intent(in) :: unit end subroutine prcdef_5_write @ %def prcdef_5_write @ Nothing to read. <>= procedure :: read => prcdef_5_read <>= subroutine prcdef_5_read (object, unit) class(prcdef_5_t), intent(out) :: object integer, intent(in) :: unit end subroutine prcdef_5_read @ %def prcdef_5_read @ Allocate the driver with the appropriate type. <>= procedure :: allocate_driver => prcdef_5_allocate_driver <>= subroutine prcdef_5_allocate_driver (object, driver, basename) class(prcdef_5_t), intent(in) :: object class(prc_core_driver_t), intent(out), allocatable :: driver type(string_t), intent(in) :: basename allocate (prctest_5_t :: driver) end subroutine prcdef_5_allocate_driver @ %def prcdef_5_allocate_driver @ This time we need code: <>= procedure, nopass :: needs_code => prcdef_5_needs_code <>= function prcdef_5_needs_code () result (flag) logical :: flag flag = .true. end function prcdef_5_needs_code @ %def prcdef_5_needs_code @ For the test case, we implement a single feature [[proc1]]. <>= procedure, nopass :: get_features => prcdef_5_get_features <>= subroutine prcdef_5_get_features (features) type(string_t), dimension(:), allocatable, intent(out) :: features allocate (features (1)) features = [ var_str ("proc1") ] end subroutine prcdef_5_get_features @ %def prcdef_5_get_features @ Nothing to connect. <>= procedure :: connect => prcdef_5_connect <>= subroutine prcdef_5_connect (def, lib_driver, i, proc_driver) class(prcdef_5_t), intent(in) :: def class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver end subroutine prcdef_5_connect @ %def prcdef_5_connect @ The driver type. <>= type, extends (prc_core_driver_t) :: prctest_5_t contains <> end type prctest_5_t @ %def prctest_5_t @ Return the type name. <>= procedure, nopass :: type_name => prctest_5_type_name <>= function prctest_5_type_name () result (type) type(string_t) :: type type = "test_file" end function prctest_5_type_name @ %def prctest_5_type_name @ Here is the actual test: <>= call test (process_libraries_5, "process_libraries_5", & "build external process library", & u, results) <>= public :: process_libraries_5 <>= subroutine process_libraries_5 (u) integer, intent(in) :: u type(process_library_t) :: lib type(process_def_entry_t), pointer :: entry class(prc_core_def_t), allocatable :: core_def type(os_data_t) :: os_data write (u, "(A)") "* Test output: process_libraries_5" write (u, "(A)") "* Purpose: build a process library with an & &external (pseudo) matrix element" write (u, "(A)") write (u, "(A)") "* Initialize a process library with one entry" write (u, "(A)") call lib%init (var_str ("proclibs5")) call os_data%init () allocate (prcdef_5_t :: core_def) select type (core_def) type is (prcdef_5_t) call core_def%init () end select allocate (entry) call entry%init (var_str ("proclibs5_a"), & model_name = var_str ("Test_Model"), & n_in = 1, n_components = 1) call entry%import_component (1, n_out = 2, & prt_in = new_prt_spec ([var_str ("a")]), & prt_out = new_prt_spec ([var_str ("b"), var_str ("c")]), & method = var_str ("test"), & variant = core_def) call lib%append (entry) write (u, "(A)") "* Configure library" write (u, "(A)") call lib%configure (os_data) write (u, "(A)") "* Compute MD5 sum" write (u, "(A)") call lib%compute_md5sum () write (u, "(A)") "* Write makefile" write (u, "(A)") call lib%write_makefile (os_data, force = .true., verbose = .false.) write (u, "(A)") "* Write driver source code" write (u, "(A)") call lib%write_driver (force = .true.) write (u, "(A)") "* Write process source code" write (u, "(A)") call lib%make_source (os_data) write (u, "(A)") "* Compile" write (u, "(A)") call lib%make_compile (os_data) write (u, "(A)") "* Link" write (u, "(A)") call lib%make_link (os_data) call lib%write (u, libpath = .false.) call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_5" end subroutine process_libraries_5 @ %def process_libraries_5 @ \subsubsection{Build and load library with test matrix element} Test 6: We write source code for a dummy process. This process variant is identical to the previous case, but it supports a driver for the test procedure 'proc1'. <>= type, extends (prc_core_def_t) :: prcdef_6_t contains <> end type prcdef_6_t @ %def prcdef_6_t @ The process variant is named [[test_file]]. <>= procedure, nopass :: type_string => prcdef_6_type_string <>= function prcdef_6_type_string () result (string) type(string_t) :: string string = "test_file" end function prcdef_6_type_string @ %def prcdef_6_type_string @ We reuse the writer [[test_writer_4]] from the previous module. <>= procedure :: init => prcdef_6_init <>= subroutine prcdef_6_init (object) class(prcdef_6_t), intent(out) :: object allocate (test_writer_4_t :: object%writer) call object%writer%init_test () end subroutine prcdef_6_init @ %def prcdef_6_init @ Nothing to write. <>= procedure :: write => prcdef_6_write <>= subroutine prcdef_6_write (object, unit) class(prcdef_6_t), intent(in) :: object integer, intent(in) :: unit end subroutine prcdef_6_write @ %def prcdef_6_write @ Nothing to read. <>= procedure :: read => prcdef_6_read <>= subroutine prcdef_6_read (object, unit) class(prcdef_6_t), intent(out) :: object integer, intent(in) :: unit end subroutine prcdef_6_read @ %def prcdef_6_read @ Allocate the driver with the appropriate type. <>= procedure :: allocate_driver => prcdef_6_allocate_driver <>= subroutine prcdef_6_allocate_driver (object, driver, basename) class(prcdef_6_t), intent(in) :: object class(prc_core_driver_t), intent(out), allocatable :: driver type(string_t), intent(in) :: basename allocate (prctest_6_t :: driver) end subroutine prcdef_6_allocate_driver @ %def prcdef_6_allocate_driver @ This time we need code: <>= procedure, nopass :: needs_code => prcdef_6_needs_code <>= function prcdef_6_needs_code () result (flag) logical :: flag flag = .true. end function prcdef_6_needs_code @ %def prcdef_6_needs_code @ For the test case, we implement a single feature [[proc1]]. <>= procedure, nopass :: get_features => prcdef_6_get_features <>= subroutine prcdef_6_get_features (features) type(string_t), dimension(:), allocatable, intent(out) :: features allocate (features (1)) features = [ var_str ("proc1") ] end subroutine prcdef_6_get_features @ %def prcdef_6_get_features @ The interface of the only specific feature. <>= abstract interface subroutine proc1_t (n) bind(C) import integer(c_int), intent(out) :: n end subroutine proc1_t end interface @ %def proc1_t @ Connect the feature [[proc1]] with the process driver. <>= procedure :: connect => prcdef_6_connect <>= subroutine prcdef_6_connect (def, lib_driver, i, proc_driver) class(prcdef_6_t), intent(in) :: def class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver integer(c_int) :: pid, fid type(c_funptr) :: fptr select type (proc_driver) type is (prctest_6_t) pid = i fid = 1 call lib_driver%get_fptr (pid, fid, fptr) call c_f_procpointer (fptr, proc_driver%proc1) end select end subroutine prcdef_6_connect @ %def prcdef_6_connect @ The driver type. <>= type, extends (prc_core_driver_t) :: prctest_6_t procedure(proc1_t), nopass, pointer :: proc1 => null () contains <> end type prctest_6_t @ %def prctest_6_t @ Return the type name. <>= procedure, nopass :: type_name => prctest_6_type_name <>= function prctest_6_type_name () result (type) type(string_t) :: type type = "test_file" end function prctest_6_type_name @ %def prctest_6_type_name @ Here is the actual test: <>= call test (process_libraries_6, "process_libraries_6", & "build and load external process library", & u, results) <>= public :: process_libraries_6 <>= subroutine process_libraries_6 (u) integer, intent(in) :: u type(process_library_t) :: lib type(process_def_entry_t), pointer :: entry class(prc_core_def_t), allocatable :: core_def type(os_data_t) :: os_data type(string_t), dimension(:), allocatable :: name_list type(process_constants_t) :: data class(prc_core_driver_t), allocatable :: proc_driver integer :: i integer(c_int) :: n write (u, "(A)") "* Test output: process_libraries_6" write (u, "(A)") "* Purpose: build and load a process library" write (u, "(A)") "* with an external (pseudo) matrix element" write (u, "(A)") "* Check single-call linking" write (u, "(A)") write (u, "(A)") "* Initialize a process library with one entry" write (u, "(A)") call lib%init (var_str ("proclibs6")) call os_data%init () allocate (prcdef_6_t :: core_def) select type (core_def) type is (prcdef_6_t) call core_def%init () end select allocate (entry) call entry%init (var_str ("proclibs6_a"), & model_name = var_str ("Test_model"), & n_in = 1, n_components = 1) call entry%import_component (1, n_out = 2, & prt_in = new_prt_spec ([var_str ("a")]), & prt_out = new_prt_spec ([var_str ("b"), var_str ("c")]), & method = var_str ("test"), & variant = core_def) call lib%append (entry) write (u, "(A)") "* Configure library" write (u, "(A)") call lib%configure (os_data) write (u, "(A)") "* Write makefile" write (u, "(A)") call lib%write_makefile (os_data, force = .true., verbose = .false.) write (u, "(A)") "* Write driver source code" write (u, "(A)") call lib%write_driver (force = .true.) write (u, "(A)") "* Write process source code, compile, link, load" write (u, "(A)") call lib%load (os_data) call lib%write (u, libpath = .false.) write (u, "(A)") write (u, "(A)") "* Probe library API:" write (u, "(A)") write (u, "(1x,A,A,A)") "name = '", & char (lib%get_name ()), "'" write (u, "(1x,A,L1)") "is active = ", & lib%is_active () write (u, "(1x,A,I0)") "n_processes = ", & lib%get_n_processes () write (u, "(1x,A)", advance="no") "processes =" call lib%get_process_id_list (name_list) do i = 1, size (name_list) write (u, "(1x,A)", advance="no") char (name_list(i)) end do write (u, *) write (u, "(1x,A,L1)") "proclibs6_a is process = ", & lib%contains (var_str ("proclibs6_a")) write (u, "(1x,A,I0)") "proclibs6_a has index = ", & lib%get_entry_index (var_str ("proclibs6_a")) write (u, "(1x,A,L1)") "foobar is process = ", & lib%contains (var_str ("foobar")) write (u, "(1x,A,I0)") "foobar has index = ", & lib%get_entry_index (var_str ("foobar")) write (u, "(1x,A,I0)") "n_in(proclibs6_a) = ", & lib%get_n_in (var_str ("proclibs6_a")) write (u, "(1x,A,A)") "model_name(proclibs6_a) = ", & char (lib%get_model_name (var_str ("proclibs6_a"))) write (u, "(1x,A)", advance="no") "components(proclibs6_a) =" call lib%get_component_list (var_str ("proclibs6_a"), name_list) do i = 1, size (name_list) write (u, "(1x,A)", advance="no") char (name_list(i)) end do write (u, *) write (u, "(A)") write (u, "(A)") "* Constants of proclibs6_a_i1:" write (u, "(A)") call lib%connect_process (var_str ("proclibs6_a"), 1, data, proc_driver) write (u, "(1x,A,A)") "component ID = ", char (data%id) write (u, "(1x,A,A)") "model name = ", char (data%model_name) write (u, "(1x,A,A,A)") "md5sum = '", data%md5sum, "'" write (u, "(1x,A,L1)") "openmp supported = ", data%openmp_supported write (u, "(1x,A,I0)") "n_in = ", data%n_in write (u, "(1x,A,I0)") "n_out = ", data%n_out write (u, "(1x,A,I0)") "n_flv = ", data%n_flv write (u, "(1x,A,I0)") "n_hel = ", data%n_hel write (u, "(1x,A,I0)") "n_col = ", data%n_col write (u, "(1x,A,I0)") "n_cin = ", data%n_cin write (u, "(1x,A,I0)") "n_cf = ", data%n_cf write (u, "(1x,A,10(1x,I0))") "flv state =", data%flv_state write (u, "(1x,A,10(1x,I0))") "hel state =", data%hel_state write (u, "(1x,A,10(1x,I0))") "col state =", data%col_state write (u, "(1x,A,10(1x,L1))") "ghost flag =", data%ghost_flag write (u, "(1x,A,10(1x,F5.3))") "color factors =", data%color_factors write (u, "(1x,A,10(1x,I0))") "cf index =", data%cf_index write (u, "(A)") write (u, "(A)") "* Call feature of proclibs6_a:" write (u, "(A)") select type (proc_driver) type is (prctest_6_t) call proc_driver%proc1 (n) write (u, "(1x,A,I0)") "proc1 = ", n end select call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_6" end subroutine process_libraries_6 @ %def process_libraries_6 @ \subsubsection{MD5 sums} Check MD5 sum calculation. <>= call test (process_libraries_7, "process_libraries_7", & "process definition list", & u, results) <>= public :: process_libraries_7 <>= subroutine process_libraries_7 (u) integer, intent(in) :: u type(prc_template_t), dimension(:), allocatable :: process_core_templates type(process_def_entry_t), target :: entry class(prc_core_def_t), allocatable :: test_def class(prc_core_def_t), pointer :: def write (u, "(A)") "* Test output: process_libraries_7" write (u, "(A)") "* Purpose: Construct a process definition list & &and check MD5 sums" write (u, "(A)") write (u, "(A)") "* Construct a process definition list" write (u, "(A)") "* Process: two components" write (u, "(A)") allocate (process_core_templates (1)) allocate (prcdef_2_t :: process_core_templates(1)%core_def) call entry%init (var_str ("first"), model_name = var_str ("Test"), & n_in = 1, n_components = 2) allocate (prcdef_2_t :: test_def) select type (test_def) type is (prcdef_2_t); test_def%data = 31 end select call entry%import_component (1, n_out = 3, & prt_in = new_prt_spec ([var_str ("a")]), & prt_out = new_prt_spec ([var_str ("b"), var_str ("c"), & var_str ("e")]), & method = var_str ("test"), & variant = test_def) allocate (prcdef_2_t :: test_def) select type (test_def) type is (prcdef_2_t); test_def%data = 42 end select call entry%import_component (2, n_out = 2, & prt_in = new_prt_spec ([var_str ("a")]), & prt_out = new_prt_spec ([var_str ("b"), var_str ("c")]), & method = var_str ("test"), & variant = test_def) call entry%write (u) write (u, "(A)") write (u, "(A)") "* Compute MD5 sums" write (u, "(A)") call entry%compute_md5sum () call entry%write (u) write (u, "(A)") write (u, "(A)") "* Recalculate MD5 sums (should be identical)" write (u, "(A)") call entry%compute_md5sum () call entry%write (u) write (u, "(A)") write (u, "(A)") "* Modify a component and recalculate MD5 sums" write (u, "(A)") def => entry%get_core_def_ptr (2) select type (def) type is (prcdef_2_t) def%data = 54 end select call entry%compute_md5sum () call entry%write (u) write (u, "(A)") write (u, "(A)") "* Modify the model and recalculate MD5 sums" write (u, "(A)") call entry%set_model_name (var_str ("foo")) call entry%compute_md5sum () call entry%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_7" end subroutine process_libraries_7 @ %def process_libraries_7 @ Here is the actual test: <>= call test (process_libraries_8, "process_libraries_8", & "library status checks", & u, results) <>= public :: process_libraries_8 <>= subroutine process_libraries_8 (u) integer, intent(in) :: u type(process_library_t) :: lib type(process_def_entry_t), pointer :: entry class(prc_core_def_t), allocatable :: core_def type(os_data_t) :: os_data write (u, "(A)") "* Test output: process_libraries_8" write (u, "(A)") "* Purpose: build and load a process library" write (u, "(A)") "* with an external (pseudo) matrix element" write (u, "(A)") "* Check status updates" write (u, "(A)") write (u, "(A)") "* Initialize a process library with one entry" write (u, "(A)") call lib%init (var_str ("proclibs8")) call os_data%init () allocate (prcdef_6_t :: core_def) select type (core_def) type is (prcdef_6_t) call core_def%init () end select allocate (entry) call entry%init (var_str ("proclibs8_a"), & model_name = var_str ("Test_model"), & n_in = 1, n_components = 1) call entry%import_component (1, n_out = 2, & prt_in = new_prt_spec ([var_str ("a")]), & prt_out = new_prt_spec ([var_str ("b"), var_str ("c")]), & method = var_str ("test"), & variant = core_def) call lib%append (entry) write (u, "(A)") "* Configure library" write (u, "(A)") call lib%configure (os_data) call lib%compute_md5sum () call lib%test_transfer_md5sum (1, 1, 1) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(A)") write (u, "(A)") "* Write makefile" write (u, "(A)") call lib%write_makefile (os_data, force = .true., verbose = .false.) write (u, "(A)") "* Update status" write (u, "(A)") call lib%update_status (os_data) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(A)") write (u, "(A)") "* Write driver source code" write (u, "(A)") call lib%write_driver (force = .false.) write (u, "(A)") "* Write process source code" write (u, "(A)") call lib%make_source (os_data) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(A)") write (u, "(A)") "* Compile and load" write (u, "(A)") call lib%load (os_data) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(A)") write (u, "(A)") "* Append process and reconfigure" write (u, "(A)") allocate (prcdef_6_t :: core_def) select type (core_def) type is (prcdef_6_t) call core_def%init () end select allocate (entry) call entry%init (var_str ("proclibs8_b"), & model_name = var_str ("Test_model"), & n_in = 1, n_components = 1) call entry%import_component (1, n_out = 2, & prt_in = new_prt_spec ([var_str ("a")]), & prt_out = new_prt_spec ([var_str ("b"), var_str ("d")]), & method = var_str ("test"), & variant = core_def) call lib%append (entry) call lib%configure (os_data) call lib%compute_md5sum () call lib%test_transfer_md5sum (2, 2, 1) call lib%write_makefile (os_data, force = .false., verbose = .false.) call lib%write_driver (force = .false.) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(1x,A,I0)") "proc2 status = ", lib%get_status (2) write (u, "(A)") write (u, "(A)") "* Update status" write (u, "(A)") call lib%update_status (os_data) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(1x,A,I0)") "proc2 status = ", lib%get_status (2) write (u, "(A)") write (u, "(A)") "* Write source code" write (u, "(A)") call lib%make_source (os_data) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(1x,A,I0)") "proc2 status = ", lib%get_status (2) write (u, "(A)") write (u, "(A)") "* Reset status" write (u, "(A)") call lib%set_status (STAT_CONFIGURED, entries=.true.) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(1x,A,I0)") "proc2 status = ", lib%get_status (2) write (u, "(A)") write (u, "(A)") "* Update status" write (u, "(A)") call lib%update_status (os_data) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(1x,A,I0)") "proc2 status = ", lib%get_status (2) write (u, "(A)") write (u, "(A)") "* Partial cleanup" write (u, "(A)") call lib%clean (os_data, distclean = .false.) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(1x,A,I0)") "proc2 status = ", lib%get_status (2) write (u, "(A)") write (u, "(A)") "* Update status" write (u, "(A)") call lib%update_status (os_data) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(1x,A,I0)") "proc2 status = ", lib%get_status (2) write (u, "(A)") write (u, "(A)") "* Complete cleanup" call lib%clean (os_data, distclean = .true.) call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_8" end subroutine process_libraries_8 @ %def process_libraries_8 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process Library Stacks} For storing and handling multiple libraries, we define process library stacks. These are ordinary stacks where new entries are pushed onto the top. <<[[prclib_stacks.f90]]>>= <> module prclib_stacks <> use process_libraries <> <> <> interface <> end interface end module prclib_stacks @ %def prclib_stacks @ <<[[prclib_stacks_sub.f90]]>>= <> submodule (prclib_stacks) prclib_stacks_s use io_units use format_utils, only: write_separator implicit none contains <> end submodule prclib_stacks_s @ %def prclib_stacks_s @ \subsection{The stack entry type} A stack entry is a process library object, augmented by a pointer to the next entry. We do not need specific methods, all relevant methods are inherited. On higher level, process libraries should be prepared as process entry objects. <>= public :: prclib_entry_t <>= type, extends (process_library_t) :: prclib_entry_t type(prclib_entry_t), pointer :: next => null () end type prclib_entry_t @ %def prclib_entry_t @ \subsection{The prclib stack type} For easy conversion and lookup it is useful to store the filling number in the object. The content is stored as a linked list. <>= public :: prclib_stack_t <>= type :: prclib_stack_t integer :: n = 0 type(prclib_entry_t), pointer :: first => null () contains <> end type prclib_stack_t @ %def prclib_stack_t @ Finalizer. Iteratively deallocate the stack entries. The resulting empty stack can be immediately recycled, if necessary. <>= procedure :: final => prclib_stack_final <>= module subroutine prclib_stack_final (object) class(prclib_stack_t), intent(inout) :: object end subroutine prclib_stack_final <>= module subroutine prclib_stack_final (object) class(prclib_stack_t), intent(inout) :: object type(prclib_entry_t), pointer :: lib do while (associated (object%first)) lib => object%first object%first => lib%next call lib%final () deallocate (lib) end do object%n = 0 end subroutine prclib_stack_final @ %def prclib_stack_final @ Output. The entries on the stack will be ordered LIFO, i.e., backwards. <>= procedure :: write => prclib_stack_write <>= module subroutine prclib_stack_write (object, unit, libpath) class(prclib_stack_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: libpath end subroutine prclib_stack_write <>= module subroutine prclib_stack_write (object, unit, libpath) class(prclib_stack_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: libpath type(prclib_entry_t), pointer :: lib integer :: u u = given_output_unit (unit) call write_separator (u, 2) select case (object%n) case (0) write (u, "(1x,A)") "Process library stack: [empty]" case default write (u, "(1x,A)") "Process library stack:" lib => object%first do while (associated (lib)) call write_separator (u) call lib%write (u, libpath) lib => lib%next end do end select call write_separator (u, 2) end subroutine prclib_stack_write @ %def prclib_stack_write @ \subsection{Operating on Stacks} We take a library entry pointer and push it onto the stack. The previous pointer is nullified. Subsequently, the library entry is `owned' by the stack and will be finalized when the stack is deleted. <>= procedure :: push => prclib_stack_push <>= module subroutine prclib_stack_push (stack, lib) class(prclib_stack_t), intent(inout) :: stack type(prclib_entry_t), intent(inout), pointer :: lib end subroutine prclib_stack_push <>= module subroutine prclib_stack_push (stack, lib) class(prclib_stack_t), intent(inout) :: stack type(prclib_entry_t), intent(inout), pointer :: lib lib%next => stack%first stack%first => lib lib => null () stack%n = stack%n + 1 end subroutine prclib_stack_push @ %def prclib_stack_push @ \subsection{Accessing Contents} Return a pointer to the topmost stack element. The result type is just the bare [[process_library_t]]. There is no [[target]] attribute required since the stack elements are allocated via pointers. <>= procedure :: get_first_ptr => prclib_stack_get_first_ptr <>= module function prclib_stack_get_first_ptr (stack) result (ptr) class(prclib_stack_t), intent(in) :: stack type(process_library_t), pointer :: ptr end function prclib_stack_get_first_ptr <>= module function prclib_stack_get_first_ptr (stack) result (ptr) class(prclib_stack_t), intent(in) :: stack type(process_library_t), pointer :: ptr if (associated (stack%first)) then ptr => stack%first%process_library_t else ptr => null () end if end function prclib_stack_get_first_ptr @ %def prclib_stack_get_first_ptr @ Return a complete list of the libraries (names) in the stack. The list is in the order in which the elements got pushed onto the stack, so the 'first' entry is listed last. <>= procedure :: get_names => prclib_stack_get_names <>= module subroutine prclib_stack_get_names (stack, libname) class(prclib_stack_t), intent(in) :: stack type(string_t), dimension(:), allocatable, intent(out) :: libname end subroutine prclib_stack_get_names <>= module subroutine prclib_stack_get_names (stack, libname) class(prclib_stack_t), intent(in) :: stack type(string_t), dimension(:), allocatable, intent(out) :: libname type(prclib_entry_t), pointer :: lib integer :: i allocate (libname (stack%n)) i = stack%n lib => stack%first do while (associated (lib)) libname(i) = lib%get_name () i = i - 1 lib => lib%next end do end subroutine prclib_stack_get_names @ %def prclib_stack_get_names @ Return a pointer to the library with given name. <>= procedure :: get_library_ptr => prclib_stack_get_library_ptr <>= module function prclib_stack_get_library_ptr (stack, libname) result (ptr) class(prclib_stack_t), intent(in) :: stack type(string_t), intent(in) :: libname type(process_library_t), pointer :: ptr end function prclib_stack_get_library_ptr <>= module function prclib_stack_get_library_ptr (stack, libname) result (ptr) class(prclib_stack_t), intent(in) :: stack type(string_t), intent(in) :: libname type(process_library_t), pointer :: ptr type(prclib_entry_t), pointer :: current current => stack%first do while (associated (current)) if (current%get_name () == libname) then ptr => current%process_library_t return end if current => current%next end do ptr => null () end function prclib_stack_get_library_ptr @ %def prclib_stack_get_library_ptr @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[prclib_stacks_ut.f90]]>>= <> module prclib_stacks_ut use unit_tests use prclib_stacks_uti <> <> contains <> end module prclib_stacks_ut @ %def prclib_stacks_ut @ <<[[prclib_stacks_uti.f90]]>>= <> module prclib_stacks_uti <> use prclib_stacks <> <> contains <> end module prclib_stacks_uti @ %def prclib_stacks_ut @ API: driver for the unit tests below. <>= public :: prclib_stacks_test <>= subroutine prclib_stacks_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine prclib_stacks_test @ %def prclib_stacks_test @ \subsubsection{Write an empty process library stack} The most trivial test is to write an uninitialized process library stack. <>= call test (prclib_stacks_1, "prclib_stacks_1", & "write an empty process library stack", & u, results) <>= public :: prclib_stacks_1 <>= subroutine prclib_stacks_1 (u) integer, intent(in) :: u type(prclib_stack_t) :: stack write (u, "(A)") "* Test output: prclib_stacks_1" write (u, "(A)") "* Purpose: display an empty process library stack" write (u, "(A)") call stack%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: prclib_stacks_1" end subroutine prclib_stacks_1 @ %def prclib_stacks_1 @ \subsubsection{Fill a process library stack} Fill a process library stack with two (identical) processes. <>= call test (prclib_stacks_2, "prclib_stacks_2", & "fill a process library stack", & u, results) <>= public :: prclib_stacks_2 <>= subroutine prclib_stacks_2 (u) integer, intent(in) :: u type(prclib_stack_t) :: stack type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: prclib_stacks_2" write (u, "(A)") "* Purpose: fill a process library stack" write (u, "(A)") write (u, "(A)") "* Initialize two (empty) libraries & &and push them on the stack" write (u, "(A)") allocate (lib) call lib%init (var_str ("lib1")) call stack%push (lib) allocate (lib) call lib%init (var_str ("lib2")) call stack%push (lib) call stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: prclib_stacks_2" end subroutine prclib_stacks_2 @ %def prclib_stacks_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Trivial matrix element for tests} For the purpose of testing the workflow, we implement here two matrix elements with the simplest possible structure. This matrix element generator can only generate a single scattering process and a single decay process. The scattering process is a quartic interaction of a massless, neutral and colorless scalar [[s]] with unit coupling results in a trivial $2\to 2$ scattering process. The matrix element is implemented internally, so we do not need the machinery of external process libraries. The decay process is a decay of [[s]] into a pair of colored fermions [[f]]. <<[[prc_test.f90]]>>= <> module prc_test use, intrinsic :: iso_c_binding !NODEP! <> <> use os_interface use particle_specifiers, only: new_prt_spec use process_constants use prclib_interfaces use prc_core_def use process_libraries <> <> <> interface <> end interface contains <> end module prc_test @ %def prc_test @ <<[[prc_test_sub.f90]]>>= <> submodule (prc_test) prc_test_s implicit none contains <> end submodule prc_test_s @ %def prc_test_s @ \subsection{Process definition} For the process definition we implement an extension of the [[prc_core_def_t]] abstract type. <>= public :: prc_test_def_t <>= 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 <> end type prc_test_def_t @ %def prc_test_def_t <>= procedure, nopass :: type_string => prc_test_def_type_string <>= module function prc_test_def_type_string () result (string) type(string_t) :: string end function prc_test_def_type_string <>= module function prc_test_def_type_string () result (string) type(string_t) :: string string = "test_me" end function prc_test_def_type_string @ %def prc_test_def_type_string @ There is no 'feature' here since there is no external code. <>= procedure, nopass :: get_features => prc_test_def_get_features <>= module subroutine prc_test_def_get_features (features) type(string_t), dimension(:), allocatable, intent(out) :: features end subroutine prc_test_def_get_features <>= module subroutine prc_test_def_get_features (features) type(string_t), dimension(:), allocatable, intent(out) :: features allocate (features (0)) end subroutine prc_test_def_get_features @ %def prc_test_def_get_features @ Initialization: set some data (not really useful). <>= procedure :: init => prc_test_def_init <>= module 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 end subroutine prc_test_def_init <>= module 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 @ %def prc_test_def_init @ Write/read process- and method-specific data. (No-op) <>= procedure :: write => prc_test_def_write <>= module subroutine prc_test_def_write (object, unit) class(prc_test_def_t), intent(in) :: object integer, intent(in) :: unit end subroutine prc_test_def_write <>= module subroutine prc_test_def_write (object, unit) class(prc_test_def_t), intent(in) :: object integer, intent(in) :: unit end subroutine prc_test_def_write @ %def prc_test_def_write @ <>= procedure :: read => prc_test_def_read <>= module subroutine prc_test_def_read (object, unit) class(prc_test_def_t), intent(out) :: object integer, intent(in) :: unit end subroutine prc_test_def_read <>= module subroutine prc_test_def_read (object, unit) class(prc_test_def_t), intent(out) :: object integer, intent(in) :: unit end subroutine prc_test_def_read @ %def prc_test_def_read @ Allocate the driver for test ME matrix elements. We get the actual component ID (basename), and we can transfer all process-specific data from the process definition.Due to a bug of bind(C) features with submodules in gfortran 7/8/9 (and maybe together with MPI) this needs to be in the module, not the submodule. <>= procedure :: allocate_driver => prc_test_def_allocate_driver <>= subroutine prc_test_def_allocate_driver (object, driver, basename) class(prc_test_def_t), intent(in) :: object class(prc_core_driver_t), intent(out), allocatable :: driver type(string_t), intent(in) :: basename allocate (prc_test_t :: driver) select type (driver) type is (prc_test_t) driver%id = basename driver%model_name = object%model_name select case (size (object%prt_in)) case (1); driver%scattering = .false. case (2); driver%scattering = .true. end select end select end subroutine prc_test_def_allocate_driver @ %def prc_test_def_allocate_driver @ Nothing to connect. This subroutine will not be called. <>= procedure :: connect => prc_test_def_connect <>= module subroutine prc_test_def_connect (def, lib_driver, i, proc_driver) class(prc_test_def_t), intent(in) :: def class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver end subroutine prc_test_def_connect <>= module subroutine prc_test_def_connect (def, lib_driver, i, proc_driver) class(prc_test_def_t), intent(in) :: def class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver end subroutine prc_test_def_connect @ %def prc_test_def_connect @ \subsection{Driver} <>= public :: prc_test_t <>= type, extends (process_driver_internal_t) :: prc_test_t type(string_t) :: id type(string_t) :: model_name logical :: scattering = .true. contains <> end type prc_test_t @ %def prc_test_t @ In contrast to generic matrix-element implementations, we can hard-wire the amplitude method as a type-bound procedure. <>= procedure, nopass :: get_amplitude => prc_test_get_amplitude <>= module function prc_test_get_amplitude (p) result (amp) complex(default) :: amp real(default), dimension(:,:), intent(in) :: p end function prc_test_get_amplitude <>= module function prc_test_get_amplitude (p) result (amp) complex(default) :: amp real(default), dimension(:,:), intent(in) :: p amp = 1 end function prc_test_get_amplitude @ %def prc_test_get_amplitude @ The reported type is the same as for the [[prc_test_def_t]] type. <>= procedure, nopass :: type_name => prc_test_type_name <>= module function prc_test_type_name () result (string) type(string_t) :: string end function prc_test_type_name <>= module function prc_test_type_name () result (string) type(string_t) :: string string = "test_me" end function prc_test_type_name @ %def prc_test_type_name @ Fill process constants. <>= procedure :: fill_constants => prc_test_fill_constants <>= module subroutine prc_test_fill_constants (driver, data) class(prc_test_t), intent(in) :: driver type(process_constants_t), intent(out) :: data end subroutine prc_test_fill_constants <>= module subroutine prc_test_fill_constants (driver, data) class(prc_test_t), intent(in) :: driver type(process_constants_t), intent(out) :: data data%id = driver%id data%model_name = driver%model_name if (driver%scattering) then data%n_in = 2 data%n_out = 2 data%n_flv = 1 data%n_hel = 1 data%n_col = 1 data%n_cin = 2 data%n_cf = 1 allocate (data%flv_state (4, 1)) data%flv_state = 25 allocate (data%hel_state (4, 1)) data%hel_state = 0 allocate (data%col_state (2, 4, 1)) data%col_state = 0 allocate (data%ghost_flag (4, 1)) data%ghost_flag = .false. allocate (data%color_factors (1)) data%color_factors = 1 allocate (data%cf_index (2, 1)) data%cf_index = 1 else data%n_in = 1 data%n_out = 2 data%n_flv = 1 data%n_hel = 2 data%n_col = 1 data%n_cin = 2 data%n_cf = 1 allocate (data%flv_state (3, 1)) data%flv_state(:,1) = [25, 6, -6] allocate (data%hel_state (3, 2)) data%hel_state(:,1) = [0, 1,-1] data%hel_state(:,2) = [0,-1, 1] allocate (data%col_state (2, 3, 1)) data%col_state = reshape ([0,0, 1,0, 0,-1], [2,3,1]) allocate (data%ghost_flag (3, 1)) data%ghost_flag = .false. allocate (data%color_factors (1)) data%color_factors = 3 allocate (data%cf_index (2, 1)) data%cf_index = 1 end if end subroutine prc_test_fill_constants @ %def prc_test_fill_constants @ \subsection{Shortcut} Since this module is there for testing purposes, we set up a subroutine that does all the work at once: create a library with the two processes (scattering and decay), configure and load, and set up the driver. Due to a bug of bind(C) features with submodules in gfortran 7/8/9 (and maybe together with MPI) this needs to be in the module, not the submodule. <>= public :: prc_test_create_library <>= 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 type(os_data_t) :: os_data logical :: sca, dec sca = .true.; if (present (scattering)) sca = scattering dec = .false.; if (present (decay)) dec = decay call os_data%init () 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 if (dec) then if (present (procname2)) then procname = procname2 else procname = libname end if if (allocated (prt_in)) deallocate (prt_in, prt_out) allocate (prt_in (1), prt_out (2)) prt_in = [var_str ("s")] prt_out = [var_str ("f"), var_str ("fbar")] 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 = 1, 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_decay"), & variant = def) call lib%append (entry) end if call lib%configure (os_data) call lib%load (os_data) end subroutine prc_test_create_library @ %def prc_test_create_library @ \subsection{Unit Test} Test module, followed by the corresponding implementation module. <<[[prc_test_ut.f90]]>>= <> module prc_test_ut use unit_tests use prc_test_uti <> <> contains <> end module prc_test_ut @ %def prc_test_ut @ <<[[prc_test_uti.f90]]>>= <> module prc_test_uti <> <> use os_interface use particle_specifiers, only: new_prt_spec use process_constants use prc_core_def use process_libraries use prc_test <> <> contains <> end module prc_test_uti @ %def prc_test_ut @ API: driver for the unit tests below. <>= public :: prc_test_test <>= subroutine prc_test_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine prc_test_test @ %def prc_test_test @ \subsubsection{Generate and load the scattering process} The process is $s s \to s s$, where $s$ is a trivial scalar particle, for vanishing mass and unit coupling. We initialize the process, build the library, and compute the particular matrix element for momenta of unit energy and right-angle scattering. (The scattering is independent of angle.) The matrix element is equal to unity. <>= call test (prc_test_1, "prc_test_1", & "build and load trivial process", & u, results) <>= public :: prc_test_1 <>= subroutine prc_test_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(process_library_t) :: lib class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry type(string_t) :: model_name type(string_t), dimension(:), allocatable :: prt_in, prt_out type(process_constants_t) :: data class(prc_core_driver_t), allocatable :: driver real(default), dimension(0:3,4) :: p integer :: i write (u, "(A)") "* Test output: prc_test_1" write (u, "(A)") "* Purpose: create a trivial process" write (u, "(A)") "* build a library and & &access the matrix element" write (u, "(A)") write (u, "(A)") "* Initialize a process library with one entry" write (u, "(A)") call os_data%init () call lib%init (var_str ("prc_test1")) model_name = "Test" 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 (var_str ("prc_test1_a"), 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) write (u, "(A)") "* Configure library" write (u, "(A)") call lib%configure (os_data) write (u, "(A)") "* Load library" write (u, "(A)") call lib%load (os_data) call lib%write (u) write (u, "(A)") write (u, "(A)") "* Probe library API:" write (u, "(A)") write (u, "(1x,A,L1)") "is active = ", & lib%is_active () write (u, "(1x,A,I0)") "n_processes = ", & lib%get_n_processes () write (u, "(A)") write (u, "(A)") "* Constants of prc_test1_a_i1:" write (u, "(A)") call lib%connect_process (var_str ("prc_test1_a"), 1, data, driver) write (u, "(1x,A,A)") "component ID = ", char (data%id) write (u, "(1x,A,A)") "model name = ", char (data%model_name) write (u, "(1x,A,A,A)") "md5sum = '", data%md5sum, "'" write (u, "(1x,A,L1)") "openmp supported = ", data%openmp_supported write (u, "(1x,A,I0)") "n_in = ", data%n_in write (u, "(1x,A,I0)") "n_out = ", data%n_out write (u, "(1x,A,I0)") "n_flv = ", data%n_flv write (u, "(1x,A,I0)") "n_hel = ", data%n_hel write (u, "(1x,A,I0)") "n_col = ", data%n_col write (u, "(1x,A,I0)") "n_cin = ", data%n_cin write (u, "(1x,A,I0)") "n_cf = ", data%n_cf write (u, "(1x,A,10(1x,I0))") "flv state =", data%flv_state write (u, "(1x,A,10(1x,I2))") "hel state =", data%hel_state(:,1) write (u, "(1x,A,10(1x,I0))") "col state =", data%col_state write (u, "(1x,A,10(1x,L1))") "ghost flag =", data%ghost_flag write (u, "(1x,A,10(1x,F5.3))") "color factors =", data%color_factors write (u, "(1x,A,10(1x,I0))") "cf index =", data%cf_index write (u, "(A)") write (u, "(A)") "* Set kinematics:" write (u, "(A)") p = reshape ([ & 1.0_default, 0.0_default, 0.0_default, 1.0_default, & 1.0_default, 0.0_default, 0.0_default,-1.0_default, & 1.0_default, 1.0_default, 0.0_default, 0.0_default, & 1.0_default,-1.0_default, 0.0_default, 0.0_default & ], [4,4]) do i = 1, 4 write (u, "(2x,A,I0,A,4(1x,F7.4))") "p", i, " =", p(:,i) end do write (u, "(A)") write (u, "(A)") "* Compute matrix element:" write (u, "(A)") select type (driver) type is (prc_test_t) write (u, "(1x,A,1x,E11.4)") "|amp| =", abs (driver%get_amplitude (p)) end select call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: prc_test_1" end subroutine prc_test_1 @ %def prc_test_1 @ \subsubsection{Shortcut} This is identical to the previous test, but we create the library be a single command. This is handy for other modules which use the test process. <>= call test (prc_test_2, "prc_test_2", & "build and load trivial process using shortcut", & u, results) <>= public :: prc_test_2 <>= subroutine prc_test_2 (u) integer, intent(in) :: u type(process_library_t) :: lib class(prc_core_driver_t), allocatable :: driver type(process_constants_t) :: data real(default), dimension(0:3,4) :: p write (u, "(A)") "* Test output: prc_test_2" write (u, "(A)") "* Purpose: create a trivial process" write (u, "(A)") "* build a library and & &access the matrix element" write (u, "(A)") write (u, "(A)") "* Build and load a process library with one entry" call prc_test_create_library (var_str ("prc_test2"), lib) call lib%connect_process (var_str ("prc_test2"), 1, data, driver) p = reshape ([ & 1.0_default, 0.0_default, 0.0_default, 1.0_default, & 1.0_default, 0.0_default, 0.0_default,-1.0_default, & 1.0_default, 1.0_default, 0.0_default, 0.0_default, & 1.0_default,-1.0_default, 0.0_default, 0.0_default & ], [4,4]) write (u, "(A)") write (u, "(A)") "* Compute matrix element:" write (u, "(A)") select type (driver) type is (prc_test_t) write (u, "(1x,A,1x,E11.4)") "|amp| =", abs (driver%get_amplitude (p)) end select call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: prc_test_2" end subroutine prc_test_2 @ %def prc_test_2 @ \subsubsection{Generate and load the decay process} The process is $s \to f\bar f$, where $s$ is a trivial scalar particle and $f$ is a colored fermion. We initialize the process, build the library, and compute the particular matrix element for a fixed momentum configuration. (The decay is independent of angle.) The matrix element is equal to unity. <>= call test (prc_test_3, "prc_test_3", & "build and load trivial decay", & u, results) <>= public :: prc_test_3 <>= subroutine prc_test_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(process_library_t) :: lib class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry type(string_t) :: model_name type(string_t), dimension(:), allocatable :: prt_in, prt_out type(process_constants_t) :: data class(prc_core_driver_t), allocatable :: driver real(default), dimension(0:3,3) :: p integer :: i write (u, "(A)") "* Test output: prc_test_3" write (u, "(A)") "* Purpose: create a trivial decay process" write (u, "(A)") "* build a library and & &access the matrix element" write (u, "(A)") write (u, "(A)") "* Initialize a process library with one entry" write (u, "(A)") call os_data%init () call lib%init (var_str ("prc_test3")) model_name = "Test" allocate (prt_in (1), prt_out (2)) prt_in = [var_str ("s")] prt_out = [var_str ("f"), var_str ("F")] 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 (var_str ("prc_test3_a"), model_name = model_name, & n_in = 1, 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) write (u, "(A)") "* Configure library" write (u, "(A)") call lib%configure (os_data) write (u, "(A)") "* Load library" write (u, "(A)") call lib%load (os_data) call lib%write (u) write (u, "(A)") write (u, "(A)") "* Probe library API:" write (u, "(A)") write (u, "(1x,A,L1)") "is active = ", & lib%is_active () write (u, "(1x,A,I0)") "n_processes = ", & lib%get_n_processes () write (u, "(A)") write (u, "(A)") "* Constants of prc_test3_a_i1:" write (u, "(A)") call lib%connect_process (var_str ("prc_test3_a"), 1, data, driver) write (u, "(1x,A,A)") "component ID = ", char (data%id) write (u, "(1x,A,A)") "model name = ", char (data%model_name) write (u, "(1x,A,A,A)") "md5sum = '", data%md5sum, "'" write (u, "(1x,A,L1)") "openmp supported = ", data%openmp_supported write (u, "(1x,A,I0)") "n_in = ", data%n_in write (u, "(1x,A,I0)") "n_out = ", data%n_out write (u, "(1x,A,I0)") "n_flv = ", data%n_flv write (u, "(1x,A,I0)") "n_hel = ", data%n_hel write (u, "(1x,A,I0)") "n_col = ", data%n_col write (u, "(1x,A,I0)") "n_cin = ", data%n_cin write (u, "(1x,A,I0)") "n_cf = ", data%n_cf write (u, "(1x,A,10(1x,I0))") "flv state =", data%flv_state write (u, "(1x,A,10(1x,I2))") "hel state =", data%hel_state(:,1) write (u, "(1x,A,10(1x,I2))") "hel state =", data%hel_state(:,2) write (u, "(1x,A,10(1x,I0))") "col state =", data%col_state write (u, "(1x,A,10(1x,L1))") "ghost flag =", data%ghost_flag write (u, "(1x,A,10(1x,F5.3))") "color factors =", data%color_factors write (u, "(1x,A,10(1x,I0))") "cf index =", data%cf_index write (u, "(A)") write (u, "(A)") "* Set kinematics:" write (u, "(A)") p = reshape ([ & 125._default, 0.0_default, 0.0_default, 0.0_default, & 62.5_default, 0.0_default, 0.0_default, 62.5_default, & 62.5_default, 0.0_default, 0.0_default,-62.5_default & ], [4,3]) do i = 1, 3 write (u, "(2x,A,I0,A,4(1x,F8.4))") "p", i, " =", p(:,i) end do write (u, "(A)") write (u, "(A)") "* Compute matrix element:" write (u, "(A)") select type (driver) type is (prc_test_t) write (u, "(1x,A,1x,E11.4)") "|amp| =", abs (driver%get_amplitude (p)) end select call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: prc_test_3" end subroutine prc_test_3 @ %def prc_test_3 @ \subsubsection{Shortcut} This is identical to the previous test, but we create the library be a single command. This is handy for other modules which use the test process. <>= call test (prc_test_4, "prc_test_4", & "build and load trivial decay using shortcut", & u, results) <>= public :: prc_test_4 <>= subroutine prc_test_4 (u) integer, intent(in) :: u type(process_library_t) :: lib class(prc_core_driver_t), allocatable :: driver type(process_constants_t) :: data real(default), dimension(0:3,3) :: p write (u, "(A)") "* Test output: prc_test_4" write (u, "(A)") "* Purpose: create a trivial decay process" write (u, "(A)") "* build a library and & &access the matrix element" write (u, "(A)") write (u, "(A)") "* Build and load a process library with one entry" call prc_test_create_library (var_str ("prc_test4"), lib, & scattering=.false., decay=.true.) call lib%connect_process (var_str ("prc_test4"), 1, data, driver) p = reshape ([ & 125._default, 0.0_default, 0.0_default, 0.0_default, & 62.5_default, 0.0_default, 0.0_default, 62.5_default, & 62.5_default, 0.0_default, 0.0_default,-62.5_default & ], [4,3]) write (u, "(A)") write (u, "(A)") "* Compute matrix element:" write (u, "(A)") select type (driver) type is (prc_test_t) write (u, "(1x,A,1x,E11.4)") "|amp| =", abs (driver%get_amplitude (p)) end select call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: prc_test_4" end subroutine prc_test_4 @ %def prc_test_4