Index: trunk/TODO =================================================================== --- trunk/TODO (revision 8234) +++ trunk/TODO (revision 8235) @@ -1,63 +0,0 @@ -WHIZARD Core -* 2.8 - - EWA implementation (some progress in 2.2.0-2) - - integration of multiple observables (cf. VAMP) - - reenabling underlying event - -* 2.9 - - Mathematica interface - - Parton shower matching (MLM done, CKKW pending) - - GUI extension (partially done) - - Dark Matter - -* 3.0 - - Tau decay module - -O'Mega -* 2.8 - - arbitrary Lorentz structure - - flavor sums - - model files unification - - helicity optimization (numerically done/analytically pending) - -* 2.8 - - W-gamma couplings to resonances - - W' - -VAMP -* 2.8 - - unify naming conventions for types with WHIZARD (JR will do, - e.g. type :: division -> division_t (partially done) -* 2.9 - - integration of multiple observables - -Misc -* Release 2.8 - - Manual + O'Mega Paper (partially done) - -* 2.8 - - review gamelan (partially done, esp. docu) - - -VAMP -* reenable as much PURE and ELEMENTAL as possible and try to make - the `poor man's elemental procedures' in pmep.nw obsolete. - -Longer term: - -* replace pointers by allocatable arrays (using deep copy?) - -* try to declare WK's PRC_INDEX as OPTIONAL - -* try to declare WK's PRC_INDEX more abstractly - - - -CIRCE2 -* fix multi channel distributions with singularities at x = 0 - -* find a better way to test distributions with delta contributions - -* update the documentation - -* add sensible installcheck for the library (and sample data files) Index: trunk/src/process_integration/process_integration.nw =================================================================== --- trunk/src/process_integration/process_integration.nw (revision 8234) +++ trunk/src/process_integration/process_integration.nw (revision 8235) @@ -1,19157 +1,19156 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: integration and process objects and such %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Integration and Process Objects} \includemodulegraph{process_integration} This is the central part of the \whizard\ package. It provides the functionality for evaluating structure functions, kinematics and matrix elements, integration and event generation. It combines the various parts that deal with those tasks individually and organizes the data transfer between them. \begin{description} \item[subevt\_expr] This enables process observables as (abstract) expressions, to be evaluated for each process call. \item[parton\_states] A [[parton_state_t]] object represents an elementary partonic interaction. There are two versions: one for the isolated elementary process, one for the elementary process convoluted with the structure-function chain. The parton state is an effective state. It needs not coincide with the seed-kinematics state which is used in evaluating phase space. \item[process] Here, all pieces are combined for the purpose of evaluating the elementary processes. The whole algorithm is coded in terms of abstract data types as defined in the appropriate modules: [[prc_core]] for matrix-element evaluation, [[prc_core_def]] for the associated configuration and driver, [[sf_base]] for beams and structure-functions, [[phs_base]] for phase space, and [[mci_base]] for integration and event generation. \item[process\_config] \item[process\_counter] Very simple object for statistics \item[process\_mci] \item[pcm] \item[kinematics] \item[instances] While the above modules set up all static information, the instances have the changing event data. There are term and process instances but no component instances. \item[process\_stacks] Process stacks collect process objects. \end{description} We combine here hard interactions, phase space, and (for scatterings) structure functions and interfaces them to the integration module. The process object implements the combination of a fixed beam and structure-function setup with a number of elementary processes. The latter are called process components. The process object represents an entity which is supposedly observable. It should be meaningful to talk about the cross section of a process. The individual components of a process are, technically, processes themselves, but they may have unphysical cross sections which have to be added for a physical result. Process components may be exclusive tree-level elementary processes, dipole subtraction term, loop corrections, etc. The beam and structure function setup is common to all process components. Thus, there is only one instance of this part. The process may be a scattering process or a decay process. In the latter case, there are no structure functions, and the beam setup consists of a single particle. Otherwise, the two classes are treated on the same footing. Once a sampling point has been chosen, a process determines a set of partons with a correlated density matrix of quantum numbers. In general, each sampling point will generate, for each process component, one or more distinct parton configurations. This is the [[computed]] state. The computed state is the subject of the multi-channel integration algorithm. For NLO computations, it is necessary to project the computed states onto another set of parton configurations (e.g., by recombining certain pairs). This is the [[observed]] state. When computing partonic observables, the information is taken from the observed state. For the purpose of event generation, we will later select one parton configuration from the observed state and collapse the correlated quantum state. This configuration is then dressed by applying parton shower, decays and hadronization. The decay chain, in particular, combines a scattering process with possible subsequent decay processes on the parton level, which are full-fledged process objects themselves. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process observables} We define an abstract [[subevt_expr_t]] object as an extension of the [[subevt_t]] type. The object contains a local variable list, variable instances (as targets for pointers in the variable list), and evaluation trees. The evaluation trees reference both the variables and the [[subevt]]. There are two instances of the abstract type: one for process instances, one for physical events. Both have a common logical expression [[selection]] which determines whether the object passes user-defined cuts. The intention is that we fill the [[subevt_t]] base object and compute the variables once we have evaluated a kinematical phase space point (or a complete event). We then evaluate the expressions and can use the results in further calculations. The [[process_expr_t]] extension contains furthermore scale and weight expressions. The [[event_expr_t]] extension contains a reweighting-factor expression and a logical expression for event analysis. In practice, we will link the variable list of the [[event_obs]] object to the variable list of the currently active [[process_obs]] object, such that the process variables are available to both objects. Event variables are meaningful only for physical events. Note that there are unit tests, but they are deferred to the [[expr_tests]] module. <<[[subevt_expr.f90]]>>= <> module subevt_expr <> <> use constants, only: zero, one use io_units use format_utils, only: write_separator use diagnostics use lorentz use subevents use variables use flavors use quantum_numbers use interactions use particles use expr_base <> <> <> <> contains <> end module subevt_expr @ %def subevt_expr @ \subsection{Abstract base type} <>= type, extends (subevt_t), abstract :: subevt_expr_t logical :: subevt_filled = .false. type(var_list_t) :: var_list real(default) :: sqrts_hat = 0 integer :: n_in = 0 integer :: n_out = 0 integer :: n_tot = 0 logical :: has_selection = .false. class(expr_t), allocatable :: selection logical :: colorize_subevt = .false. contains <> end type subevt_expr_t @ %def subevt_expr_t @ Output: Base and extended version. We already have a [[write]] routine for the [[subevt_t]] parent type. <>= procedure :: base_write => subevt_expr_write <>= subroutine subevt_expr_write (object, unit, pacified) class(subevt_expr_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacified integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Local variables:" call write_separator (u) call var_list_write (object%var_list, u, follow_link=.false., & pacified = pacified) call write_separator (u) if (object%subevt_filled) then call object%subevt_t%write (u, pacified = pacified) if (object%has_selection) then call write_separator (u) write (u, "(1x,A)") "Selection expression:" call write_separator (u) call object%selection%write (u) end if else write (u, "(1x,A)") "subevt: [undefined]" end if end subroutine subevt_expr_write @ %def subevt_expr_write @ Finalizer. <>= procedure (subevt_expr_final), deferred :: final procedure :: base_final => subevt_expr_final <>= subroutine subevt_expr_final (object) class(subevt_expr_t), intent(inout) :: object call object%var_list%final () if (object%has_selection) then call object%selection%final () end if end subroutine subevt_expr_final @ %def subevt_expr_final @ \subsection{Initialization} Initialization: define local variables and establish pointers. The common variables are [[sqrts]] (the nominal beam energy, fixed), [[sqrts_hat]] (the actual energy), [[n_in]], [[n_out]], and [[n_tot]] for the [[subevt]]. With the exception of [[sqrts]], all are implemented as pointers to subobjects. <>= procedure (subevt_expr_setup_vars), deferred :: setup_vars procedure :: base_setup_vars => subevt_expr_setup_vars <>= subroutine subevt_expr_setup_vars (expr, sqrts) class(subevt_expr_t), intent(inout), target :: expr real(default), intent(in) :: sqrts call expr%var_list%final () call var_list_append_real (expr%var_list, & var_str ("sqrts"), sqrts, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_real_ptr (expr%var_list, & var_str ("sqrts_hat"), expr%sqrts_hat, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_int_ptr (expr%var_list, & var_str ("n_in"), expr%n_in, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_int_ptr (expr%var_list, & var_str ("n_out"), expr%n_out, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_int_ptr (expr%var_list, & var_str ("n_tot"), expr%n_tot, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic = .true.) end subroutine subevt_expr_setup_vars @ %def subevt_expr_setup_vars @ Append the subevent expr (its base-type core) itself to the variable list, if it is not yet present. <>= procedure :: setup_var_self => subevt_expr_setup_var_self <>= subroutine subevt_expr_setup_var_self (expr) class(subevt_expr_t), intent(inout), target :: expr if (.not. expr%var_list%contains (var_str ("@evt"))) then call var_list_append_subevt_ptr & (expr%var_list, & var_str ("@evt"), expr%subevt_t, & is_known = expr%subevt_filled, & locked = .true., verbose = .false., intrinsic=.true.) end if end subroutine subevt_expr_setup_var_self @ %def subevt_expr_setup_var_self @ Link a variable list to the local one. This could be done event by event, but before evaluating expressions. <>= procedure :: link_var_list => subevt_expr_link_var_list <>= subroutine subevt_expr_link_var_list (expr, var_list) class(subevt_expr_t), intent(inout) :: expr type(var_list_t), intent(in), target :: var_list call expr%var_list%link (var_list) end subroutine subevt_expr_link_var_list @ %def subevt_expr_link_var_list @ Compile the selection expression. If there is no expression, the build method won't allocate the expression object. <>= procedure :: setup_selection => subevt_expr_setup_selection <>= subroutine subevt_expr_setup_selection (expr, ef_cuts) class(subevt_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_cuts call ef_cuts%build (expr%selection) if (allocated (expr%selection)) then call expr%setup_var_self () call expr%selection%setup_lexpr (expr%var_list) expr%has_selection = .true. end if end subroutine subevt_expr_setup_selection @ %def subevt_expr_setup_selection @ (De)activate color storage and evaluation for the expression. The subevent particles will have color information. <>= procedure :: colorize => subevt_expr_colorize <>= subroutine subevt_expr_colorize (expr, colorize_subevt) class(subevt_expr_t), intent(inout), target :: expr logical, intent(in) :: colorize_subevt expr%colorize_subevt = colorize_subevt end subroutine subevt_expr_colorize @ %def subevt_expr_colorize @ \subsection{Evaluation} Reset to initial state, i.e., mark the [[subevt]] as invalid. <>= procedure :: reset_contents => subevt_expr_reset_contents procedure :: base_reset_contents => subevt_expr_reset_contents <>= subroutine subevt_expr_reset_contents (expr) class(subevt_expr_t), intent(inout) :: expr expr%subevt_filled = .false. end subroutine subevt_expr_reset_contents @ %def subevt_expr_reset_contents @ Evaluate the selection expression and return the result. There is also a deferred version: this should evaluate the remaining expressions if the event has passed. <>= procedure :: base_evaluate => subevt_expr_evaluate <>= subroutine subevt_expr_evaluate (expr, passed) class(subevt_expr_t), intent(inout) :: expr logical, intent(out) :: passed if (expr%has_selection) then call expr%selection%evaluate () if (expr%selection%is_known ()) then passed = expr%selection%get_log () else call msg_error ("Evaluate selection expression: result undefined") passed = .false. end if else passed = .true. end if end subroutine subevt_expr_evaluate @ %def subevt_expr_evaluate @ \subsection{Implementation for partonic events} This implementation contains the expressions that we can evaluate for the partonic process during integration. <>= public :: parton_expr_t <>= type, extends (subevt_expr_t) :: parton_expr_t integer, dimension(:), allocatable :: i_beam integer, dimension(:), allocatable :: i_in integer, dimension(:), allocatable :: i_out logical :: has_scale = .false. logical :: has_fac_scale = .false. logical :: has_ren_scale = .false. logical :: has_weight = .false. class(expr_t), allocatable :: scale class(expr_t), allocatable :: fac_scale class(expr_t), allocatable :: ren_scale class(expr_t), allocatable :: weight contains <> end type parton_expr_t @ %def parton_expr_t @ Finalizer. <>= procedure :: final => parton_expr_final <>= subroutine parton_expr_final (object) class(parton_expr_t), intent(inout) :: object call object%base_final () if (object%has_scale) then call object%scale%final () end if if (object%has_fac_scale) then call object%fac_scale%final () end if if (object%has_ren_scale) then call object%ren_scale%final () end if if (object%has_weight) then call object%weight%final () end if end subroutine parton_expr_final @ %def parton_expr_final @ Output: continue writing the active expressions, after the common selection expression. Note: the [[prefix]] argument is declared in the [[write]] method of the [[subevt_t]] base type. Here, it is unused. <>= procedure :: write => parton_expr_write <>= subroutine parton_expr_write (object, unit, prefix, pacified) class(parton_expr_t), intent(in) :: object integer, intent(in), optional :: unit character(*), intent(in), optional :: prefix logical, intent(in), optional :: pacified integer :: u u = given_output_unit (unit) call object%base_write (u, pacified = pacified) if (object%subevt_filled) then if (object%has_scale) then call write_separator (u) write (u, "(1x,A)") "Scale expression:" call write_separator (u) call object%scale%write (u) end if if (object%has_fac_scale) then call write_separator (u) write (u, "(1x,A)") "Factorization scale expression:" call write_separator (u) call object%fac_scale%write (u) end if if (object%has_ren_scale) then call write_separator (u) write (u, "(1x,A)") "Renormalization scale expression:" call write_separator (u) call object%ren_scale%write (u) end if if (object%has_weight) then call write_separator (u) write (u, "(1x,A)") "Weight expression:" call write_separator (u) call object%weight%write (u) end if end if end subroutine parton_expr_write @ %def parton_expr_write @ Define variables. <>= procedure :: setup_vars => parton_expr_setup_vars <>= subroutine parton_expr_setup_vars (expr, sqrts) class(parton_expr_t), intent(inout), target :: expr real(default), intent(in) :: sqrts call expr%base_setup_vars (sqrts) end subroutine parton_expr_setup_vars @ %def parton_expr_setup_vars @ Compile the scale expressions. If a pointer is disassociated, there is no expression. <>= procedure :: setup_scale => parton_expr_setup_scale procedure :: setup_fac_scale => parton_expr_setup_fac_scale procedure :: setup_ren_scale => parton_expr_setup_ren_scale <>= subroutine parton_expr_setup_scale (expr, ef_scale) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_scale call ef_scale%build (expr%scale) if (allocated (expr%scale)) then call expr%setup_var_self () call expr%scale%setup_expr (expr%var_list) expr%has_scale = .true. end if end subroutine parton_expr_setup_scale subroutine parton_expr_setup_fac_scale (expr, ef_fac_scale) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_fac_scale call ef_fac_scale%build (expr%fac_scale) if (allocated (expr%fac_scale)) then call expr%setup_var_self () call expr%fac_scale%setup_expr (expr%var_list) expr%has_fac_scale = .true. end if end subroutine parton_expr_setup_fac_scale subroutine parton_expr_setup_ren_scale (expr, ef_ren_scale) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_ren_scale call ef_ren_scale%build (expr%ren_scale) if (allocated (expr%ren_scale)) then call expr%setup_var_self () call expr%ren_scale%setup_expr (expr%var_list) expr%has_ren_scale = .true. end if end subroutine parton_expr_setup_ren_scale @ %def parton_expr_setup_scale @ %def parton_expr_setup_fac_scale @ %def parton_expr_setup_ren_scale @ Compile the weight expression. <>= procedure :: setup_weight => parton_expr_setup_weight <>= subroutine parton_expr_setup_weight (expr, ef_weight) class(parton_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_weight call ef_weight%build (expr%weight) if (allocated (expr%weight)) then call expr%setup_var_self () call expr%weight%setup_expr (expr%var_list) expr%has_weight = .true. end if end subroutine parton_expr_setup_weight @ %def parton_expr_setup_weight @ Filling the partonic state consists of two parts. The first routine prepares the subevt without assigning momenta. It takes the particles from an [[interaction_t]]. It needs the indices and flavors for the beam, incoming, and outgoing particles. We can assume that the particle content of the subevt does not change. Therefore, we set the event variables [[n_in]], [[n_out]], [[n_tot]] already in this initialization step. <>= procedure :: setup_subevt => parton_expr_setup_subevt <>= subroutine parton_expr_setup_subevt (expr, int, & i_beam, i_in, i_out, f_beam, f_in, f_out) class(parton_expr_t), intent(inout) :: expr type(interaction_t), intent(in), target :: int integer, dimension(:), intent(in) :: i_beam, i_in, i_out type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out allocate (expr%i_beam (size (i_beam))) allocate (expr%i_in (size (i_in))) allocate (expr%i_out (size (i_out))) expr%i_beam = i_beam expr%i_in = i_in expr%i_out = i_out call interaction_to_subevt (int, & expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t) call subevt_set_pdg_beam (expr%subevt_t, f_beam%get_pdg ()) call subevt_set_pdg_incoming (expr%subevt_t, f_in%get_pdg ()) call subevt_set_pdg_outgoing (expr%subevt_t, f_out%get_pdg ()) call subevt_set_p2_beam (expr%subevt_t, f_beam%get_mass () ** 2) call subevt_set_p2_incoming (expr%subevt_t, f_in%get_mass () ** 2) call subevt_set_p2_outgoing (expr%subevt_t, f_out%get_mass () ** 2) expr%n_in = size (i_in) expr%n_out = size (i_out) expr%n_tot = expr%n_in + expr%n_out end subroutine parton_expr_setup_subevt @ %def parton_expr_setup_subevt @ Transfer PDG codes, masses (initalization) and momenta to a predefined subevent. We use the flavor assignment of the first branch in the interaction state matrix. Only incoming and outgoing particles are transferred. Switch momentum sign for incoming particles. <>= interface interaction_momenta_to_subevt module procedure interaction_momenta_to_subevt_id module procedure interaction_momenta_to_subevt_tr end interface <>= subroutine interaction_to_subevt (int, j_beam, j_in, j_out, subevt) type(interaction_t), intent(in), target :: int integer, dimension(:), intent(in) :: j_beam, j_in, j_out type(subevt_t), intent(out) :: subevt type(flavor_t), dimension(:), allocatable :: flv integer :: n_beam, n_in, n_out, i, j allocate (flv (int%get_n_tot ())) flv = quantum_numbers_get_flavor (int%get_quantum_numbers (1)) n_beam = size (j_beam) n_in = size (j_in) n_out = size (j_out) call subevt_init (subevt, n_beam + n_in + n_out) do i = 1, n_beam j = j_beam(i) call subevt_set_beam (subevt, i, & flv(j)%get_pdg (), & vector4_null, & flv(j)%get_mass () ** 2) end do do i = 1, n_in j = j_in(i) call subevt_set_incoming (subevt, n_beam + i, & flv(j)%get_pdg (), & vector4_null, & flv(j)%get_mass () ** 2) end do do i = 1, n_out j = j_out(i) call subevt_set_outgoing (subevt, n_beam + n_in + i, & flv(j)%get_pdg (), & vector4_null, & flv(j)%get_mass () ** 2) end do end subroutine interaction_to_subevt subroutine interaction_momenta_to_subevt_id (int, j_beam, j_in, j_out, subevt) type(interaction_t), intent(in) :: int integer, dimension(:), intent(in) :: j_beam, j_in, j_out type(subevt_t), intent(inout) :: subevt call subevt_set_p_beam (subevt, - int%get_momenta (j_beam)) call subevt_set_p_incoming (subevt, - int%get_momenta (j_in)) call subevt_set_p_outgoing (subevt, int%get_momenta (j_out)) end subroutine interaction_momenta_to_subevt_id subroutine interaction_momenta_to_subevt_tr & (int, j_beam, j_in, j_out, lt, subevt) type(interaction_t), intent(in) :: int integer, dimension(:), intent(in) :: j_beam, j_in, j_out type(subevt_t), intent(inout) :: subevt type(lorentz_transformation_t), intent(in) :: lt call subevt_set_p_beam & (subevt, - lt * int%get_momenta (j_beam)) call subevt_set_p_incoming & (subevt, - lt * int%get_momenta (j_in)) call subevt_set_p_outgoing & (subevt, lt * int%get_momenta (j_out)) end subroutine interaction_momenta_to_subevt_tr @ %def interaction_momenta_to_subevt @ The second part takes the momenta from the interaction object and thus completes the subevt. The partonic energy can then be computed. <>= procedure :: fill_subevt => parton_expr_fill_subevt <>= subroutine parton_expr_fill_subevt (expr, int) class(parton_expr_t), intent(inout) :: expr type(interaction_t), intent(in), target :: int call interaction_momenta_to_subevt (int, & expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t) expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t) expr%subevt_filled = .true. end subroutine parton_expr_fill_subevt @ %def parton_expr_fill_subevt @ Evaluate, if the event passes the selection. For absent expressions we take default values. <>= procedure :: evaluate => parton_expr_evaluate <>= subroutine parton_expr_evaluate & (expr, passed, scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation) class(parton_expr_t), intent(inout) :: expr logical, intent(out) :: passed real(default), intent(out) :: scale real(default), intent(out) :: fac_scale real(default), intent(out) :: ren_scale real(default), intent(out) :: weight real(default), intent(in), allocatable, optional :: scale_forced logical, intent(in), optional :: force_evaluation logical :: force_scale, force_eval force_scale = .false.; force_eval = .false. if (present (scale_forced)) force_scale = allocated (scale_forced) if (present (force_evaluation)) force_eval = force_evaluation call expr%base_evaluate (passed) if (passed .or. force_eval) then if (force_scale) then scale = scale_forced else if (expr%has_scale) then call expr%scale%evaluate () if (expr%scale%is_known ()) then scale = expr%scale%get_real () else call msg_error ("Evaluate scale expression: result undefined") scale = zero end if else scale = expr%sqrts_hat end if if (force_scale) then fac_scale = scale_forced else if (expr%has_fac_scale) then call expr%fac_scale%evaluate () if (expr%fac_scale%is_known ()) then fac_scale = expr%fac_scale%get_real () else call msg_error ("Evaluate factorization scale expression: & &result undefined") fac_scale = zero end if else fac_scale = scale end if if (force_scale) then ren_scale = scale_forced else if (expr%has_ren_scale) then call expr%ren_scale%evaluate () if (expr%ren_scale%is_known ()) then ren_scale = expr%ren_scale%get_real () else call msg_error ("Evaluate renormalization scale expression: & &result undefined") ren_scale = zero end if else ren_scale = scale end if if (expr%has_weight) then call expr%weight%evaluate () if (expr%weight%is_known ()) then weight = expr%weight%get_real () else call msg_error ("Evaluate weight expression: result undefined") weight = zero end if else weight = one end if else weight = zero end if end subroutine parton_expr_evaluate @ %def parton_expr_evaluate @ Return the beam/incoming parton indices. <>= procedure :: get_beam_index => parton_expr_get_beam_index procedure :: get_in_index => parton_expr_get_in_index <>= subroutine parton_expr_get_beam_index (expr, i_beam) class(parton_expr_t), intent(in) :: expr integer, dimension(:), intent(out) :: i_beam i_beam = expr%i_beam end subroutine parton_expr_get_beam_index subroutine parton_expr_get_in_index (expr, i_in) class(parton_expr_t), intent(in) :: expr integer, dimension(:), intent(out) :: i_in i_in = expr%i_in end subroutine parton_expr_get_in_index @ %def parton_expr_get_beam_index @ %def parton_expr_get_in_index @ \subsection{Implementation for full events} This implementation contains the expressions that we can evaluate for the full event. It also contains data that pertain to the event, suitable for communication with external event formats. These data simultaneously serve as pointer targets for the variable lists hidden in the expressions (eval trees). Squared matrix element and weight values: when reading events from file, the [[ref]] value is the number in the file, while the [[prc]] value is the number that we calculate from the momenta in the file, possibly with different parameters. When generating events the first time, or if we do not recalculate, the numbers should coincide. Furthermore, the array of [[alt]] values is copied from an array of alternative event records. These values should represent calculated values. <>= public :: event_expr_t <>= type, extends (subevt_expr_t) :: event_expr_t logical :: has_reweight = .false. logical :: has_analysis = .false. class(expr_t), allocatable :: reweight class(expr_t), allocatable :: analysis logical :: has_id = .false. type(string_t) :: id logical :: has_num_id = .false. integer :: num_id = 0 logical :: has_index = .false. integer :: index = 0 logical :: has_sqme_ref = .false. real(default) :: sqme_ref = 0 logical :: has_sqme_prc = .false. real(default) :: sqme_prc = 0 logical :: has_weight_ref = .false. real(default) :: weight_ref = 0 logical :: has_weight_prc = .false. real(default) :: weight_prc = 0 logical :: has_excess_prc = .false. real(default) :: excess_prc = 0 integer :: n_alt = 0 logical :: has_sqme_alt = .false. real(default), dimension(:), allocatable :: sqme_alt logical :: has_weight_alt = .false. real(default), dimension(:), allocatable :: weight_alt contains <> end type event_expr_t @ %def event_expr_t @ Finalizer for the expressions. <>= procedure :: final => event_expr_final <>= subroutine event_expr_final (object) class(event_expr_t), intent(inout) :: object call object%base_final () if (object%has_reweight) then call object%reweight%final () end if if (object%has_analysis) then call object%analysis%final () end if end subroutine event_expr_final @ %def event_expr_final @ Output: continue writing the active expressions, after the common selection expression. Note: the [[prefix]] argument is declared in the [[write]] method of the [[subevt_t]] base type. Here, it is unused. <>= procedure :: write => event_expr_write <>= subroutine event_expr_write (object, unit, prefix, pacified) class(event_expr_t), intent(in) :: object integer, intent(in), optional :: unit character(*), intent(in), optional :: prefix logical, intent(in), optional :: pacified integer :: u u = given_output_unit (unit) call object%base_write (u, pacified = pacified) if (object%subevt_filled) then if (object%has_reweight) then call write_separator (u) write (u, "(1x,A)") "Reweighting expression:" call write_separator (u) call object%reweight%write (u) end if if (object%has_analysis) then call write_separator (u) write (u, "(1x,A)") "Analysis expression:" call write_separator (u) call object%analysis%write (u) end if end if end subroutine event_expr_write @ %def event_expr_write @ Initializer. This is required only for the [[sqme_alt]] and [[weight_alt]] arrays. <>= procedure :: init => event_expr_init <>= subroutine event_expr_init (expr, n_alt) class(event_expr_t), intent(out) :: expr integer, intent(in), optional :: n_alt if (present (n_alt)) then expr%n_alt = n_alt allocate (expr%sqme_alt (n_alt), source = 0._default) allocate (expr%weight_alt (n_alt), source = 0._default) end if end subroutine event_expr_init @ %def event_expr_init @ Define variables. We have the variables of the base type plus specific variables for full events. There is the event index. <>= procedure :: setup_vars => event_expr_setup_vars <>= subroutine event_expr_setup_vars (expr, sqrts) class(event_expr_t), intent(inout), target :: expr real(default), intent(in) :: sqrts call expr%base_setup_vars (sqrts) call var_list_append_string_ptr (expr%var_list, & var_str ("$process_id"), expr%id, & is_known = expr%has_id, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_int_ptr (expr%var_list, & var_str ("process_num_id"), expr%num_id, & is_known = expr%has_num_id, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_real_ptr (expr%var_list, & var_str ("sqme"), expr%sqme_prc, & is_known = expr%has_sqme_prc, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_real_ptr (expr%var_list, & var_str ("sqme_ref"), expr%sqme_ref, & is_known = expr%has_sqme_ref, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_int_ptr (expr%var_list, & var_str ("event_index"), expr%index, & is_known = expr%has_index, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_real_ptr (expr%var_list, & var_str ("event_weight"), expr%weight_prc, & is_known = expr%has_weight_prc, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_real_ptr (expr%var_list, & var_str ("event_weight_ref"), expr%weight_ref, & is_known = expr%has_weight_ref, & locked = .true., verbose = .false., intrinsic = .true.) call var_list_append_real_ptr (expr%var_list, & var_str ("event_excess"), expr%excess_prc, & is_known = expr%has_excess_prc, & locked = .true., verbose = .false., intrinsic = .true.) end subroutine event_expr_setup_vars @ %def event_expr_setup_vars @ Compile the analysis expression. If the pointer is disassociated, there is no expression. <>= procedure :: setup_analysis => event_expr_setup_analysis <>= subroutine event_expr_setup_analysis (expr, ef_analysis) class(event_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_analysis call ef_analysis%build (expr%analysis) if (allocated (expr%analysis)) then call expr%setup_var_self () call expr%analysis%setup_lexpr (expr%var_list) expr%has_analysis = .true. end if end subroutine event_expr_setup_analysis @ %def event_expr_setup_analysis @ Compile the reweight expression. <>= procedure :: setup_reweight => event_expr_setup_reweight <>= subroutine event_expr_setup_reweight (expr, ef_reweight) class(event_expr_t), intent(inout), target :: expr class(expr_factory_t), intent(in) :: ef_reweight call ef_reweight%build (expr%reweight) if (allocated (expr%reweight)) then call expr%setup_var_self () call expr%reweight%setup_expr (expr%var_list) expr%has_reweight = .true. end if end subroutine event_expr_setup_reweight @ %def event_expr_setup_reweight @ Store the string or numeric process ID. This should be done during initialization. <>= procedure :: set_process_id => event_expr_set_process_id procedure :: set_process_num_id => event_expr_set_process_num_id <>= subroutine event_expr_set_process_id (expr, id) class(event_expr_t), intent(inout) :: expr type(string_t), intent(in) :: id expr%id = id expr%has_id = .true. end subroutine event_expr_set_process_id subroutine event_expr_set_process_num_id (expr, num_id) class(event_expr_t), intent(inout) :: expr integer, intent(in) :: num_id expr%num_id = num_id expr%has_num_id = .true. end subroutine event_expr_set_process_num_id @ %def event_expr_set_process_id @ %def event_expr_set_process_num_id @ Reset / set the data that pertain to a particular event. The event index is reset unless explicitly told to keep it. <>= procedure :: reset_contents => event_expr_reset_contents procedure :: set => event_expr_set <>= subroutine event_expr_reset_contents (expr) class(event_expr_t), intent(inout) :: expr call expr%base_reset_contents () expr%has_sqme_ref = .false. expr%has_sqme_prc = .false. expr%has_sqme_alt = .false. expr%has_weight_ref = .false. expr%has_weight_prc = .false. expr%has_weight_alt = .false. expr%has_excess_prc = .false. end subroutine event_expr_reset_contents subroutine event_expr_set (expr, & weight_ref, weight_prc, weight_alt, & excess_prc, & sqme_ref, sqme_prc, sqme_alt) class(event_expr_t), intent(inout) :: expr real(default), intent(in), optional :: weight_ref, weight_prc real(default), intent(in), optional :: excess_prc real(default), intent(in), optional :: sqme_ref, sqme_prc real(default), dimension(:), intent(in), optional :: sqme_alt, weight_alt if (present (sqme_ref)) then expr%has_sqme_ref = .true. expr%sqme_ref = sqme_ref end if if (present (sqme_prc)) then expr%has_sqme_prc = .true. expr%sqme_prc = sqme_prc end if if (present (sqme_alt)) then expr%has_sqme_alt = .true. expr%sqme_alt = sqme_alt end if if (present (weight_ref)) then expr%has_weight_ref = .true. expr%weight_ref = weight_ref end if if (present (weight_prc)) then expr%has_weight_prc = .true. expr%weight_prc = weight_prc end if if (present (weight_alt)) then expr%has_weight_alt = .true. expr%weight_alt = weight_alt end if if (present (excess_prc)) then expr%has_excess_prc = .true. expr%excess_prc = excess_prc end if end subroutine event_expr_set @ %def event_expr_reset_contents event_expr_set @ Access the subevent index. <>= procedure :: has_event_index => event_expr_has_event_index procedure :: get_event_index => event_expr_get_event_index <>= function event_expr_has_event_index (expr) result (flag) class(event_expr_t), intent(in) :: expr logical :: flag flag = expr%has_index end function event_expr_has_event_index function event_expr_get_event_index (expr) result (index) class(event_expr_t), intent(in) :: expr integer :: index if (expr%has_index) then index = expr%index else index = 0 end if end function event_expr_get_event_index @ %def event_expr_has_event_index @ %def event_expr_get_event_index @ Set/increment the subevent index. Initialize it if necessary. <>= procedure :: set_event_index => event_expr_set_event_index procedure :: reset_event_index => event_expr_reset_event_index procedure :: increment_event_index => event_expr_increment_event_index <>= subroutine event_expr_set_event_index (expr, index) class(event_expr_t), intent(inout) :: expr integer, intent(in) :: index expr%index = index expr%has_index = .true. end subroutine event_expr_set_event_index subroutine event_expr_reset_event_index (expr) class(event_expr_t), intent(inout) :: expr expr%has_index = .false. end subroutine event_expr_reset_event_index subroutine event_expr_increment_event_index (expr, offset) class(event_expr_t), intent(inout) :: expr integer, intent(in), optional :: offset if (expr%has_index) then expr%index = expr%index + 1 else if (present (offset)) then call expr%set_event_index (offset + 1) else call expr%set_event_index (1) end if end subroutine event_expr_increment_event_index @ %def event_expr_set_event_index @ %def event_expr_increment_event_index @ Fill the event expression: take the particle data and kinematics from a [[particle_set]] object. We allow the particle content to change for each event. Therefore, we set the event variables each time. Also increment the event index; initialize it if necessary. <>= procedure :: fill_subevt => event_expr_fill_subevt <>= subroutine event_expr_fill_subevt (expr, particle_set) class(event_expr_t), intent(inout) :: expr type(particle_set_t), intent(in) :: particle_set call particle_set%to_subevt (expr%subevt_t, expr%colorize_subevt) expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t) expr%n_in = subevt_get_n_in (expr%subevt_t) expr%n_out = subevt_get_n_out (expr%subevt_t) expr%n_tot = expr%n_in + expr%n_out expr%subevt_filled = .true. end subroutine event_expr_fill_subevt @ %def event_expr_fill_subevt @ Evaluate, if the event passes the selection. For absent expressions we take default values. <>= procedure :: evaluate => event_expr_evaluate <>= subroutine event_expr_evaluate (expr, passed, reweight, analysis_flag) class(event_expr_t), intent(inout) :: expr logical, intent(out) :: passed real(default), intent(out) :: reweight logical, intent(out) :: analysis_flag call expr%base_evaluate (passed) if (passed) then if (expr%has_reweight) then call expr%reweight%evaluate () if (expr%reweight%is_known ()) then reweight = expr%reweight%get_real () else call msg_error ("Evaluate reweight expression: & &result undefined") reweight = 0 end if else reweight = 1 end if if (expr%has_analysis) then call expr%analysis%evaluate () if (expr%analysis%is_known ()) then analysis_flag = expr%analysis%get_log () else call msg_error ("Evaluate analysis expression: & &result undefined") analysis_flag = .false. end if else analysis_flag = .true. end if end if end subroutine event_expr_evaluate @ %def event_expr_evaluate @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Parton states} A [[parton_state_t]] object contains the effective kinematics and dynamics of an elementary partonic interaction, with or without the beam/structure function state included. The type is abstract and has two distinct extensions. The [[isolated_state_t]] extension describes the isolated elementary interaction where the [[int_eff]] subobject contains the complex transition amplitude, exclusive in all quantum numbers. The particle content and kinematics describe the effective partonic state. The [[connected_state_t]] extension contains the partonic [[subevt]] and the expressions for cuts and scales which use it. In the isolated state, the effective partonic interaction may either be identical to the hard interaction, in which case it is just a pointer to the latter. Or it may involve a rearrangement of partons, in which case we allocate it explicitly and flag this by [[int_is_allocated]]. The [[trace]] evaluator contains the absolute square of the effective transition amplitude matrix, summed over final states. It is also summed over initial states, depending on the the beam setup allows. The result is used for integration. The [[matrix]] evaluator is the counterpart of [[trace]] which is kept exclusive in all observable quantum numbers. The [[flows]] evaluator is furthermore exclusive in colors, but neglecting all color interference. The [[matrix]] and [[flows]] evaluators are filled only for sampling points that become part of physical events. Note: It would be natural to make the evaluators allocatable. However, this causes memory corruption in gfortran 4.6.3. The extra [[has_XXX]] flags indicate whether evaluators are active, instead. This module contains no unit tests. The tests are covered by the [[processes]] module below. <<[[parton_states.f90]]>>= <> module parton_states <> use io_units use format_utils, only: write_separator use diagnostics use lorentz use subevents use variables use expr_base use model_data use flavors use helicities use colors use quantum_numbers use state_matrices use polarizations use interactions use evaluators use beams use sf_base use process_constants use prc_core use subevt_expr <> <> <> contains <> end module parton_states @ %def parton_states @ \subsection{Abstract base type} The common part are the evaluators, one for the trace (summed over all quantum numbers), one for the transition matrix (summed only over unobservable quantum numbers), and one for the flow distribution (transition matrix without interferences, exclusive in color flow). <>= type, abstract :: parton_state_t logical :: has_trace = .false. logical :: has_matrix = .false. logical :: has_flows = .false. type(evaluator_t) :: trace type(evaluator_t) :: matrix type(evaluator_t) :: flows contains <> end type parton_state_t @ %def parton_state_t @ The [[isolated_state_t]] extension contains the [[sf_chain_eff]] object and the (hard) effective interaction [[int_eff]], separately, both implemented as a pointer. The evaluators (trace, matrix, flows) apply to the hard interaction only. If the effective interaction differs from the hard interaction, the pointer is allocated explicitly. Analogously for [[sf_chain_eff]]. <>= public :: isolated_state_t <>= type, extends (parton_state_t) :: isolated_state_t logical :: sf_chain_is_allocated = .false. type(sf_chain_instance_t), pointer :: sf_chain_eff => null () logical :: int_is_allocated = .false. type(interaction_t), pointer :: int_eff => null () contains <> end type isolated_state_t @ %def isolated_state_t @ The [[connected_state_t]] extension contains all data that enable the evaluation of observables for the effective connected state. The evaluators connect the (effective) structure-function chain and hard interaction that were kept separate in the [[isolated_state_t]]. The [[flows_sf]] evaluator is an extended copy of the structure-function The [[expr]] subobject consists of the [[subevt]], a simple event record, expressions for cuts etc.\ which refer to this record, and a [[var_list]] which contains event-specific variables, linked to the process variable list. Variables used within the expressions are looked up in [[var_list]]. <>= public :: connected_state_t <>= type, extends (parton_state_t) :: connected_state_t type(state_flv_content_t) :: state_flv logical :: has_flows_sf = .false. type(evaluator_t) :: flows_sf logical :: has_expr = .false. type(parton_expr_t) :: expr contains <> end type connected_state_t @ %def connected_state_t @ Output: each evaluator is written only when it is active. The [[sf_chain]] is only written if it is explicitly allocated. <>= procedure :: write => parton_state_write <>= subroutine parton_state_write (state, unit, testflag) class(parton_state_t), intent(in) :: state integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) select type (state) class is (isolated_state_t) if (state%sf_chain_is_allocated) then call write_separator (u) call state%sf_chain_eff%write (u) end if if (state%int_is_allocated) then call write_separator (u) write (u, "(1x,A)") & "Effective interaction:" call write_separator (u) call state%int_eff%basic_write (u, testflag = testflag) end if class is (connected_state_t) if (state%has_flows_sf) then call write_separator (u) write (u, "(1x,A)") & "Evaluator (extension of the beam evaluator & &with color contractions):" call write_separator (u) call state%flows_sf%write (u, testflag = testflag) end if end select if (state%has_trace) then call write_separator (u) write (u, "(1x,A)") & "Evaluator (trace of the squared transition matrix):" call write_separator (u) call state%trace%write (u, testflag = testflag) end if if (state%has_matrix) then call write_separator (u) write (u, "(1x,A)") & "Evaluator (squared transition matrix):" call write_separator (u) call state%matrix%write (u, testflag = testflag) end if if (state%has_flows) then call write_separator (u) write (u, "(1x,A)") & "Evaluator (squared color-flow matrix):" call write_separator (u) call state%flows%write (u, testflag = testflag) end if select type (state) class is (connected_state_t) if (state%has_expr) then call write_separator (u) call state%expr%write (u) end if end select end subroutine parton_state_write @ %def parton_state_write @ Finalize interaction and evaluators, but only if allocated. <>= procedure :: final => parton_state_final <>= subroutine parton_state_final (state) class(parton_state_t), intent(inout) :: state if (state%has_flows) then call state%flows%final () state%has_flows = .false. end if if (state%has_matrix) then call state%matrix%final () state%has_matrix = .false. end if if (state%has_trace) then call state%trace%final () state%has_trace = .false. end if select type (state) class is (connected_state_t) if (state%has_flows_sf) then call state%flows_sf%final () state%has_flows_sf = .false. end if call state%expr%final () class is (isolated_state_t) if (state%int_is_allocated) then call state%int_eff%final () deallocate (state%int_eff) state%int_is_allocated = .false. end if if (state%sf_chain_is_allocated) then call state%sf_chain_eff%final () end if end select end subroutine parton_state_final @ %def parton_state_final @ \subsection{Common Initialization} Initialize the isolated parton state. In this version, the effective structure-function chain [[sf_chain_eff]] and the effective interaction [[int_eff]] both are trivial pointers to the seed structure-function chain and to the hard interaction, respectively. <>= procedure :: init => isolated_state_init <>= subroutine isolated_state_init (state, sf_chain, int) class(isolated_state_t), intent(out) :: state type(sf_chain_instance_t), intent(in), target :: sf_chain type(interaction_t), intent(in), target :: int state%sf_chain_eff => sf_chain state%int_eff => int end subroutine isolated_state_init @ %def isolated_state_init @ \subsection{Evaluator initialization: isolated state} Create an evaluator for the trace of the squared transition matrix. The trace goes over all outgoing quantum numbers. Whether we trace over incoming quantum numbers other than color, depends on the given [[qn_mask_in]]. There are two options: explicitly computing the color factor table ([[use_cf]] false; [[nc]] defined), or taking the color factor table from the hard matrix element data. <>= procedure :: setup_square_trace => isolated_state_setup_square_trace <>= subroutine isolated_state_setup_square_trace (state, core, & qn_mask_in, col, keep_fs_flavor) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in !!! Actually need allocatable attribute here fore once because col might !!! enter the subroutine non-allocated. integer, intent(in), dimension(:), allocatable :: col logical, intent(in) :: keep_fs_flavor type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask associate (data => core%data) allocate (qn_mask (data%n_in + data%n_out)) qn_mask( : data%n_in) = & quantum_numbers_mask (.false., .true., .false.) & .or. qn_mask_in qn_mask(data%n_in + 1 : ) = & quantum_numbers_mask (.not. keep_fs_flavor, .true., .true.) if (core%use_color_factors) then call state%trace%init_square (state%int_eff, qn_mask, & col_flow_index = data%cf_index, & col_factor = data%color_factors, & col_index_hi = col, & nc = core%nc) else call state%trace%init_square (state%int_eff, qn_mask, nc = core%nc) end if end associate state%has_trace = .true. end subroutine isolated_state_setup_square_trace @ %def isolated_state_setup_square_trace @ Setup an identity-evaluator for the trace. This implies that [[me]] is considered to be a squared amplitude, as for example for BLHA matrix elements. <>= procedure :: setup_identity_trace => isolated_state_setup_identity_trace <>= subroutine isolated_state_setup_identity_trace (state, core, qn_mask_in, & keep_fs_flavors, keep_colors) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in logical, intent(in), optional :: keep_fs_flavors, keep_colors type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask logical :: fs_flv_flag, col_flag fs_flv_flag = .true.; col_flag = .true. if (present(keep_fs_flavors)) fs_flv_flag = .not. keep_fs_flavors if (present(keep_colors)) col_flag = .not. keep_colors associate (data => core%data) allocate (qn_mask (data%n_in + data%n_out)) qn_mask( : data%n_in) = & quantum_numbers_mask (.false., col_flag, .false.) .or. qn_mask_in qn_mask(data%n_in + 1 : ) = & quantum_numbers_mask (fs_flv_flag, col_flag, .true.) end associate call state%int_eff%set_mask (qn_mask) call state%trace%init_identity (state%int_eff) state%has_trace = .true. end subroutine isolated_state_setup_identity_trace @ %def isolated_state_setup_identity_trace @ Setup the evaluator for the transition matrix, exclusive in helicities where this is requested. For all unstable final-state particles we keep polarization according to the applicable decay options. If the process is a decay itself, this applies also to the initial state. For all polarized final-state particles, we keep polarization including off-diagonal entries. We drop helicity completely for unpolarized final-state particles. For the initial state, if the particle has not been handled yet, we apply the provided [[qn_mask_in]] which communicates the beam properties. <>= procedure :: setup_square_matrix => isolated_state_setup_square_matrix <>= subroutine isolated_state_setup_square_matrix & (state, core, model, qn_mask_in, col) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in integer, dimension(:), intent(in) :: col type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask type(flavor_t), dimension(:), allocatable :: flv integer :: i logical :: helmask, helmask_hd associate (data => core%data) allocate (qn_mask (data%n_in + data%n_out)) allocate (flv (data%n_flv)) do i = 1, data%n_in + data%n_out call flv%init (data%flv_state(i,:), model) if ((data%n_in == 1 .or. i > data%n_in) & .and. any (.not. flv%is_stable ())) then helmask = all (flv%decays_isotropically ()) helmask_hd = all (flv%decays_diagonal ()) qn_mask(i) = quantum_numbers_mask (.false., .true., helmask, & mask_hd = helmask_hd) else if (i > data%n_in) then helmask = all (.not. flv%is_polarized ()) qn_mask(i) = quantum_numbers_mask (.false., .true., helmask) else qn_mask(i) = quantum_numbers_mask (.false., .true., .false.) & .or. qn_mask_in(i) end if end do if (core%use_color_factors) then call state%matrix%init_square (state%int_eff, qn_mask, & col_flow_index = data%cf_index, & col_factor = data%color_factors, & col_index_hi = col, & nc = core%nc) else call state%matrix%init_square (state%int_eff, & qn_mask, & nc = core%nc) end if end associate state%has_matrix = .true. end subroutine isolated_state_setup_square_matrix @ %def isolated_state_setup_square_matrix @ This procedure initializes the evaluator that computes the contributions to color flows, neglecting color interference. The incoming-particle mask can be used to sum over incoming flavor. Helicity handling: see above. <>= procedure :: setup_square_flows => isolated_state_setup_square_flows <>= subroutine isolated_state_setup_square_flows (state, core, model, qn_mask_in) class(isolated_state_t), intent(inout), target :: state class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask type(flavor_t), dimension(:), allocatable :: flv integer :: i logical :: helmask, helmask_hd associate (data => core%data) allocate (qn_mask (data%n_in + data%n_out)) allocate (flv (data%n_flv)) do i = 1, data%n_in + data%n_out call flv%init (data%flv_state(i,:), model) if ((data%n_in == 1 .or. i > data%n_in) & .and. any (.not. flv%is_stable ())) then helmask = all (flv%decays_isotropically ()) helmask_hd = all (flv%decays_diagonal ()) qn_mask(i) = quantum_numbers_mask (.false., .false., helmask, & mask_hd = helmask_hd) else if (i > data%n_in) then helmask = all (.not. flv%is_polarized ()) qn_mask(i) = quantum_numbers_mask (.false., .false., helmask) else qn_mask(i) = quantum_numbers_mask (.false., .false., .false.) & .or. qn_mask_in(i) end if end do call state%flows%init_square (state%int_eff, qn_mask, & expand_color_flows = .true.) end associate state%has_flows = .true. end subroutine isolated_state_setup_square_flows @ %def isolated_state_setup_square_flows @ \subsection{Evaluator initialization: connected state} Setup a trace evaluator as a product of two evaluators (incoming state, effective interaction). In the result, all quantum numbers are summed over. If the optional [[int]] interaction is provided, use this for the first factor in the convolution. Otherwise, use the final interaction of the stored [[sf_chain]]. The [[resonant]] flag applies if we want to construct a decay chain. The resonance property can propagate to the final event output. <>= procedure :: setup_connected_trace => connected_state_setup_connected_trace <>= subroutine connected_state_setup_connected_trace & (state, isolated, int, resonant, undo_helicities, & keep_fs_flavors, extended_sf) class(connected_state_t), intent(inout), target :: state type(isolated_state_t), intent(in), target :: isolated type(interaction_t), intent(in), optional, target :: int logical, intent(in), optional :: resonant logical, intent(in), optional :: undo_helicities logical, intent(in), optional :: keep_fs_flavors logical, intent(in), optional :: extended_sf type(quantum_numbers_mask_t) :: mask type(interaction_t), pointer :: src_int, beam_int logical :: reduce, fs_flv_flag call msg_debug (D_PROCESS_INTEGRATION, & "connected_state_setup_connected_trace") reduce = .false.; fs_flv_flag = .true. if (present (undo_helicities)) reduce = undo_helicities if (present (keep_fs_flavors)) fs_flv_flag = .not. keep_fs_flavors mask = quantum_numbers_mask (fs_flv_flag, .true., .true.) if (present (int)) then src_int => int else src_int => isolated%sf_chain_eff%get_out_int_ptr () end if if (debug2_active (D_PROCESS_INTEGRATION)) then call src_int%basic_write () end if call state%trace%init_product (src_int, isolated%trace, & qn_mask_conn = mask, & qn_mask_rest = mask, & connections_are_resonant = resonant, & ignore_sub = extended_sf) if (reduce) then beam_int => isolated%sf_chain_eff%get_beam_int_ptr () call undo_qn_hel (beam_int, mask, beam_int%get_n_tot ()) call undo_qn_hel (src_int, mask, src_int%get_n_tot ()) call beam_int%set_matrix_element (cmplx (1, 0, default)) call src_int%set_matrix_element (cmplx (1, 0, default)) end if state%has_trace = .true. contains subroutine undo_qn_hel (int_in, mask, n_tot) type(interaction_t), intent(inout) :: int_in type(quantum_numbers_mask_t), intent(in) :: mask integer, intent(in) :: n_tot type(quantum_numbers_mask_t), dimension(n_tot) :: mask_in mask_in = mask call int_in%set_mask (mask_in) end subroutine undo_qn_hel end subroutine connected_state_setup_connected_trace @ %def connected_state_setup_connected_trace @ Setup a matrix evaluator as a product of two evaluators (incoming state, effective interation). In the intermediate state, color and helicity is summed over. In the final state, we keep the quantum numbers which are present in the original evaluators. <>= procedure :: setup_connected_matrix => connected_state_setup_connected_matrix <>= subroutine connected_state_setup_connected_matrix & (state, isolated, int, resonant, qn_filter_conn) class(connected_state_t), intent(inout), target :: state type(isolated_state_t), intent(in), target :: isolated type(interaction_t), intent(in), optional, target :: int logical, intent(in), optional :: resonant type(quantum_numbers_t), intent(in), optional :: qn_filter_conn type(quantum_numbers_mask_t) :: mask type(interaction_t), pointer :: src_int mask = quantum_numbers_mask (.false., .true., .true.) if (present (int)) then src_int => int else src_int => isolated%sf_chain_eff%get_out_int_ptr () end if call state%matrix%init_product & (src_int, isolated%matrix, mask, & qn_filter_conn = qn_filter_conn, & connections_are_resonant = resonant) state%has_matrix = .true. end subroutine connected_state_setup_connected_matrix @ %def connected_state_setup_connected_matrix @ Setup a matrix evaluator as a product of two evaluators (incoming state, effective interation). In the intermediate state, only helicity is summed over. In the final state, we keep the quantum numbers which are present in the original evaluators. If the optional [[int]] interaction is provided, use this for the first factor in the convolution. Otherwise, use the final interaction of the stored [[sf_chain]], after creating an intermediate interaction that includes a correlated color state. We assume that for a caller-provided [[int]], this is not necessary. <>= procedure :: setup_connected_flows => connected_state_setup_connected_flows <>= subroutine connected_state_setup_connected_flows & (state, isolated, int, resonant, qn_filter_conn) class(connected_state_t), intent(inout), target :: state type(isolated_state_t), intent(in), target :: isolated type(interaction_t), intent(in), optional, target :: int logical, intent(in), optional :: resonant type(quantum_numbers_t), intent(in), optional :: qn_filter_conn type(quantum_numbers_mask_t) :: mask type(interaction_t), pointer :: src_int mask = quantum_numbers_mask (.false., .false., .true.) if (present (int)) then src_int => int else src_int => isolated%sf_chain_eff%get_out_int_ptr () call state%flows_sf%init_color_contractions (src_int) state%has_flows_sf = .true. src_int => state%flows_sf%interaction_t end if call state%flows%init_product (src_int, isolated%flows, mask, & qn_filter_conn = qn_filter_conn, & connections_are_resonant = resonant) state%has_flows = .true. end subroutine connected_state_setup_connected_flows @ %def connected_state_setup_connected_flows @ Determine and store the flavor content for the connected state. This queries the [[matrix]] evaluator component, which should hold the requested flavor information. <>= procedure :: setup_state_flv => connected_state_setup_state_flv <>= subroutine connected_state_setup_state_flv (state, n_out_hard) class(connected_state_t), intent(inout), target :: state integer, intent(in) :: n_out_hard call interaction_get_flv_content & (state%matrix%interaction_t, state%state_flv, n_out_hard) end subroutine connected_state_setup_state_flv @ %def connected_state_setup_state_flv @ Return the current flavor state object. <>= procedure :: get_state_flv => connected_state_get_state_flv <>= function connected_state_get_state_flv (state) result (state_flv) class(connected_state_t), intent(in) :: state type(state_flv_content_t) :: state_flv state_flv = state%state_flv end function connected_state_get_state_flv @ %def connected_state_get_state_flv @ \subsection{Cuts and expressions} Set up the [[subevt]] that corresponds to the connected interaction. The index arrays refer to the interaction. We assign the particles as follows: the beam particles are the first two (decay process: one) entries in the trace evaluator. The incoming partons are identified by their link to the outgoing partons of the structure-function chain. The outgoing partons are those of the trace evaluator, which include radiated partons during the structure-function chain. <>= procedure :: setup_subevt => connected_state_setup_subevt <>= subroutine connected_state_setup_subevt (state, sf_chain, f_beam, f_in, f_out) class(connected_state_t), intent(inout), target :: state type(sf_chain_instance_t), intent(in), target :: sf_chain type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out integer :: n_beam, n_in, n_out, n_vir, n_tot, i, j integer, dimension(:), allocatable :: i_beam, i_in, i_out integer :: sf_out_i type(interaction_t), pointer :: sf_int sf_int => sf_chain%get_out_int_ptr () n_beam = size (f_beam) n_in = size (f_in) n_out = size (f_out) n_vir = state%trace%get_n_vir () n_tot = state%trace%get_n_tot () allocate (i_beam (n_beam), i_in (n_in), i_out (n_out)) i_beam = [(i, i = 1, n_beam)] do j = 1, n_in sf_out_i = sf_chain%get_out_i (j) i_in(j) = interaction_find_link & (state%trace%interaction_t, sf_int, sf_out_i) end do i_out = [(i, i = n_vir + 1, n_tot)] call state%expr%setup_subevt (state%trace%interaction_t, & i_beam, i_in, i_out, f_beam, f_in, f_out) state%has_expr = .true. end subroutine connected_state_setup_subevt @ %def connected_state_setup_subevt @ Initialize the variable list specific for this state/term. We insert event variables ([[sqrts_hat]]) and link the process variable list. The variable list acquires pointers to subobjects of [[state]], which must therefore have a [[target]] attribute. <>= procedure :: setup_var_list => connected_state_setup_var_list <>= subroutine connected_state_setup_var_list (state, process_var_list, beam_data) class(connected_state_t), intent(inout), target :: state type(var_list_t), intent(in), target :: process_var_list type(beam_data_t), intent(in) :: beam_data call state%expr%setup_vars (beam_data%get_sqrts ()) call state%expr%link_var_list (process_var_list) end subroutine connected_state_setup_var_list @ %def connected_state_setup_var_list @ Allocate the cut expression etc. <>= procedure :: setup_cuts => connected_state_setup_cuts procedure :: setup_scale => connected_state_setup_scale procedure :: setup_fac_scale => connected_state_setup_fac_scale procedure :: setup_ren_scale => connected_state_setup_ren_scale procedure :: setup_weight => connected_state_setup_weight <>= subroutine connected_state_setup_cuts (state, ef_cuts) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_cuts call state%expr%setup_selection (ef_cuts) end subroutine connected_state_setup_cuts subroutine connected_state_setup_scale (state, ef_scale) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_scale call state%expr%setup_scale (ef_scale) end subroutine connected_state_setup_scale subroutine connected_state_setup_fac_scale (state, ef_fac_scale) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_fac_scale call state%expr%setup_fac_scale (ef_fac_scale) end subroutine connected_state_setup_fac_scale subroutine connected_state_setup_ren_scale (state, ef_ren_scale) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_ren_scale call state%expr%setup_ren_scale (ef_ren_scale) end subroutine connected_state_setup_ren_scale subroutine connected_state_setup_weight (state, ef_weight) class(connected_state_t), intent(inout), target :: state class(expr_factory_t), intent(in) :: ef_weight call state%expr%setup_weight (ef_weight) end subroutine connected_state_setup_weight @ %def connected_state_setup_expressions @ Reset the expression object: invalidate the subevt. <>= procedure :: reset_expressions => connected_state_reset_expressions <>= subroutine connected_state_reset_expressions (state) class(connected_state_t), intent(inout) :: state if (state%has_expr) call state%expr%reset_contents () end subroutine connected_state_reset_expressions @ %def connected_state_reset_expressions @ \subsection{Evaluation} Transfer momenta to the trace evaluator and fill the [[subevt]] with this effective kinematics, if applicable. Note: we may want to apply a boost for the [[subevt]]. <>= procedure :: receive_kinematics => parton_state_receive_kinematics <>= subroutine parton_state_receive_kinematics (state) class(parton_state_t), intent(inout), target :: state if (state%has_trace) then call state%trace%receive_momenta () select type (state) class is (connected_state_t) if (state%has_expr) then call state%expr%fill_subevt (state%trace%interaction_t) end if end select end if end subroutine parton_state_receive_kinematics @ %def parton_state_receive_kinematics @ Recover kinematics: We assume that the trace evaluator is filled with momenta. Send those momenta back to the sources, then fill the variables and subevent as above. The incoming momenta of the connected state are not connected to the isolated state but to the beam interaction. Therefore, the incoming momenta within the isolated state do not become defined, yet. Instead, we reconstruct the beam (and ISR) momentum configuration. <>= procedure :: send_kinematics => parton_state_send_kinematics <>= subroutine parton_state_send_kinematics (state) class(parton_state_t), intent(inout), target :: state if (state%has_trace) then call interaction_send_momenta (state%trace%interaction_t) select type (state) class is (connected_state_t) call state%expr%fill_subevt (state%trace%interaction_t) end select end if end subroutine parton_state_send_kinematics @ %def parton_state_send_kinematics @ Evaluate the expressions. The routine evaluates first the cut expression. If the event passes, it evaluates the other expressions. Where no expressions are defined, default values are inserted. <>= procedure :: evaluate_expressions => connected_state_evaluate_expressions <>= subroutine connected_state_evaluate_expressions (state, passed, & scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation) class(connected_state_t), intent(inout) :: state logical, intent(out) :: passed real(default), intent(out) :: scale, fac_scale, ren_scale, weight real(default), intent(in), allocatable, optional :: scale_forced logical, intent(in), optional :: force_evaluation if (state%has_expr) then call state%expr%evaluate (passed, scale, fac_scale, ren_scale, weight, & scale_forced, force_evaluation) end if end subroutine connected_state_evaluate_expressions @ %def connected_state_evaluate_expressions @ Evaluate the structure-function chain, if it is allocated explicitly. The argument is the factorization scale. If the chain is merely a pointer, the chain should already be evaluated at this point. <>= procedure :: evaluate_sf_chain => isolated_state_evaluate_sf_chain <>= subroutine isolated_state_evaluate_sf_chain (state, fac_scale) class(isolated_state_t), intent(inout) :: state real(default), intent(in) :: fac_scale if (state%sf_chain_is_allocated) call state%sf_chain_eff%evaluate (fac_scale) end subroutine isolated_state_evaluate_sf_chain @ %def isolated_state_evaluate_sf_chain @ Evaluate the trace. <>= procedure :: evaluate_trace => parton_state_evaluate_trace <>= subroutine parton_state_evaluate_trace (state) class(parton_state_t), intent(inout) :: state if (state%has_trace) call state%trace%evaluate () end subroutine parton_state_evaluate_trace @ %def parton_state_evaluate_trace <>= procedure :: evaluate_matrix => parton_state_evaluate_matrix <>= subroutine parton_state_evaluate_matrix (state) class(parton_state_t), intent(inout) :: state if (state%has_matrix) call state%matrix%evaluate () end subroutine parton_state_evaluate_matrix @ %def parton_state_evaluate_matrix @ Evaluate the extra evaluators that we need for physical events. <>= procedure :: evaluate_event_data => parton_state_evaluate_event_data <>= subroutine parton_state_evaluate_event_data (state, only_momenta) class(parton_state_t), intent(inout) :: state logical, intent(in), optional :: only_momenta logical :: only_mom only_mom = .false.; if (present (only_momenta)) only_mom = only_momenta select type (state) type is (connected_state_t) if (state%has_flows_sf) then call state%flows_sf%receive_momenta () if (.not. only_mom) call state%flows_sf%evaluate () end if end select if (state%has_matrix) then call state%matrix%receive_momenta () if (.not. only_mom) call state%matrix%evaluate () end if if (state%has_flows) then call state%flows%receive_momenta () if (.not. only_mom) call state%flows%evaluate () end if end subroutine parton_state_evaluate_event_data @ %def parton_state_evaluate_event_data @ Normalize the helicity density matrix by its trace, i.e., factor out the trace and put it into an overall normalization factor. The trace and flow evaluators are unchanged. <>= procedure :: normalize_matrix_by_trace => & parton_state_normalize_matrix_by_trace <>= subroutine parton_state_normalize_matrix_by_trace (state) class(parton_state_t), intent(inout) :: state if (state%has_matrix) call state%matrix%normalize_by_trace () end subroutine parton_state_normalize_matrix_by_trace @ %def parton_state_normalize_matrix_by_trace @ \subsection{Accessing the state} Three functions return a pointer to the event-relevant interactions. <>= procedure :: get_trace_int_ptr => parton_state_get_trace_int_ptr procedure :: get_matrix_int_ptr => parton_state_get_matrix_int_ptr procedure :: get_flows_int_ptr => parton_state_get_flows_int_ptr <>= function parton_state_get_trace_int_ptr (state) result (ptr) class(parton_state_t), intent(in), target :: state type(interaction_t), pointer :: ptr if (state%has_trace) then ptr => state%trace%interaction_t else ptr => null () end if end function parton_state_get_trace_int_ptr function parton_state_get_matrix_int_ptr (state) result (ptr) class(parton_state_t), intent(in), target :: state type(interaction_t), pointer :: ptr if (state%has_matrix) then ptr => state%matrix%interaction_t else ptr => null () end if end function parton_state_get_matrix_int_ptr function parton_state_get_flows_int_ptr (state) result (ptr) class(parton_state_t), intent(in), target :: state type(interaction_t), pointer :: ptr if (state%has_flows) then ptr => state%flows%interaction_t else ptr => null () end if end function parton_state_get_flows_int_ptr @ %def parton_state_get_trace_int_ptr @ %def parton_state_get_matrix_int_ptr @ %def parton_state_get_flows_int_ptr @ Return the indices of the beam particles and the outgoing particles within the trace (and thus, matrix and flows) evaluator, respectively. <>= procedure :: get_beam_index => connected_state_get_beam_index procedure :: get_in_index => connected_state_get_in_index <>= subroutine connected_state_get_beam_index (state, i_beam) class(connected_state_t), intent(in) :: state integer, dimension(:), intent(out) :: i_beam call state%expr%get_beam_index (i_beam) end subroutine connected_state_get_beam_index subroutine connected_state_get_in_index (state, i_in) class(connected_state_t), intent(in) :: state integer, dimension(:), intent(out) :: i_in call state%expr%get_in_index (i_in) end subroutine connected_state_get_in_index @ %def connected_state_get_beam_index @ %def connected_state_get_in_index @ <>= public :: refill_evaluator <>= subroutine refill_evaluator (sqme, qn, flv_index, evaluator) complex(default), intent(in), dimension(:) :: sqme type(quantum_numbers_t), intent(in), dimension(:,:) :: qn integer, intent(in), dimension(:), optional :: flv_index type(evaluator_t), intent(inout) :: evaluator integer :: i, i_flv do i = 1, size (sqme) if (present (flv_index)) then i_flv = flv_index(i) else i_flv = i end if call evaluator%add_to_matrix_element (qn(:,i_flv), sqme(i), & match_only_flavor = .true.) end do end subroutine refill_evaluator @ %def refill_evaluator @ Return the number of outgoing (hard) particles for the state. <>= procedure :: get_n_out => parton_state_get_n_out <>= function parton_state_get_n_out (state) result (n) class(parton_state_t), intent(in), target :: state integer :: n n = state%trace%get_n_out () end function parton_state_get_n_out @ %def parton_state_get_n_out @ \subsection{Unit tests} <<[[parton_states_ut.f90]]>>= <> module parton_states_ut use unit_tests use parton_states_uti <> <> contains <> end module parton_states_ut @ %def parton_states_ut <<[[parton_states_uti.f90]]>>= <> module parton_states_uti <> <> use constants, only: zero use numeric_utils use flavors use colors use helicities use quantum_numbers use sf_base, only: sf_chain_instance_t use state_matrices, only: state_matrix_t use prc_template_me, only: prc_template_me_t use interactions, only: interaction_t use models, only: model_t, create_test_model use parton_states <> <> contains <> end module parton_states_uti @ %def parton_states_uti @ <>= public :: parton_states_test <>= subroutine parton_states_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine parton_states_test @ %def parton_states_test @ \subsubsection{Test a simple isolated state} <>= call test (parton_states_1, "parton_states_1", & "Create a 2 -> 2 isolated state and compute trace", & u, results) <>= public :: parton_states_1 <>= subroutine parton_states_1 (u) integer, intent(in) :: u type(state_matrix_t), allocatable :: state type(flavor_t), dimension(2) :: flv_in type(flavor_t), dimension(2) :: flv_out1, flv_out2 type(flavor_t), dimension(4) :: flv_tot type(helicity_t), dimension(4) :: hel type(color_t), dimension(4) :: col integer :: h1, h2, h3, h4 integer :: f integer :: i type(quantum_numbers_t), dimension(4) :: qn type(prc_template_me_t) :: core type(sf_chain_instance_t), target :: sf_chain type(interaction_t), target :: int type(isolated_state_t) :: isolated_state integer :: n_states = 0 integer, dimension(:), allocatable :: col_flow_index type(quantum_numbers_mask_t), dimension(2) :: qn_mask integer, dimension(8) :: i_allowed_states complex(default), dimension(8) :: me complex(default) :: me_check_tot, me_check_1, me_check_2, me2 logical :: tmp1, tmp2 type(model_t), pointer :: test_model => null () write (u, "(A)") "* Test output: parton_states_1" write (u, "(A)") "* Purpose: Test the standard parton states" write (u, "(A)") call flv_in%init ([11, -11]) call flv_out1%init ([1, -1]) call flv_out2%init ([2, -2]) write (u, "(A)") "* Using incoming flavors: " call flavor_write_array (flv_in, u) write (u, "(A)") "* Two outgoing flavor structures: " call flavor_write_array (flv_out1, u) call flavor_write_array (flv_out2, u) write (u, "(A)") "* Initialize state matrix" allocate (state) call state%init () write (u, "(A)") "* Fill state matrix" call col(3)%init ([1]) call col(4)%init ([-1]) do f = 1, 2 do h1 = -1, 1, 2 do h2 = -1, 1, 2 do h3 = -1, 1, 2 do h4 = -1, 1, 2 n_states = n_states + 1 call hel%init ([h1, h2, h3, h4], [h1, h2, h3, h4]) if (f == 1) then flv_tot = [flv_in, flv_out1] else flv_tot = [flv_in, flv_out2] end if call qn%init (flv_tot, col, hel) call state%add_state (qn) end do end do end do end do end do !!! Two flavors, one color flow, 2 x 2 x 2 x 2 helicity configurations !!! -> 32 states. write (u, "(A)") write (u, "(A,I2)") "* Generated number of states: ", n_states call state%freeze () !!! Indices of the helicity configurations which are non-zero i_allowed_states = [6, 7, 10, 11, 22, 23, 26, 27] me = [cmplx (-1.89448E-5_default, 9.94456E-7_default, default), & cmplx (-8.37887E-2_default, 4.30842E-3_default, default), & cmplx (-1.99997E-1_default, -1.01985E-2_default, default), & cmplx ( 1.79717E-5_default, 9.27038E-7_default, default), & cmplx (-1.74859E-5_default, 8.78819E-7_default, default), & cmplx ( 1.67577E-1_default, -8.61683E-3_default, default), & cmplx ( 2.41331E-1_default, 1.23306E-2_default, default), & cmplx (-3.59435E-5_default, -1.85407E-6_default, default)] me_check_tot = cmplx (zero, zero, default) me_check_1 = cmplx (zero, zero, default) me_check_2 = cmplx (zero, zero, default) do i = 1, 8 me2 = me(i) * conjg (me(i)) me_check_tot = me_check_tot + me2 if (i < 5) then me_check_1 = me_check_1 + me2 else me_check_2 = me_check_2 + me2 end if call state%set_matrix_element (i_allowed_states(i), me(i)) end do !!! Don't forget the color factor me_check_tot = 3._default * me_check_tot me_check_1 = 3._default * me_check_1 me_check_2 = 3._default * me_check_2 write (u, "(A)") write (u, "(A)") "* Setup interaction" call int%basic_init (2, 0, 2, set_relations = .true.) call int%set_state_matrix (state) core%data%n_in = 2; core%data%n_out = 2 core%data%n_flv = 2 allocate (core%data%flv_state (4, 2)) core%data%flv_state (1, :) = [11, 11] core%data%flv_state (2, :) = [-11, -11] core%data%flv_state (3, :) = [1, 2] core%data%flv_state (4, :) = [-1, -2] core%use_color_factors = .false. core%nc = 3 write (u, "(A)") "* Init isolated state" call isolated_state%init (sf_chain, int) !!! There is only one color flow. allocate (col_flow_index (n_states)); col_flow_index = 1 call qn_mask%init (.false., .false., .true., mask_cg = .false.) write (u, "(A)") "* Give a trace to the isolated state" call isolated_state%setup_square_trace (core, qn_mask, col_flow_index, .false.) call isolated_state%evaluate_trace () write (u, "(A)") write (u, "(A)", advance = "no") "* Squared matrix element correct: " write (u, "(L1)") nearly_equal (me_check_tot, & isolated_state%trace%get_matrix_element (1), rel_smallness = 0.00001_default) write (u, "(A)") "* Give a matrix to the isolated state" call create_test_model (var_str ("SM"), test_model) call isolated_state%setup_square_matrix (core, test_model, qn_mask, col_flow_index) call isolated_state%evaluate_matrix () write (u, "(A)") "* Sub-matrixelements correct: " tmp1 = nearly_equal (me_check_1, & isolated_state%matrix%get_matrix_element (1), rel_smallness = 0.00001_default) tmp2 = nearly_equal (me_check_2, & isolated_state%matrix%get_matrix_element (2), rel_smallness = 0.00001_default) write (u, "(A,L1,A,L1)") "* 1: ", tmp1, ", 2: ", tmp2 write (u, "(A)") "* Test output end: parton_states_1" end subroutine parton_states_1 @ %def parton_states_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process component management} This module contains tools for managing and combining process components and matrix-element code and values, acting at a level below the actual process definition. \subsection{Abstract base type} The types introduced here are abstract base types. <<[[pcm_base.f90]]>>= <> module pcm_base <> use io_units use diagnostics use format_utils, only: write_integer_array use format_utils, only: write_separator use physics_defs, only: BORN, NLO_REAL <> use os_interface, only: os_data_t use process_libraries, only: process_component_def_t use process_libraries, only: process_library_t use prc_core_def use prc_core use variables, only: var_list_t use mappings, only: mapping_defaults_t use phs_base, only: phs_config_t use phs_forests, only: phs_parameters_t use mci_base, only: mci_t use model_data, only: model_data_t use models, only: model_t use blha_config, only: blha_master_t use blha_olp_interfaces, only: blha_template_t use process_config use process_mci, only: process_mci_entry_t <> <> <> <> <> contains <> end module pcm_base @ %def pcm_base @ \subsection{Core management} This object holds information about the cores used by the components and allocates the corresponding manager instance. [[i_component]] is the index of the process component which this core belongs to. The pointer to the core definition is a convenient help in configuring the core itself. We allow for a [[blha_config]] configuration object that covers BLHA cores. The BLHA standard is suitable generic to warrant support outside of specific type extension (i.e., applies to LO and NLO if requested). The BLHA configuration is allocated only if the core requires it. <>= public :: core_entry_t <>= type :: core_entry_t integer :: i_component = 0 logical :: active = .false. class(prc_core_def_t), pointer :: core_def => null () type(blha_template_t), allocatable :: blha_config class(prc_core_t), allocatable :: core contains <> end type core_entry_t @ %def core_entry_t @ <>= procedure :: get_core_ptr => core_entry_get_core_ptr <>= function core_entry_get_core_ptr (core_entry) result (core) class(core_entry_t), intent(in), target :: core_entry class(prc_core_t), pointer :: core if (allocated (core_entry%core)) then core => core_entry%core else core => null () end if end function core_entry_get_core_ptr @ %def core_entry_get_core_ptr @ Configure the core object after allocation with correct type. The [[core_def]] object pointer and the index [[i_component]] of the associated process component are already there. <>= procedure :: configure => core_entry_configure <>= subroutine core_entry_configure (core_entry, lib, id) class(core_entry_t), intent(inout) :: core_entry type(process_library_t), intent(in), target :: lib type(string_t), intent(in) :: id call core_entry%core%init & (core_entry%core_def, lib, id, core_entry%i_component) end subroutine core_entry_configure @ %def core_entry_configure @ \subsection{Process component manager} This object may hold process and method-specific data, and it should allocate the corresponding manager instance. The number of components determines the [[component_selected]] array. [[i_phs_config]] is a lookup table that returns the PHS configuration index for a given component index. [[i_core]] is a lookup table that returns the core-entry index for a given component index. <>= public :: pcm_t <>= type, abstract :: pcm_t logical :: initialized = .false. logical :: has_pdfs = .false. integer :: n_components = 0 integer :: n_cores = 0 integer :: n_mci = 0 logical, dimension(:), allocatable :: component_selected logical, dimension(:), allocatable :: component_active integer, dimension(:), allocatable :: i_phs_config integer, dimension(:), allocatable :: i_core integer, dimension(:), allocatable :: i_mci type(blha_template_t) :: blha_defaults logical :: uses_blha = .false. type(os_data_t) :: os_data contains <> end type pcm_t @ %def pcm_t @ The factory method. We use the [[inout]] intent, so calling this again is an error. <>= procedure(pcm_allocate_instance), deferred :: allocate_instance <>= abstract interface subroutine pcm_allocate_instance (pcm, instance) import class(pcm_t), intent(in) :: pcm class(pcm_instance_t), intent(inout), allocatable :: instance end subroutine pcm_allocate_instance end interface @ %def pcm_allocate_instance @ <>= procedure(pcm_is_nlo), deferred :: is_nlo <>= abstract interface function pcm_is_nlo (pcm) result (is_nlo) import logical :: is_nlo class(pcm_t), intent(in) :: pcm end function pcm_is_nlo end interface @ %def pcm_is_nlo @ <>= procedure(pcm_final), deferred :: final <>= abstract interface subroutine pcm_final (pcm) import class(pcm_t), intent(inout) :: pcm end subroutine pcm_final end interface @ %def pcm_final @ \subsection{Initialization methods} The PCM has the duty to coordinate and configure the process-object components. Initialize the PCM configuration itself, using environment data. <>= procedure(pcm_init), deferred :: init <>= abstract interface subroutine pcm_init (pcm, env, meta) import class(pcm_t), intent(out) :: pcm type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta end subroutine pcm_init end interface @ %def pcm_init @ Initialize the BLHA configuration block, the component-independent default settings. This is to be called by [[pcm_init]]. We use the provided variable list. This block is filled regardless of whether BLHA is actually used, because why not? We use a default value for the scheme (not set in unit tests). <>= procedure :: set_blha_defaults => pcm_set_blha_defaults <>= subroutine pcm_set_blha_defaults (pcm, polarized_beams, var_list) class(pcm_t), intent(inout) :: pcm type(var_list_t), intent(in) :: var_list logical, intent(in) :: polarized_beams logical :: muon_yukawa_off real(default) :: top_yukawa type(string_t) :: ew_scheme muon_yukawa_off = & var_list%get_lval (var_str ("?openloops_switch_off_muon_yukawa")) top_yukawa = & var_list%get_rval (var_str ("blha_top_yukawa")) ew_scheme = & var_list%get_sval (var_str ("$blha_ew_scheme")) if (ew_scheme == "") ew_scheme = "Gmu" call pcm%blha_defaults%init & (polarized_beams, muon_yukawa_off, top_yukawa, ew_scheme) end subroutine pcm_set_blha_defaults @ %def pcm_set_blha_defaults @ Read the method settings from the variable list and store them in the BLHA master. The details depend on the [[pcm]] concrete type. <>= procedure(pcm_set_blha_methods), deferred :: set_blha_methods <>= abstract interface subroutine pcm_set_blha_methods (pcm, blha_master, var_list) import class(pcm_t), intent(in) :: pcm type(blha_master_t), intent(inout) :: blha_master type(var_list_t), intent(in) :: var_list end subroutine pcm_set_blha_methods end interface @ %def pcm_set_blha_methods @ Produce the LO and NLO flavor-state tables (as far as available), as appropriate for BLHA configuration. We may inspect either the PCM itself or the array of process cores. <>= procedure(pcm_get_blha_flv_states), deferred :: get_blha_flv_states <>= abstract interface subroutine pcm_get_blha_flv_states (pcm, core_entry, flv_born, flv_real) import class(pcm_t), intent(in) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry integer, dimension(:,:), allocatable, intent(out) :: flv_born integer, dimension(:,:), allocatable, intent(out) :: flv_real end subroutine pcm_get_blha_flv_states end interface @ %def pcm_get_blha_flv_states @ Allocate the right number of process components. The number is also stored in the process meta. Initially, all components are active but none are selected. <>= procedure :: allocate_components => pcm_allocate_components <>= subroutine pcm_allocate_components (pcm, comp, meta) class(pcm_t), intent(inout) :: pcm type(process_component_t), dimension(:), allocatable, intent(out) :: comp type(process_metadata_t), intent(in) :: meta pcm%n_components = meta%n_components allocate (comp (pcm%n_components)) allocate (pcm%component_selected (pcm%n_components), source = .false.) allocate (pcm%component_active (pcm%n_components), source = .true.) end subroutine pcm_allocate_components @ %def pcm_allocate_components @ Each process component belongs to a category/type, which we identify by a universal integer constant. The categories can be taken from the process definition. For easy lookup, we store the categories in an array. <>= procedure(pcm_categorize_components), deferred :: categorize_components <>= abstract interface subroutine pcm_categorize_components (pcm, config) import class(pcm_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config end subroutine pcm_categorize_components end interface @ %def pcm_categorize_components @ Allocate the right number and type(s) of process-core objects, i.e., the interface object between the process and matrix-element code. Within the [[pcm]] block, also associate cores with components and store relevant configuration data, including the [[i_core]] lookup table. <>= procedure(pcm_allocate_cores), deferred :: allocate_cores <>= abstract interface subroutine pcm_allocate_cores (pcm, config, core_entry) import class(pcm_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry end subroutine pcm_allocate_cores end interface @ %def pcm_allocate_cores @ Generate and interface external code for a single core, if this is required. <>= procedure(pcm_prepare_any_external_code), deferred :: & prepare_any_external_code <>= abstract interface subroutine pcm_prepare_any_external_code & (pcm, core_entry, i_core, libname, model, var_list) import class(pcm_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry integer, intent(in) :: i_core type(string_t), intent(in) :: libname type(model_data_t), intent(in), target :: model type(var_list_t), intent(in) :: var_list end subroutine pcm_prepare_any_external_code end interface @ %def pcm_prepare_any_external_code @ Prepare the BLHA configuration for a core object that requires it. This does not affect the core object, which may not yet be allocated. <>= procedure(pcm_setup_blha), deferred :: setup_blha <>= abstract interface subroutine pcm_setup_blha (pcm, core_entry) import class(pcm_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry end subroutine pcm_setup_blha end interface @ %def pcm_setup_blha @ Configure the BLHA interface for a core object that requires it. This is separate from the previous method, assuming that the [[pcm]] has to allocate the actual cores and acquire some data in-between. <>= procedure(pcm_prepare_blha_core), deferred :: prepare_blha_core <>= abstract interface subroutine pcm_prepare_blha_core (pcm, core_entry, model) import class(pcm_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry class(model_data_t), intent(in), target :: model end subroutine pcm_prepare_blha_core end interface @ %def pcm_prepare_blha_core @ Allocate and configure the MCI (multi-channel integrator) records and their relation to process components, appropriate for the algorithm implemented by [[pcm]]. Create a [[mci_t]] template: the procedure [[dispatch_mci]] is called as a factory method for allocating the [[mci_t]] object with a specific concrete type. The call may depend on the concrete [[pcm]] type. <>= public :: dispatch_mci_proc <>= abstract interface subroutine dispatch_mci_proc (mci, var_list, process_id, is_nlo) import class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo end subroutine dispatch_mci_proc end interface @ %def dispatch_mci_proc <>= procedure(pcm_setup_mci), deferred :: setup_mci procedure(pcm_call_dispatch_mci), deferred :: call_dispatch_mci <>= abstract interface subroutine pcm_setup_mci (pcm, mci_entry) import class(pcm_t), intent(inout) :: pcm type(process_mci_entry_t), & dimension(:), allocatable, intent(out) :: mci_entry end subroutine pcm_setup_mci end interface abstract interface subroutine pcm_call_dispatch_mci (pcm, & dispatch_mci, var_list, process_id, mci_template) import class(pcm_t), intent(inout) :: pcm procedure(dispatch_mci_proc) :: dispatch_mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id class(mci_t), intent(out), allocatable :: mci_template end subroutine pcm_call_dispatch_mci end interface @ %def pcm_setup_mci @ %def pcm_call_dispatch_mci @ Proceed with PCM configuration based on the core and component configuration data. Base version is empty. <>= procedure(pcm_complete_setup), deferred :: complete_setup <>= abstract interface subroutine pcm_complete_setup (pcm, core_entry, component, model) import class(pcm_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry type(process_component_t), dimension(:), intent(inout) :: component type(model_t), intent(in), target :: model end subroutine pcm_complete_setup end interface @ %def pcm_complete_setup @ \subsubsection{Retrieve information} Return the core index that belongs to a particular component. <>= procedure :: get_i_core => pcm_get_i_core <>= function pcm_get_i_core (pcm, i_component) result (i_core) class(pcm_t), intent(in) :: pcm integer, intent(in) :: i_component integer :: i_core if (allocated (pcm%i_core)) then i_core = pcm%i_core(i_component) else i_core = 0 end if end function pcm_get_i_core @ %def pcm_get_i_core @ \subsubsection{Phase-space configuration} Allocate and initialize the right number and type(s) of phase-space configuration entries. The [[i_phs_config]] lookup table must be set accordingly. <>= procedure(pcm_init_phs_config), deferred :: init_phs_config <>= abstract interface subroutine pcm_init_phs_config & (pcm, phs_entry, meta, env, phs_par, mapping_defs) import class(pcm_t), intent(inout) :: pcm type(process_phs_config_t), & dimension(:), allocatable, intent(out) :: phs_entry type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env type(mapping_defaults_t), intent(in) :: mapping_defs type(phs_parameters_t), intent(in) :: phs_par end subroutine pcm_init_phs_config end interface @ %def pcm_init_phs_config @ Initialize a single component. We require all process-configuration blocks, and specific templates for the phase-space and integrator configuration. We also provide the current component index [[i]] and the [[active]] flag. <>= procedure(pcm_init_component), deferred :: init_component <>= abstract interface subroutine pcm_init_component & (pcm, component, i, active, phs_config, env, meta, config) import class(pcm_t), intent(in) :: pcm type(process_component_t), intent(out) :: component integer, intent(in) :: i logical, intent(in) :: active class(phs_config_t), allocatable, intent(in) :: phs_config type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config end subroutine pcm_init_component end interface @ %def pcm_init_component @ Record components in the process [[meta]] data if they have turned out to be inactive. <>= procedure :: record_inactive_components => pcm_record_inactive_components <>= subroutine pcm_record_inactive_components (pcm, component, meta) class(pcm_t), intent(inout) :: pcm type(process_component_t), dimension(:), intent(in) :: component type(process_metadata_t), intent(inout) :: meta integer :: i pcm%component_active = component%active do i = 1, pcm%n_components if (.not. component(i)%active) call meta%deactivate_component (i) end do end subroutine pcm_record_inactive_components @ %def pcm_record_inactive_components @ \subsection{Manager instance} This object deals with the actual (squared) matrix element values. <>= public :: pcm_instance_t <>= type, abstract :: pcm_instance_t class(pcm_t), pointer :: config => null () logical :: bad_point = .false. contains <> end type pcm_instance_t @ %def pcm_instance_t @ <>= procedure(pcm_instance_final), deferred :: final <>= abstract interface subroutine pcm_instance_final (pcm_instance) import class(pcm_instance_t), intent(inout) :: pcm_instance end subroutine pcm_instance_final end interface @ %def pcm_instance_final @ <>= procedure :: link_config => pcm_instance_link_config <>= subroutine pcm_instance_link_config (pcm_instance, config) class(pcm_instance_t), intent(inout) :: pcm_instance class(pcm_t), intent(in), target :: config pcm_instance%config => config end subroutine pcm_instance_link_config @ %def pcm_instance_link_config @ <>= procedure :: is_valid => pcm_instance_is_valid <>= function pcm_instance_is_valid (pcm_instance) result (valid) logical :: valid class(pcm_instance_t), intent(in) :: pcm_instance valid = .not. pcm_instance%bad_point end function pcm_instance_is_valid @ %def pcm_instance_is_valid @ <>= procedure :: set_bad_point => pcm_instance_set_bad_point <>= pure subroutine pcm_instance_set_bad_point (pcm_instance, bad_point) class(pcm_instance_t), intent(inout) :: pcm_instance logical, intent(in) :: bad_point pcm_instance%bad_point = pcm_instance%bad_point .or. bad_point end subroutine pcm_instance_set_bad_point @ %def pcm_instance_set_bad_point @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The process object} <<[[process.f90]]>>= <> module process <> <> use io_units use format_utils, only: write_separator use constants use diagnostics use numeric_utils use lorentz use cputime use md5 use rng_base use dispatch_rng, only: dispatch_rng_factory use dispatch_rng, only: update_rng_seed_in_var_list use os_interface use sm_qcd use integration_results use mci_base use flavors use model_data use models use physics_defs use process_libraries use process_constants use particles use variables use beam_structures use beams use interactions use pdg_arrays use expr_base use sf_base use sf_mappings use resonances, only: resonance_history_t, resonance_history_set_t use prc_test_core, only: test_t use prc_core_def, only: prc_core_def_t use prc_core, only: prc_core_t, helicity_selection_t use prc_external, only: prc_external_t use prc_recola, only: prc_recola_t use blha_olp_interfaces, only: prc_blha_t, blha_template_t use prc_threshold, only: prc_threshold_t use phs_fks, only: phs_fks_config_t use phs_base use mappings, only: mapping_defaults_t use phs_forests, only: phs_parameters_t use phs_wood, only: phs_wood_config_t use phs_wood, only: EXTENSION_DEFAULT, EXTENSION_DGLAP use dispatch_phase_space, only: dispatch_phs use blha_config, only: blha_master_t use nlo_data, only: FKS_DEFAULT, FKS_RESONANCES use parton_states, only: connected_state_t use pcm_base use pcm use process_counter use process_config use process_mci <> <> <> <> <> contains <> end module process @ %def process @ \subsection{Process status} Store counter and status information in a process object. <>= type :: process_status_t private end type process_status_t @ %def process_status_t @ \subsection{Process status} Store integration results in a process object. <>= type :: process_results_t private end type process_results_t @ %def process_results_t @ \subsection{The process type} A process object is the workspace for the process instance. After initialization, its contents are filled by integration passes which shape the integration grids and compute cross sections. Processes are set up initially from user-level configuration data. After calculating integrals and thus developing integration grid data, the program may use a process object or a copy of it for the purpose of generating events. The process object consists of several subobjects with their specific purposes. The corresponding types are defined below. (Technically, the subobject type definitions have to come before the process type definition, but with NOWEB magic we reverse this order here.) The [[type]] determines whether we are considering a decay or a scattering process. The [[meta]] object describes the process and its environment. All contents become fixed when the object is initialized. The [[config]] object holds physical and technical configuration data that have been obtained during process initialization, and which are common to all process components. The individual process components are configured in the [[component]] objects. These objects contain more configuration parameters and workspace, as needed for the specific process variant. The [[term]] objects describe parton configurations which are technically used as phase-space points. Each process component may split into several terms with distinct kinematics and particle content. Furthermore, each term may project on a different physical state, e.g., by particle recombination. The [[term]] object provides the framework for this projection, for applying cuts, weight, and thus completing the process calculation. The [[beam_config]] object describes the incoming particles, either the decay mother or the scattering beams. It also contains the structure-function information. The [[mci_entry]] objects configure a MC input parameter set and integrator, each. The number of parameters depends on the process component and on the beam and structure-function setup. The [[pcm]] component is the process-component manager. This polymorphic object manages and hides the details of dealing with NLO processes where several components have to be combined in a non-trivial way. It also acts as an abstract factory for the corresponding object in [[process_instance]], which does the actual work for this matter. <>= public :: process_t <>= type :: process_t private type(process_metadata_t) :: & meta type(process_environment_t) :: & env type(process_config_data_t) :: & config class(pcm_t), allocatable :: & pcm type(process_component_t), dimension(:), allocatable :: & component type(process_phs_config_t), dimension(:), allocatable :: & phs_entry type(core_entry_t), dimension(:), allocatable :: & core_entry type(process_mci_entry_t), dimension(:), allocatable :: & mci_entry class(rng_factory_t), allocatable :: & rng_factory type(process_beam_config_t) :: & beam_config type(process_term_t), dimension(:), allocatable :: & term type(process_status_t) :: & status type(process_results_t) :: & result contains <> end type process_t @ %def process_t @ \subsection{Process pointer} Wrapper type for storing pointers to process objects in arrays. <>= public :: process_ptr_t <>= type :: process_ptr_t type(process_t), pointer :: p => null () end type process_ptr_t @ %def process_ptr_t @ \subsection{Output} This procedure is an important debugging and inspection tool; it is not used during normal operation. The process object is written to a file (identified by unit, which may also be standard output). Optional flags determine whether we show everything or just the interesting parts. The shorthand as a traditional TBP. <>= procedure :: write => process_write <>= subroutine process_write (process, screen, unit, & show_os_data, show_var_list, show_rng, show_expressions, pacify) class(process_t), intent(in) :: process logical, intent(in) :: screen integer, intent(in), optional :: unit logical, intent(in), optional :: show_os_data logical, intent(in), optional :: show_var_list logical, intent(in), optional :: show_rng logical, intent(in), optional :: show_expressions logical, intent(in), optional :: pacify integer :: u, iostat character(0) :: iomsg integer, dimension(:), allocatable :: v_list u = given_output_unit (unit) allocate (v_list (0)) call set_flag (v_list, F_SHOW_OS_DATA, show_os_data) call set_flag (v_list, F_SHOW_VAR_LIST, show_var_list) call set_flag (v_list, F_SHOW_RNG, show_rng) call set_flag (v_list, F_SHOW_EXPRESSIONS, show_expressions) call set_flag (v_list, F_PACIFY, pacify) if (screen) then call process%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg) else call process%write_formatted (u, "DT", v_list, iostat, iomsg) end if end subroutine process_write @ %def process_write @ Standard DTIO procedure with binding. For the particular application, the screen format is triggered by the [[LISTDIRECTED]] option for the [[iotype]] format editor string. The other options activate when the particular parameter value is found in [[v_list]]. NOTE: The DTIO [[generic]] binding is supported by gfortran since 7.0. -TODO: The default could be to show everything, and we should have separate +TODO wk 2018: The default could be to show everything, and we should have separate switches for all major parts. Currently, there are only a few. <>= ! generic :: write (formatted) => write_formatted procedure :: write_formatted => process_write_formatted <>= subroutine process_write_formatted (dtv, unit, iotype, v_list, iostat, iomsg) class(process_t), intent(in) :: dtv integer, intent(in) :: unit character(*), intent(in) :: iotype integer, dimension(:), intent(in) :: v_list integer, intent(out) :: iostat character(*), intent(inout) :: iomsg integer :: u logical :: screen logical :: var_list logical :: rng_factory logical :: expressions logical :: counters logical :: os_data logical :: model logical :: pacify integer :: i u = unit select case (iotype) case ("LISTDIRECTED") screen = .true. case default screen = .false. end select var_list = flagged (v_list, F_SHOW_VAR_LIST) rng_factory = flagged (v_list, F_SHOW_RNG, .true.) expressions = flagged (v_list, F_SHOW_EXPRESSIONS) counters = .true. os_data = flagged (v_list, F_SHOW_OS_DATA) model = .false. pacify = flagged (v_list, F_PACIFY) associate (process => dtv) if (screen) then write (msg_buffer, "(A)") repeat ("-", 72) call msg_message () else call write_separator (u, 2) end if call process%meta%write (u, screen) if (var_list) then call process%env%write (u, show_var_list=var_list, & show_model=.false., show_lib=.false., & show_os_data=os_data) else if (.not. screen) then write (u, "(1x,A)") "Variable list: [not shown]" end if if (process%meta%type == PRC_UNKNOWN) then call write_separator (u, 2) return else if (screen) then return end if call write_separator (u) call process%config%write (u, counters, model, expressions) if (rng_factory) then if (allocated (process%rng_factory)) then call write_separator (u) call process%rng_factory%write (u) end if end if call write_separator (u, 2) if (allocated (process%component)) then write (u, "(1x,A)") "Process component configuration:" do i = 1, size (process%component) call write_separator (u) call process%component(i)%write (u) end do else write (u, "(1x,A)") "Process component configuration: [undefined]" end if call write_separator (u, 2) if (allocated (process%term)) then write (u, "(1x,A)") "Process term configuration:" do i = 1, size (process%term) call write_separator (u) call process%term(i)%write (u) end do else write (u, "(1x,A)") "Process term configuration: [undefined]" end if call write_separator (u, 2) call process%beam_config%write (u) call write_separator (u, 2) if (allocated (process%mci_entry)) then write (u, "(1x,A)") "Multi-channel integrator configurations:" do i = 1, size (process%mci_entry) call write_separator (u) write (u, "(1x,A,I0,A)") "MCI #", i, ":" call process%mci_entry(i)%write (u, pacify) end do end if call write_separator (u, 2) end associate iostat = 0 iomsg = "" end subroutine process_write_formatted @ %def process_write_formatted @ <>= procedure :: write_meta => process_write_meta <>= subroutine process_write_meta (process, unit, testflag) class(process_t), intent(in) :: process integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u, i u = given_output_unit (unit) select case (process%meta%type) case (PRC_UNKNOWN) write (u, "(1x,A)") "Process instance [undefined]" return case (PRC_DECAY) write (u, "(1x,A)", advance="no") "Process instance [decay]:" case (PRC_SCATTERING) write (u, "(1x,A)", advance="no") "Process instance [scattering]:" case default call msg_bug ("process_instance_write: undefined process type") end select write (u, "(1x,A,A,A)") "'", char (process%meta%id), "'" write (u, "(3x,A,A,A)") "Run ID = '", char (process%meta%run_id), "'" if (allocated (process%meta%component_id)) then write (u, "(3x,A)") "Process components:" do i = 1, size (process%meta%component_id) if (process%pcm%component_selected(i)) then write (u, "(3x,'*')", advance="no") else write (u, "(4x)", advance="no") end if write (u, "(1x,I0,9A)") i, ": '", & char (process%meta%component_id (i)), "': ", & char (process%meta%component_description (i)) end do end if end subroutine process_write_meta @ %def process_write_meta @ Screen output. Write a short account of the process configuration and the current results. The verbose version lists the components, the short version just the results. <>= procedure :: show => process_show <>= subroutine process_show (object, unit, verbose) class(process_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u logical :: verb real(default) :: err_percent u = given_output_unit (unit) verb = .true.; if (present (verbose)) verb = verbose if (verb) then call object%meta%show (u, object%config%model%get_name ()) select case (object%meta%type) case (PRC_DECAY) write (u, "(2x,A)", advance="no") "Computed width =" case (PRC_SCATTERING) write (u, "(2x,A)", advance="no") "Computed cross section =" case default; return end select else if (object%meta%run_id /= "") then write (u, "('Run',1x,A,':',1x)", advance="no") & char (object%meta%run_id) end if write (u, "(A)", advance="no") char (object%meta%id) select case (object%meta%num_id) case (0) write (u, "(':')") case default write (u, "(1x,'(',I0,')',':')") object%meta%num_id end select write (u, "(2x)", advance="no") end if if (object%has_integral_tot ()) then write (u, "(ES14.7,1x,'+-',ES9.2)", advance="no") & object%get_integral_tot (), object%get_error_tot () select case (object%meta%type) case (PRC_DECAY) write (u, "(1x,A)", advance="no") "GeV" case (PRC_SCATTERING) write (u, "(1x,A)", advance="no") "fb " case default write (u, "(1x,A)", advance="no") " " end select if (object%get_integral_tot () /= 0) then err_percent = abs (100 & * object%get_error_tot () / object%get_integral_tot ()) else err_percent = 0 end if if (err_percent == 0) then write (u, "(1x,'(',F4.0,4x,'%)')") err_percent else if (err_percent < 0.1) then write (u, "(1x,'(',F7.3,1x,'%)')") err_percent else if (err_percent < 1) then write (u, "(1x,'(',F6.2,2x,'%)')") err_percent else if (err_percent < 10) then write (u, "(1x,'(',F5.1,3x,'%)')") err_percent else write (u, "(1x,'(',F4.0,4x,'%)')") err_percent end if else write (u, "(A)") "[integral undefined]" end if end subroutine process_show @ %def process_show @ Finalizer. Explicitly iterate over all subobjects that may contain allocated pointers. -TODO (workaround): The finalizer for the [[config_data]] component is not +TODO wk 2018 (workaround): The finalizer for the [[config_data]] component is not called. The reason is that this deletes model data local to the process, but these could be referenced by pointers (flavor objects) from some persistent event record. Obviously, such side effects should be avoided, but this requires refactoring the event-handling procedures. <>= procedure :: final => process_final <>= subroutine process_final (process) class(process_t), intent(inout) :: process integer :: i ! call process%meta%final () call process%env%final () ! call process%config%final () if (allocated (process%component)) then do i = 1, size (process%component) call process%component(i)%final () end do end if if (allocated (process%term)) then do i = 1, size (process%term) call process%term(i)%final () end do end if call process%beam_config%final () if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) call process%mci_entry(i)%final () end do end if if (allocated (process%pcm)) then call process%pcm%final () deallocate (process%pcm) end if end subroutine process_final @ %def process_final @ \subsubsection{Process setup} Initialize a process. We need a process library [[lib]] and the process identifier [[proc_id]] (string). We will fetch the current run ID from the variable list [[var_list]]. We collect all important data from the environment and store them in the appropriate places. OS data, model, and variable list are copied into [[env]] (true snapshot), also the process library (pointer only). The [[meta]] subobject is initialized with process ID and attributes taken from the process library. We initialize the [[config]] subobject with all data that are relevant for this run, using the settings from [[env]]. These data determine the MD5 sum for this run, which allows us to identify the setup and possibly skips in a later re-run. We also allocate and initialize the embedded RNG factory. We take the seed from the [[var_list]], and we should return the [[var_list]] to the caller with a new seed. Finally, we allocate the process component manager [[pcm]], which implements the chosen algorithm for process integration. The first task of the manager is to allocate the component array and to determine the component categories (e.g., Born/Virtual etc.). -TODO: The [[pcm]] dispatcher should be provided by the caller, if we +TODO wk 2018: The [[pcm]] dispatcher should be provided by the caller, if we eventually want to eliminate dependencies on concrete [[pcm_t]] extensions. <>= procedure :: init => process_init <>= subroutine process_init & (process, proc_id, lib, os_data, model, var_list, beam_structure) class(process_t), intent(out) :: process type(string_t), intent(in) :: proc_id type(process_library_t), intent(in), target :: lib type(os_data_t), intent(in) :: os_data class(model_t), intent(in), target :: model type(var_list_t), intent(inout), target, optional :: var_list type(beam_structure_t), intent(in), optional :: beam_structure integer :: next_rng_seed call msg_debug (D_PROCESS_INTEGRATION, "process_init") associate & (meta => process%meta, env => process%env, config => process%config) call env%init & (model, lib, os_data, var_list, beam_structure) call meta%init & (proc_id, lib, env%get_var_list_ptr ()) call config%init & (meta, env) call dispatch_rng_factory & (process%rng_factory, env%get_var_list_ptr (), next_rng_seed) call update_rng_seed_in_var_list (var_list, next_rng_seed) call dispatch_pcm & (process%pcm, config%process_def%is_nlo ()) associate (pcm => process%pcm) call pcm%init (env, meta) call pcm%allocate_components (process%component, meta) call pcm%categorize_components (config) end associate end associate end subroutine process_init @ %def process_init @ \subsection{Process component manager} The [[pcm]] (read: process-component manager) takes the responsibility of steering the actual algorithm of configuration and integration. Depending on the concrete type, different algorithms can be implemented. The first version of this supports just two implementations: leading-order (tree-level) integration and event generation, and NLO (QCD/FKS subtraction). We thus can start with a single logical for steering the dispatcher. -TODO: Eventually, we may eliminate all references to the extensions of +TODO wk 2018: Eventually, we may eliminate all references to the extensions of [[pcm_t]] from this module and therefore move this outside the module as well. <>= subroutine dispatch_pcm (pcm, is_nlo) class(pcm_t), allocatable, intent(out) :: pcm logical, intent(in) :: is_nlo if (.not. is_nlo) then allocate (pcm_default_t :: pcm) else allocate (pcm_nlo_t :: pcm) end if end subroutine dispatch_pcm @ %def dispatch_pcm @ This step is performed after phase-space and core objects are done: collect all missing information and prepare the process component manager for the appropriate integration algorithm. <>= procedure :: complete_pcm_setup => process_complete_pcm_setup <>= subroutine process_complete_pcm_setup (process) class(process_t), intent(inout) :: process call process%pcm%complete_setup & (process%core_entry, process%component, process%env%get_model_ptr ()) end subroutine process_complete_pcm_setup @ %def process_complete_pcm_setup @ \subsection{Core management} Allocate cores (interface objects to matrix-element code). The [[dispatch_core]] procedure is taken as an argument, so we do not depend on the implementation, and thus on the specific core types. The [[helicity_selection]] object collects data that the matrix-element code needs for configuring the appropriate behavior. After the cores have been allocated, and assuming the phs initial configuration has been done before, we proceed with computing the [[pcm]] internal data. <>= procedure :: setup_cores => process_setup_cores <>= subroutine process_setup_cores (process, dispatch_core, & helicity_selection, use_color_factors, has_beam_pol) class(process_t), intent(inout) :: process procedure(dispatch_core_proc) :: dispatch_core type(helicity_selection_t), intent(in), optional :: helicity_selection logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol integer :: i associate (pcm => process%pcm) call pcm%allocate_cores (process%config, process%core_entry) do i = 1, size (process%core_entry) call dispatch_core (process%core_entry(i)%core, & process%core_entry(i)%core_def, & process%config%model, & helicity_selection, & process%config%qcd, & use_color_factors, & has_beam_pol) call process%core_entry(i)%configure & (process%env%get_lib_ptr (), process%meta%id) if (process%core_entry(i)%core%uses_blha ()) then call pcm%setup_blha (process%core_entry(i)) end if end do end associate end subroutine process_setup_cores @ %def process_setup_cores <>= abstract interface subroutine dispatch_core_proc (core, core_def, model, & helicity_selection, qcd, use_color_factors, has_beam_pol) import class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_def_t), intent(in) :: core_def class(model_data_t), intent(in), target, optional :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol end subroutine dispatch_core_proc end interface @ %def dispatch_core_proc @ Use the [[pcm]] to initialize the BLHA interface for each core which requires it. <>= procedure :: prepare_blha_cores => process_prepare_blha_cores <>= subroutine process_prepare_blha_cores (process) class(process_t), intent(inout), target :: process integer :: i associate (pcm => process%pcm) do i = 1, size (process%core_entry) associate (core_entry => process%core_entry(i)) if (core_entry%core%uses_blha ()) then pcm%uses_blha = .true. call pcm%prepare_blha_core (core_entry, process%config%model) end if end associate end do end associate end subroutine process_prepare_blha_cores @ %def process_prepare_blha_cores @ Create the BLHA interface data, using PCM for specific data, and write the BLHA contract file(s). We take various configuration data and copy them to the [[blha_master]] record, which then creates and writes the contracts. For assigning the QCD/QED coupling powers, we inspect the first process component only. The other parameters are taken as-is from the process environment variables. <>= procedure :: create_blha_interface => process_create_blha_interface <>= subroutine process_create_blha_interface (process) class(process_t), intent(in) :: process integer :: alpha_power, alphas_power integer :: openloops_phs_tolerance, openloops_stability_log logical :: use_cms, use_collier type(string_t) :: ew_scheme, correction_type type(string_t) :: openloops_extra_cmd type(blha_master_t) :: blha_master integer, dimension(:,:), allocatable :: flv_born, flv_real if (process%pcm%uses_blha) then call collect_configuration_parameters (process%get_var_list_ptr ()) call process%component(1)%config%get_coupling_powers & (alpha_power, alphas_power) associate (pcm => process%pcm) call pcm%set_blha_methods (blha_master, process%get_var_list_ptr ()) call blha_master%set_ew_scheme (ew_scheme) call blha_master%allocate_config_files () call blha_master%set_correction_type (correction_type) call blha_master%setup_additional_features ( & openloops_phs_tolerance, & use_cms, & openloops_stability_log, & use_collier, & extra_cmd = openloops_extra_cmd, & beam_structure = process%env%get_beam_structure ()) call pcm%get_blha_flv_states (process%core_entry, flv_born, flv_real) call blha_master%generate (process%meta%id, & process%config%model, process%config%n_in, & alpha_power, alphas_power, & flv_born, flv_real) call blha_master%write_olp (process%meta%id) end associate end if contains subroutine collect_configuration_parameters (var_list) type(var_list_t), intent(in) :: var_list openloops_phs_tolerance = & var_list%get_ival (var_str ("openloops_phs_tolerance")) openloops_stability_log = & var_list%get_ival (var_str ("openloops_stability_log")) use_cms = & var_list%get_lval (var_str ("?openloops_use_cms")) use_collier = & var_list%get_lval (var_str ("?openloops_use_collier")) ew_scheme = & var_list%get_sval (var_str ("$blha_ew_scheme")) correction_type = & var_list%get_sval (var_str ("$nlo_correction_type")) openloops_extra_cmd = & var_list%get_sval (var_str ("$openloops_extra_cmd")) end subroutine collect_configuration_parameters end subroutine process_create_blha_interface @ %def process_create_blha_interface @ Initialize the process components, one by one. We require templates for the [[mci]] (integrator) and [[phs_config]] (phase-space) configuration data. The [[active]] flag is set if the component has an associated matrix element, so we can compute it. The case of no core is a unit-test case. The specifics depend on the algorithm and are delegated to the [[pcm]] process-component manager. The optional [[phs_config]] overrides a pre-generated config array (for unit test). <>= procedure :: init_components => process_init_components <>= subroutine process_init_components (process, phs_config) class(process_t), intent(inout), target :: process class(phs_config_t), allocatable, intent(in), optional :: phs_config integer :: i, i_core class(prc_core_t), pointer :: core logical :: active associate (pcm => process%pcm) do i = 1, pcm%n_components i_core = pcm%get_i_core(i) if (i_core > 0) then core => process%get_core_ptr (i_core) active = core%has_matrix_element () else active = .true. end if if (present (phs_config)) then call pcm%init_component (process%component(i), & i, & active, & phs_config, & process%env, process%meta, process%config) else call pcm%init_component (process%component(i), & i, & active, & process%phs_entry(pcm%i_phs_config(i))%phs_config, & process%env, process%meta, process%config) end if end do end associate end subroutine process_init_components @ %def process_init_components @ If process components have turned out to be inactive, this has to be recorded in the [[meta]] block. Delegate to the [[pcm]]. <>= procedure :: record_inactive_components => process_record_inactive_components <>= subroutine process_record_inactive_components (process) class(process_t), intent(inout) :: process associate (pcm => process%pcm) call pcm%record_inactive_components (process%component, process%meta) end associate end subroutine process_record_inactive_components @ %def process_record_inactive_components @ Determine the process terms for each process component. <>= procedure :: setup_terms => process_setup_terms <>= subroutine process_setup_terms (process, with_beams) class(process_t), intent(inout), target :: process logical, intent(in), optional :: with_beams class(model_data_t), pointer :: model integer :: i, j, k, i_term integer, dimension(:), allocatable :: n_entry integer :: n_components, n_tot integer :: i_sub type(string_t) :: subtraction_method class(prc_core_t), pointer :: core => null () logical :: setup_subtraction_component, singular_real logical :: requires_spin_correlations integer :: nlo_type_to_fetch, n_emitters i_sub = 0 model => process%config%model n_components = process%meta%n_components allocate (n_entry (n_components), source = 0) do i = 1, n_components associate (component => process%component(i)) if (component%active) then n_entry(i) = 1 if (component%get_nlo_type () == NLO_REAL) then select type (pcm => process%pcm) type is (pcm_nlo_t) if (component%component_type /= COMP_REAL_FIN) & n_entry(i) = n_entry(i) + pcm%region_data%get_n_phs () end select end if end if end associate end do n_tot = sum (n_entry) allocate (process%term (n_tot)) k = 0 if (process%is_nlo_calculation ()) then i_sub = process%component(1)%config%get_associated_subtraction () subtraction_method = process%component(i_sub)%config%get_me_method () call msg_debug2 (D_PROCESS_INTEGRATION, "process_setup_terms: ", & subtraction_method) end if do i = 1, n_components associate (component => process%component(i)) if (.not. component%active) cycle allocate (component%i_term (n_entry(i))) do j = 1, n_entry(i) singular_real = component%get_nlo_type () == NLO_REAL & .and. component%component_type /= COMP_REAL_FIN setup_subtraction_component = singular_real .and. j == n_entry(i) i_term = k + j component%i_term(j) = i_term if (singular_real) then process%term(i_term)%i_sub = k + n_entry(i) else process%term(i_term)%i_sub = 0 end if if (setup_subtraction_component) then select type (pcm => process%pcm) class is (pcm_nlo_t) process%term(i_term)%i_core = pcm%i_core(pcm%i_sub) end select else process%term(i_term)%i_core = process%pcm%get_i_core(i) end if if (process%term(i_term)%i_core == 0) then call msg_bug ("Process '" // char (process%get_id ()) & // "': core not found!") end if core => process%get_core_term (i_term) if (i_sub > 0) then select type (pcm => process%pcm) type is (pcm_nlo_t) requires_spin_correlations = & pcm%region_data%requires_spin_correlations () n_emitters = pcm%region_data%n_emitters class default requires_spin_correlations = .false. n_emitters = 0 end select if (requires_spin_correlations) then call process%term(i_term)%init ( & i_term, i, j, core, model, & nlo_type = component%config%get_nlo_type (), & use_beam_pol = with_beams, & subtraction_method = subtraction_method, & has_pdfs = process%pcm%has_pdfs, & n_emitters = n_emitters) else call process%term(i_term)%init ( & i_term, i, j, core, model, & nlo_type = component%config%get_nlo_type (), & use_beam_pol = with_beams, & subtraction_method = subtraction_method, & has_pdfs = process%pcm%has_pdfs) end if else call process%term(i_term)%init ( & i_term, i, j, core, model, & nlo_type = component%config%get_nlo_type (), & use_beam_pol = with_beams, & has_pdfs = process%pcm%has_pdfs) end if end do end associate k = k + n_entry(i) end do process%config%n_terms = n_tot end subroutine process_setup_terms @ %def process_setup_terms @ Initialize the beam setup. This is the trivial version where the incoming state of the matrix element coincides with the initial state of the process. For a scattering process, we need the c.m. energy, all other variables are set to their default values (no polarization, lab frame and c.m.\ frame coincide, etc.) We assume that all components consistently describe a scattering process, i.e., two incoming particles. Note: The current layout of the [[beam_data_t]] record requires that the flavor for each beam is unique. For processes with multiple flavors in the initial state, one has to set up beams explicitly. This restriction could be removed by extending the code in the [[beams]] module. <>= procedure :: setup_beams_sqrts => process_setup_beams_sqrts <>= subroutine process_setup_beams_sqrts (process, sqrts, beam_structure, i_core) class(process_t), intent(inout) :: process real(default), intent(in) :: sqrts type(beam_structure_t), intent(in), optional :: beam_structure integer, intent(in), optional :: i_core type(pdg_array_t), dimension(:,:), allocatable :: pdg_in integer, dimension(2) :: pdg_scattering type(flavor_t), dimension(2) :: flv_in integer :: i, i0, ic allocate (pdg_in (2, process%meta%n_components)) i0 = 0 do i = 1, process%meta%n_components if (process%component(i)%active) then if (present (i_core)) then ic = i_core else ic = process%pcm%get_i_core (i) end if associate (core => process%core_entry(ic)%core) pdg_in(:,i) = core%data%get_pdg_in () end associate if (i0 == 0) i0 = i end if end do do i = 1, process%meta%n_components if (.not. process%component(i)%active) then pdg_in(:,i) = pdg_in(:,i0) end if end do if (all (pdg_array_get_length (pdg_in) == 1) .and. & all (pdg_in(1,:) == pdg_in(1,i0)) .and. & all (pdg_in(2,:) == pdg_in(2,i0))) then pdg_scattering = pdg_array_get (pdg_in(:,i0), 1) call flv_in%init (pdg_scattering, process%config%model) call process%beam_config%init_scattering (flv_in, sqrts, beam_structure) else call msg_fatal ("Setting up process '" // char (process%meta%id) // "':", & [var_str (" --------------------------------------------"), & var_str ("Inconsistent initial state. This happens if either "), & var_str ("several processes with non-matching initial states "), & var_str ("have been added, or for a single process with an "), & var_str ("initial state flavor sum. In that case, please set beams "), & var_str ("explicitly [singling out a flavor / structure function.]")]) end if end subroutine process_setup_beams_sqrts @ %def process_setup_beams_sqrts @ This is the version that applies to decay processes. The energy is the particle mass, hence no extra argument. <>= procedure :: setup_beams_decay => process_setup_beams_decay <>= subroutine process_setup_beams_decay (process, rest_frame, beam_structure, i_core) class(process_t), intent(inout), target :: process logical, intent(in), optional :: rest_frame type(beam_structure_t), intent(in), optional :: beam_structure integer, intent(in), optional :: i_core type(pdg_array_t), dimension(:,:), allocatable :: pdg_in integer, dimension(1) :: pdg_decay type(flavor_t), dimension(1) :: flv_in integer :: i, i0, ic allocate (pdg_in (1, process%meta%n_components)) i0 = 0 do i = 1, process%meta%n_components if (process%component(i)%active) then if (present (i_core)) then ic = i_core else ic = process%pcm%get_i_core (i) end if associate (core => process%core_entry(ic)%core) pdg_in(:,i) = core%data%get_pdg_in () end associate if (i0 == 0) i0 = i end if end do do i = 1, process%meta%n_components if (.not. process%component(i)%active) then pdg_in(:,i) = pdg_in(:,i0) end if end do if (all (pdg_array_get_length (pdg_in) == 1) & .and. all (pdg_in(1,:) == pdg_in(1,i0))) then pdg_decay = pdg_array_get (pdg_in(:,i0), 1) call flv_in%init (pdg_decay, process%config%model) call process%beam_config%init_decay (flv_in, rest_frame, beam_structure) else call msg_fatal ("Setting up decay '" & // char (process%meta%id) // "': decaying particle not unique") end if end subroutine process_setup_beams_decay @ %def process_setup_beams_decay @ We have to make sure that the masses of the various flavors in a given position in the particle string coincide. <>= procedure :: check_masses => process_check_masses <>= subroutine process_check_masses (process) class(process_t), intent(in) :: process type(flavor_t), dimension(:), allocatable :: flv real(default), dimension(:), allocatable :: mass integer :: i, j integer :: i_component class(prc_core_t), pointer :: core do i = 1, process%get_n_terms () i_component = process%term(i)%i_component if (.not. process%component(i_component)%active) cycle core => process%get_core_term (i) associate (data => core%data) allocate (flv (data%n_flv), mass (data%n_flv)) do j = 1, data%n_in + data%n_out call flv%init (data%flv_state(j,:), process%config%model) mass = flv%get_mass () if (any (.not. nearly_equal(mass, mass(1)))) then call msg_fatal ("Process '" // char (process%meta%id) // "': " & // "mass values in flavor combination do not coincide. ") end if end do deallocate (flv, mass) end associate end do end subroutine process_check_masses @ %def process_check_masses @ For some structure functions we need to get the list of initial state flavors. This is a two-dimensional array. The first index is the beam index, the second index is the component index. Each array element is itself a PDG array object, which consists of the list of incoming PDG values for this beam and component. <>= procedure :: get_pdg_in => process_get_pdg_in <>= subroutine process_get_pdg_in (process, pdg_in) class(process_t), intent(in), target :: process type(pdg_array_t), dimension(:,:), allocatable, intent(out) :: pdg_in integer :: i, i_core allocate (pdg_in (process%config%n_in, process%meta%n_components)) do i = 1, process%meta%n_components if (process%component(i)%active) then i_core = process%pcm%get_i_core (i) associate (core => process%core_entry(i_core)%core) pdg_in(:,i) = core%data%get_pdg_in () end associate end if end do end subroutine process_get_pdg_in @ %def process_get_pdg_in @ The phase-space configuration object, in case we need it separately. <>= procedure :: get_phs_config => process_get_phs_config <>= function process_get_phs_config (process, i_component) result (phs_config) class(phs_config_t), pointer :: phs_config class(process_t), intent(in), target :: process integer, intent(in) :: i_component if (allocated (process%component)) then phs_config => process%component(i_component)%phs_config else phs_config => null () end if end function process_get_phs_config @ %def process_get_phs_config @ The resonance history set can be extracted from the phase-space configuration. However, this is only possible if the default phase-space method (wood) has been chosen. If [[include_trivial]] is set, we include the resonance history with no resonances in the set. <>= procedure :: extract_resonance_history_set & => process_extract_resonance_history_set <>= subroutine process_extract_resonance_history_set & (process, res_set, include_trivial, i_component) class(process_t), intent(in), target :: process type(resonance_history_set_t), intent(out) :: res_set logical, intent(in), optional :: include_trivial integer, intent(in), optional :: i_component integer :: i i = 1; if (present (i_component)) i = i_component select type (phs_config => process%get_phs_config (i)) class is (phs_wood_config_t) call phs_config%extract_resonance_history_set (res_set, include_trivial) class default call msg_error ("process '" // char (process%get_id ()) & // "': extract resonance histories: phase-space method must be & &'wood'. No resonances can be determined.") end select end subroutine process_extract_resonance_history_set @ %def process_extract_resonance_history_set @ Initialize from a complete beam setup. If the beam setup does not apply directly to the process, choose a fallback option as a straight scattering or decay process. <>= procedure :: setup_beams_beam_structure => process_setup_beams_beam_structure <>= subroutine process_setup_beams_beam_structure & (process, beam_structure, sqrts, decay_rest_frame) class(process_t), intent(inout) :: process type(beam_structure_t), intent(in) :: beam_structure real(default), intent(in) :: sqrts logical, intent(in), optional :: decay_rest_frame integer :: n_in logical :: applies n_in = process%get_n_in () call beam_structure%check_against_n_in (process%get_n_in (), applies) if (applies) then call process%beam_config%init_beam_structure & (beam_structure, sqrts, process%get_model_ptr (), decay_rest_frame) else if (n_in == 2) then call process%setup_beams_sqrts (sqrts, beam_structure) else call process%setup_beams_decay (decay_rest_frame, beam_structure) end if end subroutine process_setup_beams_beam_structure @ %def process_setup_beams_beam_structure @ Notify the user about beam setup. <>= procedure :: beams_startup_message => process_beams_startup_message <>= subroutine process_beams_startup_message (process, unit, beam_structure) class(process_t), intent(in) :: process integer, intent(in), optional :: unit type(beam_structure_t), intent(in), optional :: beam_structure call process%beam_config%startup_message (unit, beam_structure) end subroutine process_beams_startup_message @ %def process_beams_startup_message @ Initialize phase-space configuration by reading out the environment variables. We return the rebuild flags and store parameters in the blocks [[phs_par]] and [[mapping_defs]]. The phase-space configuration object(s) are allocated by [[pcm]]. <>= procedure :: init_phs_config => process_init_phs_config <>= subroutine process_init_phs_config (process) class(process_t), intent(inout) :: process type(var_list_t), pointer :: var_list type(phs_parameters_t) :: phs_par type(mapping_defaults_t) :: mapping_defs var_list => process%env%get_var_list_ptr () phs_par%m_threshold_s = & var_list%get_rval (var_str ("phs_threshold_s")) phs_par%m_threshold_t = & var_list%get_rval (var_str ("phs_threshold_t")) phs_par%off_shell = & var_list%get_ival (var_str ("phs_off_shell")) phs_par%keep_nonresonant = & var_list%get_lval (var_str ("?phs_keep_nonresonant")) phs_par%t_channel = & var_list%get_ival (var_str ("phs_t_channel")) mapping_defs%energy_scale = & var_list%get_rval (var_str ("phs_e_scale")) mapping_defs%invariant_mass_scale = & var_list%get_rval (var_str ("phs_m_scale")) mapping_defs%momentum_transfer_scale = & var_list%get_rval (var_str ("phs_q_scale")) mapping_defs%step_mapping = & var_list%get_lval (var_str ("?phs_step_mapping")) mapping_defs%step_mapping_exp = & var_list%get_lval (var_str ("?phs_step_mapping_exp")) mapping_defs%enable_s_mapping = & var_list%get_lval (var_str ("?phs_s_mapping")) associate (pcm => process%pcm) call pcm%init_phs_config (process%phs_entry, & process%meta, process%env, phs_par, mapping_defs) end associate end subroutine process_init_phs_config @ %def process_init_phs_config @ We complete the kinematics configuration after the beam setup, but before we configure the chain of structure functions. The reason is that we need the total energy [[sqrts]] for the kinematics, but the structure-function setup requires the number of channels, which depends on the kinematics configuration. For instance, the kinematics module may return the need for parameterizing an s-channel resonance. <>= procedure :: configure_phs => process_configure_phs <>= subroutine process_configure_phs (process, rebuild, ignore_mismatch, & combined_integration, subdir) class(process_t), intent(inout) :: process logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch logical, intent(in), optional :: combined_integration type(string_t), intent(in), optional :: subdir real(default) :: sqrts integer :: i, i_born class(phs_config_t), pointer :: phs_config_born sqrts = process%get_sqrts () do i = 1, process%meta%n_components associate (component => process%component(i)) if (component%active) then select type (pcm => process%pcm) type is (pcm_default_t) call component%configure_phs (sqrts, process%beam_config, & rebuild, ignore_mismatch, subdir) class is (pcm_nlo_t) select case (component%config%get_nlo_type ()) case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION) call component%configure_phs (sqrts, process%beam_config, & rebuild, ignore_mismatch, subdir) call check_and_extend_phs (component) case (NLO_REAL, NLO_MISMATCH, NLO_DGLAP) i_born = component%config%get_associated_born () if (component%component_type /= COMP_REAL_FIN) & call check_and_extend_phs (component) call process%component(i_born)%get_phs_config (phs_config_born) select type (config => component%phs_config) type is (phs_fks_config_t) select type (phs_config_born) type is (phs_wood_config_t) config%md5sum_born_config = phs_config_born%md5sum_phs_config call config%set_born_config (phs_config_born) call config%set_mode (component%config%get_nlo_type ()) end select end select call component%configure_phs (sqrts, & process%beam_config, rebuild, ignore_mismatch, subdir) end select class default call msg_bug ("process_configure_phs: unsupported PCM type") end select end if end associate end do contains subroutine check_and_extend_phs (component) type(process_component_t), intent(inout) :: component logical :: requires_dglap_random_number if (combined_integration) then requires_dglap_random_number = any (process%component%get_nlo_type () == NLO_DGLAP) select type (phs_config => component%phs_config) class is (phs_wood_config_t) if (requires_dglap_random_number) then call phs_config%set_extension_mode (EXTENSION_DGLAP) else call phs_config%set_extension_mode (EXTENSION_DEFAULT) end if call phs_config%increase_n_par () end select end if end subroutine check_and_extend_phs end subroutine process_configure_phs @ %def process_configure_phs @ <>= procedure :: print_phs_startup_message => process_print_phs_startup_message <>= subroutine process_print_phs_startup_message (process) class(process_t), intent(in) :: process integer :: i_component do i_component = 1, process%meta%n_components associate (component => process%component(i_component)) if (component%active) then call component%phs_config%startup_message () end if end associate end do end subroutine process_print_phs_startup_message @ %def process_print_phs_startup_message @ Insert the structure-function configuration data. First allocate the storage, then insert data one by one. The third procedure declares a mapping (of the MC input parameters) for a specific channel and structure-function combination. We take the number of channels from the corresponding entry in the [[config_data]] section. Otherwise, these a simple wrapper routines. The extra level in the call tree may allow for simple addressing of multiple concurrent beam configurations, not implemented currently. If we do not want structure functions, we simply do not call those procedures. <>= procedure :: init_sf_chain => process_init_sf_chain generic :: set_sf_channel => set_sf_channel_single procedure :: set_sf_channel_single => process_set_sf_channel generic :: set_sf_channel => set_sf_channel_array procedure :: set_sf_channel_array => process_set_sf_channel_array <>= subroutine process_init_sf_chain (process, sf_config, sf_trace_file) class(process_t), intent(inout) :: process type(sf_config_t), dimension(:), intent(in) :: sf_config type(string_t), intent(in), optional :: sf_trace_file type(string_t) :: file if (present (sf_trace_file)) then if (sf_trace_file /= "") then file = sf_trace_file else file = process%get_id () // "_sftrace.dat" end if call process%beam_config%init_sf_chain (sf_config, file) else call process%beam_config%init_sf_chain (sf_config) end if end subroutine process_init_sf_chain subroutine process_set_sf_channel (process, c, sf_channel) class(process_t), intent(inout) :: process integer, intent(in) :: c type(sf_channel_t), intent(in) :: sf_channel call process%beam_config%set_sf_channel (c, sf_channel) end subroutine process_set_sf_channel subroutine process_set_sf_channel_array (process, sf_channel) class(process_t), intent(inout) :: process type(sf_channel_t), dimension(:), intent(in) :: sf_channel integer :: c call process%beam_config%allocate_sf_channels (size (sf_channel)) do c = 1, size (sf_channel) call process%beam_config%set_sf_channel (c, sf_channel(c)) end do end subroutine process_set_sf_channel_array @ %def process_init_sf_chain @ %def process_set_sf_channel @ Notify about the structure-function setup. <>= procedure :: sf_startup_message => process_sf_startup_message <>= subroutine process_sf_startup_message (process, sf_string, unit) class(process_t), intent(in) :: process type(string_t), intent(in) :: sf_string integer, intent(in), optional :: unit call process%beam_config%sf_startup_message (sf_string, unit) end subroutine process_sf_startup_message @ %def process_sf_startup_message @ As soon as both the kinematics configuration and the structure-function setup are complete, we match parameterizations (channels) for both. The matching entries are (re)set in the [[component]] phase-space configuration, while the structure-function configuration is left intact. <>= procedure :: collect_channels => process_collect_channels <>= subroutine process_collect_channels (process, coll) class(process_t), intent(inout) :: process type(phs_channel_collection_t), intent(inout) :: coll integer :: i do i = 1, process%meta%n_components associate (component => process%component(i)) if (component%active) & call component%collect_channels (coll) end associate end do end subroutine process_collect_channels @ %def process_collect_channels @ Independently, we should be able to check if any component does not contain phase-space parameters. Such a process can only be integrated if there are structure functions. <>= procedure :: contains_trivial_component => process_contains_trivial_component <>= function process_contains_trivial_component (process) result (flag) class(process_t), intent(in) :: process logical :: flag integer :: i flag = .true. do i = 1, process%meta%n_components associate (component => process%component(i)) if (component%active) then if (component%get_n_phs_par () == 0) return end if end associate end do flag = .false. end function process_contains_trivial_component @ %def process_contains_trivial_component @ <>= procedure :: get_master_component => process_get_master_component <>= function process_get_master_component (process, i_mci) result (i_component) integer :: i_component class(process_t), intent(in) :: process integer, intent(in) :: i_mci integer :: i i_component = 0 do i = 1, size (process%component) if (process%component(i)%i_mci == i_mci) then i_component = i return end if end do end function process_get_master_component @ %def process_get_master_component @ Determine the MC parameter set structure and the MCI configuration for each process component. We need data from the structure-function and phase-space setup, so those should be complete before this is called. We also make a random-number generator instance for each MCI group. <>= procedure :: setup_mci => process_setup_mci <>= subroutine process_setup_mci (process, dispatch_mci) class(process_t), intent(inout) :: process procedure(dispatch_mci_proc) :: dispatch_mci class(mci_t), allocatable :: mci_template integer :: i, i_mci call msg_debug (D_PROCESS_INTEGRATION, "process_setup_mci") associate (pcm => process%pcm) call pcm%call_dispatch_mci (dispatch_mci, & process%get_var_list_ptr (), process%meta%id, mci_template) call pcm%setup_mci (process%mci_entry) process%config%n_mci = pcm%n_mci process%component(:)%i_mci = pcm%i_mci(:) do i = 1, pcm%n_components i_mci = process%pcm%i_mci(i) if (i_mci > 0) then associate (component => process%component(i), & mci_entry => process%mci_entry(i_mci)) call mci_entry%configure (mci_template, & process%meta%type, & i_mci, i, component, process%beam_config%n_sfpar, & process%rng_factory) call mci_entry%set_parameters (process%get_var_list_ptr ()) end associate end if end do end associate end subroutine process_setup_mci @ %def process_setup_mci @ Set cuts. This is a parse node, namely the right-hand side of the [[cut]] assignment. When creating an instance, we compile this into an evaluation tree. The parse node may be null. <>= procedure :: set_cuts => process_set_cuts <>= subroutine process_set_cuts (process, ef_cuts) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_cuts allocate (process%config%ef_cuts, source = ef_cuts) end subroutine process_set_cuts @ %def process_set_cuts @ Analogously for the other expressions. <>= procedure :: set_scale => process_set_scale procedure :: set_fac_scale => process_set_fac_scale procedure :: set_ren_scale => process_set_ren_scale procedure :: set_weight => process_set_weight <>= subroutine process_set_scale (process, ef_scale) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_scale allocate (process%config%ef_scale, source = ef_scale) end subroutine process_set_scale subroutine process_set_fac_scale (process, ef_fac_scale) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_fac_scale allocate (process%config%ef_fac_scale, source = ef_fac_scale) end subroutine process_set_fac_scale subroutine process_set_ren_scale (process, ef_ren_scale) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_ren_scale allocate (process%config%ef_ren_scale, source = ef_ren_scale) end subroutine process_set_ren_scale subroutine process_set_weight (process, ef_weight) class(process_t), intent(inout) :: process class(expr_factory_t), intent(in) :: ef_weight allocate (process%config%ef_weight, source = ef_weight) end subroutine process_set_weight @ %def process_set_scale @ %def process_set_fac_scale @ %def process_set_ren_scale @ %def process_set_weight @ \subsubsection{MD5 sum} The MD5 sum of the process object should reflect the state completely, including integration results. It is used for checking the integrity of event files. This global checksum includes checksums for the various parts. In particular, the MCI object receives a checksum that includes the configuration of all configuration parts relevant for an individual integration. This checksum is used for checking the integrity of integration grids. We do not need MD5 sums for the process terms, since these are generated from the component definitions. <>= procedure :: compute_md5sum => process_compute_md5sum <>= subroutine process_compute_md5sum (process) class(process_t), intent(inout) :: process integer :: i call process%config%compute_md5sum () do i = 1, process%config%n_components associate (component => process%component(i)) if (component%active) then call component%compute_md5sum () end if end associate end do call process%beam_config%compute_md5sum () do i = 1, process%config%n_mci call process%mci_entry(i)%compute_md5sum & (process%config, process%component, process%beam_config) end do end subroutine process_compute_md5sum @ %def process_compute_md5sum @ <>= procedure :: sampler_test => process_sampler_test <>= subroutine process_sampler_test (process, sampler, n_calls, i_mci) class(process_t), intent(inout) :: process class(mci_sampler_t), intent(inout) :: sampler integer, intent(in) :: n_calls, i_mci call process%mci_entry(i_mci)%sampler_test (sampler, n_calls) end subroutine process_sampler_test @ %def process_sampler_test @ The finalizer should be called after all integration passes have been completed. It will, for instance, write a summary of the integration results. [[integrate_dummy]] does a ``dummy'' integration in the sense that nothing is done but just empty integration results appended. <>= procedure :: final_integration => process_final_integration procedure :: integrate_dummy => process_integrate_dummy <>= subroutine process_final_integration (process, i_mci) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci call process%mci_entry(i_mci)%final_integration () end subroutine process_final_integration subroutine process_integrate_dummy (process) class(process_t), intent(inout) :: process type(integration_results_t) :: results integer :: u_log u_log = logfile_unit () call results%init (process%meta%type) call results%display_init (screen = .true., unit = u_log) call results%new_pass () call results%record (1, 0, 0._default, 0._default, 0._default) call results%display_final () end subroutine process_integrate_dummy @ %def process_final_integration @ %def process_integrate_dummy @ <>= procedure :: integrate => process_integrate <>= subroutine process_integrate (process, i_mci, mci_work, & mci_sampler, n_it, n_calls, adapt_grids, adapt_weights, final, & pacify, nlo_type) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(mci_work_t), intent(inout) :: mci_work class(mci_sampler_t), intent(inout) :: mci_sampler integer, intent(in) :: n_it, n_calls logical, intent(in), optional :: adapt_grids, adapt_weights logical, intent(in), optional :: final logical, intent(in), optional :: pacify integer, intent(in), optional :: nlo_type associate (mci_entry => process%mci_entry(i_mci)) call mci_entry%integrate (mci_work%mci, mci_sampler, n_it, n_calls, & adapt_grids, adapt_weights, final, pacify, & nlo_type = nlo_type) call mci_entry%results%display_pass (pacify) end associate end subroutine process_integrate @ %def process_integrate @ <>= procedure :: generate_weighted_event => process_generate_weighted_event <>= subroutine process_generate_weighted_event (process, i_mci, mci_work, & mci_sampler, keep_failed_events) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(mci_work_t), intent(inout) :: mci_work class(mci_sampler_t), intent(inout) :: mci_sampler logical, intent(in) :: keep_failed_events associate (mci_entry => process%mci_entry(i_mci)) call mci_entry%generate_weighted_event (mci_work%mci, & mci_sampler, keep_failed_events) end associate end subroutine process_generate_weighted_event @ %def process_generate_weighted_event <>= procedure :: generate_unweighted_event => process_generate_unweighted_event <>= subroutine process_generate_unweighted_event (process, i_mci, & mci_work, mci_sampler) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(mci_work_t), intent(inout) :: mci_work class(mci_sampler_t), intent(inout) :: mci_sampler associate (mci_entry => process%mci_entry(i_mci)) call mci_entry%generate_unweighted_event & (mci_work%mci, mci_sampler) end associate end subroutine process_generate_unweighted_event @ %def process_generate_unweighted_event @ Display the final results for the sum of all components. (This is useful, obviously, only if there is more than one component.) <>= procedure :: display_summed_results => process_display_summed_results <>= subroutine process_display_summed_results (process, pacify) class(process_t), intent(inout) :: process logical, intent(in) :: pacify type(integration_results_t) :: results integer :: u_log u_log = logfile_unit () call results%init (process%meta%type) call results%display_init (screen = .true., unit = u_log) call results%new_pass () call results%record (1, 0, & process%get_integral (), & process%get_error (), & process%get_efficiency (), suppress = pacify) select type (pcm => process%pcm) class is (pcm_nlo_t) !!! Check that Born integral is there if (process%component_can_be_integrated (1)) then call results%record_correction (process%get_correction (), & process%get_correction_error ()) end if end select call results%display_final () end subroutine process_display_summed_results @ %def process_display_summed_results @ Run LaTeX/Metapost to generate a ps/pdf file for the integration history. We (re)write the driver file -- just in case it has been missed before -- then we compile it. <>= procedure :: display_integration_history => & process_display_integration_history <>= subroutine process_display_integration_history & (process, i_mci, filename, os_data, eff_reset) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(string_t), intent(in) :: filename type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: eff_reset call integration_results_write_driver & (process%mci_entry(i_mci)%results, filename, eff_reset) call integration_results_compile_driver & (process%mci_entry(i_mci)%results, filename, os_data) end subroutine process_display_integration_history @ %def subroutine process_display_integration_history @ Write a complete logfile (with hardcoded name based on the process ID). We do not write internal data. <>= procedure :: write_logfile => process_write_logfile <>= subroutine process_write_logfile (process, i_mci, filename) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(string_t), intent(in) :: filename type(time_t) :: time integer :: unit, u unit = free_unit () open (unit = unit, file = char (filename), action = "write", & status = "replace") u = given_output_unit (unit) write (u, "(A)") repeat ("#", 79) call process%meta%write (u, .false.) write (u, "(A)") repeat ("#", 79) write (u, "(3x,A,ES17.10)") "Integral = ", & process%mci_entry(i_mci)%get_integral () write (u, "(3x,A,ES17.10)") "Error = ", & process%mci_entry(i_mci)%get_error () write (u, "(3x,A,ES17.10)") "Accuracy = ", & process%mci_entry(i_mci)%get_accuracy () write (u, "(3x,A,ES17.10)") "Chi2 = ", & process%mci_entry(i_mci)%get_chi2 () write (u, "(3x,A,ES17.10)") "Efficiency = ", & process%mci_entry(i_mci)%get_efficiency () call process%mci_entry(i_mci)%get_time (time, 10000) if (time%is_known ()) then write (u, "(3x,A,1x,A)") "T(10k evt) = ", char (time%to_string_dhms ()) else write (u, "(3x,A)") "T(10k evt) = [undefined]" end if call process%mci_entry(i_mci)%results%write (u) write (u, "(A)") repeat ("#", 79) call process%mci_entry(i_mci)%results%write_chain_weights (u) write (u, "(A)") repeat ("#", 79) call process%mci_entry(i_mci)%counter%write (u) write (u, "(A)") repeat ("#", 79) call process%mci_entry(i_mci)%mci%write_log_entry (u) write (u, "(A)") repeat ("#", 79) call process%beam_config%data%write (u) write (u, "(A)") repeat ("#", 79) if (allocated (process%config%ef_cuts)) then write (u, "(3x,A)") "Cut expression:" call process%config%ef_cuts%write (u) else write (u, "(3x,A)") "No cuts used." end if call write_separator (u) if (allocated (process%config%ef_scale)) then write (u, "(3x,A)") "Scale expression:" call process%config%ef_scale%write (u) else write (u, "(3x,A)") "No scale expression was given." end if call write_separator (u) if (allocated (process%config%ef_fac_scale)) then write (u, "(3x,A)") "Factorization scale expression:" call process%config%ef_fac_scale%write (u) else write (u, "(3x,A)") "No factorization scale expression was given." end if call write_separator (u) if (allocated (process%config%ef_ren_scale)) then write (u, "(3x,A)") "Renormalization scale expression:" call process%config%ef_ren_scale%write (u) else write (u, "(3x,A)") "No renormalization scale expression was given." end if call write_separator (u) if (allocated (process%config%ef_weight)) then call write_separator (u) write (u, "(3x,A)") "Weight expression:" call process%config%ef_weight%write (u) else write (u, "(3x,A)") "No weight expression was given." end if write (u, "(A)") repeat ("#", 79) write (u, "(1x,A)") "Summary of quantum-number states:" write (u, "(1x,A)") " + sign: allowed and contributing" write (u, "(1x,A)") " no + : switched off at runtime" call process%write_state_summary (u) write (u, "(A)") repeat ("#", 79) call process%env%write (u, show_var_list=.true., & show_model=.false., show_lib=.false., show_os_data=.false.) write (u, "(A)") repeat ("#", 79) close (u) end subroutine process_write_logfile @ %def process_write_logfile @ Display the quantum-number combinations of the process components, and their current status (allowed or switched off). <>= procedure :: write_state_summary => process_write_state_summary <>= subroutine process_write_state_summary (process, unit) class(process_t), intent(in) :: process integer, intent(in), optional :: unit integer :: i, i_component, u u = given_output_unit (unit) do i = 1, size (process%term) call write_separator (u) i_component = process%term(i)%i_component if (i_component /= 0) then call process%term(i)%write_state_summary & (process%get_core_term(i), unit) end if end do end subroutine process_write_state_summary @ %def process_write_state_summary @ Prepare event generation for the specified MCI entry. This implies, in particular, checking the phase-space file. <>= procedure :: prepare_simulation => process_prepare_simulation <>= subroutine process_prepare_simulation (process, i_mci) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci call process%mci_entry(i_mci)%prepare_simulation () end subroutine process_prepare_simulation @ %def process_prepare_simulation @ \subsubsection{Retrieve process data} Tell whether integral (and error) are known. <>= generic :: has_integral => has_integral_tot, has_integral_mci procedure :: has_integral_tot => process_has_integral_tot procedure :: has_integral_mci => process_has_integral_mci <>= function process_has_integral_mci (process, i_mci) result (flag) logical :: flag class(process_t), intent(in) :: process integer, intent(in) :: i_mci if (allocated (process%mci_entry)) then flag = process%mci_entry(i_mci)%has_integral () else flag = .false. end if end function process_has_integral_mci function process_has_integral_tot (process) result (flag) logical :: flag class(process_t), intent(in) :: process integer :: i, j, i_component if (allocated (process%mci_entry)) then flag = .true. do i = 1, size (process%mci_entry) do j = 1, size (process%mci_entry(i)%i_component) i_component = process%mci_entry(i)%i_component(j) if (process%component_can_be_integrated (i_component)) & flag = flag .and. process%mci_entry(i)%has_integral () end do end do else flag = .false. end if end function process_has_integral_tot @ %def process_has_integral @ Return the current integral and error obtained by the integrator [[i_mci]]. <>= generic :: get_integral => get_integral_tot, get_integral_mci generic :: get_error => get_error_tot, get_error_mci generic :: get_efficiency => get_efficiency_tot, get_efficiency_mci procedure :: get_integral_tot => process_get_integral_tot procedure :: get_integral_mci => process_get_integral_mci procedure :: get_error_tot => process_get_error_tot procedure :: get_error_mci => process_get_error_mci procedure :: get_efficiency_tot => process_get_efficiency_tot procedure :: get_efficiency_mci => process_get_efficiency_mci <>= function process_get_integral_mci (process, i_mci) result (integral) real(default) :: integral class(process_t), intent(in) :: process integer, intent(in) :: i_mci integral = process%mci_entry(i_mci)%get_integral () end function process_get_integral_mci function process_get_error_mci (process, i_mci) result (error) real(default) :: error class(process_t), intent(in) :: process integer, intent(in) :: i_mci error = process%mci_entry(i_mci)%get_error () end function process_get_error_mci function process_get_efficiency_mci (process, i_mci) result (efficiency) real(default) :: efficiency class(process_t), intent(in) :: process integer, intent(in) :: i_mci efficiency = process%mci_entry(i_mci)%get_efficiency () end function process_get_efficiency_mci function process_get_integral_tot (process) result (integral) real(default) :: integral class(process_t), intent(in) :: process integer :: i, j, i_component integral = zero if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) do j = 1, size (process%mci_entry(i)%i_component) i_component = process%mci_entry(i)%i_component(j) if (process%component_can_be_integrated(i_component)) & integral = integral + process%mci_entry(i)%get_integral () end do end do end if end function process_get_integral_tot function process_get_error_tot (process) result (error) real(default) :: variance class(process_t), intent(in) :: process real(default) :: error integer :: i, j, i_component variance = zero if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) do j = 1, size (process%mci_entry(i)%i_component) i_component = process%mci_entry(i)%i_component(j) if (process%component_can_be_integrated(i_component)) & variance = variance + process%mci_entry(i)%get_error () ** 2 end do end do end if error = sqrt (variance) end function process_get_error_tot function process_get_efficiency_tot (process) result (efficiency) real(default) :: efficiency class(process_t), intent(in) :: process real(default) :: den, eff, int integer :: i, j, i_component den = zero if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) do j = 1, size (process%mci_entry(i)%i_component) i_component = process%mci_entry(i)%i_component(j) if (process%component_can_be_integrated(i_component)) then int = process%get_integral (i) if (int > 0) then eff = process%mci_entry(i)%get_efficiency () if (eff > 0) then den = den + int / eff else efficiency = 0 return end if end if end if end do end do end if if (den > 0) then efficiency = process%get_integral () / den else efficiency = 0 end if end function process_get_efficiency_tot @ %def process_get_integral process_get_efficiency @ Let us call the ratio of the LO and the NLO result $\iota = I_{LO} / I_{NLO}$. Then usual error propagation gives \begin{equation*} \sigma_{\iota}^2 = \left(\frac{\partial \iota}{\partial I_{LO}}\right)^2 \sigma_{I_{LO}}^2 + \left(\frac{\partial \iota}{\partial I_{NLO}}\right)^2 \sigma_{I_{NLO}}^2 = \frac{I_{NLO}^2\sigma_{I_{LO}}^2}{I_{LO}^4} + \frac{\sigma_{I_{NLO}}^2}{I_{LO}^2}. \end{equation*} <>= procedure :: get_correction => process_get_correction procedure :: get_correction_error => process_get_correction_error <>= function process_get_correction (process) result (ratio) real(default) :: ratio class(process_t), intent(in) :: process integer :: i_mci real(default) :: int_born, int_nlo int_nlo = zero int_born = process%mci_entry(1)%get_integral () do i_mci = 2, size (process%mci_entry) if (process%component_can_be_integrated (i_mci)) & int_nlo = int_nlo + process%mci_entry(i_mci)%get_integral () end do ratio = int_nlo / int_born * 100 end function process_get_correction function process_get_correction_error (process) result (error) real(default) :: error class(process_t), intent(in) :: process real(default) :: int_born, sum_int_nlo real(default) :: err_born, err2 integer :: i_mci sum_int_nlo = zero; err2 = zero int_born = process%mci_entry(1)%get_integral () err_born = process%mci_entry(1)%get_error () do i_mci = 2, size (process%mci_entry) if (process%component_can_be_integrated (i_mci)) then sum_int_nlo = sum_int_nlo + process%mci_entry(i_mci)%get_integral () err2 = err2 + process%mci_entry(i_mci)%get_error()**2 end if end do error = sqrt (err2 / int_born**2 + sum_int_nlo**2 * err_born**2 / int_born**4) * 100 end function process_get_correction_error @ %def process_get_correction process_get_correction_error @ <>= procedure :: lab_is_cm_frame => process_lab_is_cm_frame <>= pure function process_lab_is_cm_frame (process) result (cm_frame) logical :: cm_frame class(process_t), intent(in) :: process cm_frame = process%beam_config%lab_is_cm_frame end function process_lab_is_cm_frame @ %def process_lab_is_cm_frame @ <>= procedure :: get_component_ptr => process_get_component_ptr <>= function process_get_component_ptr (process, i) result (component) type(process_component_t), pointer :: component class(process_t), intent(in), target :: process integer, intent(in) :: i component => process%component(i) end function process_get_component_ptr @ %def process_get_component_ptr @ <>= procedure :: get_qcd => process_get_qcd <>= function process_get_qcd (process) result (qcd) type(qcd_t) :: qcd class(process_t), intent(in) :: process qcd = process%config%get_qcd () end function process_get_qcd @ %def process_get_qcd @ <>= generic :: get_component_type => get_component_type_single procedure :: get_component_type_single => process_get_component_type_single <>= elemental function process_get_component_type_single & (process, i_component) result (comp_type) integer :: comp_type class(process_t), intent(in) :: process integer, intent(in) :: i_component comp_type = process%component(i_component)%component_type end function process_get_component_type_single @ %def process_get_component_type_single @ <>= generic :: get_component_type => get_component_type_all procedure :: get_component_type_all => process_get_component_type_all <>= function process_get_component_type_all & (process) result (comp_type) integer, dimension(:), allocatable :: comp_type class(process_t), intent(in) :: process allocate (comp_type (size (process%component))) comp_type = process%component%component_type end function process_get_component_type_all @ %def process_get_component_type_all @ <>= procedure :: get_component_i_terms => process_get_component_i_terms <>= function process_get_component_i_terms (process, i_component) result (i_term) integer, dimension(:), allocatable :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_component allocate (i_term (size (process%component(i_component)%i_term))) i_term = process%component(i_component)%i_term end function process_get_component_i_terms @ %def process_get_component_i_terms @ <>= procedure :: get_n_allowed_born => process_get_n_allowed_born <>= function process_get_n_allowed_born (process, i_born) result (n_born) class(process_t), intent(inout) :: process integer, intent(in) :: i_born integer :: n_born n_born = process%term(i_born)%n_allowed end function process_get_n_allowed_born @ %def process_get_n_allowed_born @ Workaround getter. Would be better to remove this. <>= procedure :: get_pcm_ptr => process_get_pcm_ptr <>= function process_get_pcm_ptr (process) result (pcm) class(pcm_t), pointer :: pcm class(process_t), intent(in), target :: process pcm => process%pcm end function process_get_pcm_ptr @ %def process_get_pcm_ptr <>= generic :: component_can_be_integrated => component_can_be_integrated_single generic :: component_can_be_integrated => component_can_be_integrated_all procedure :: component_can_be_integrated_single => process_component_can_be_integrated_single <>= function process_component_can_be_integrated_single (process, i_component) & result (active) logical :: active class(process_t), intent(in) :: process integer, intent(in) :: i_component logical :: combined_integration select type (pcm => process%pcm) type is (pcm_nlo_t) combined_integration = pcm%settings%combined_integration class default combined_integration = .false. end select associate (component => process%component(i_component)) active = component%can_be_integrated () if (combined_integration) & active = active .and. component%component_type <= COMP_MASTER end associate end function process_component_can_be_integrated_single @ %def process_component_can_be_integrated_single @ <>= procedure :: component_can_be_integrated_all => process_component_can_be_integrated_all <>= function process_component_can_be_integrated_all (process) result (val) logical, dimension(:), allocatable :: val class(process_t), intent(in) :: process integer :: i allocate (val (size (process%component))) do i = 1, size (process%component) val(i) = process%component_can_be_integrated (i) end do end function process_component_can_be_integrated_all @ %def process_component_can_be_integrated_all @ <>= procedure :: reset_selected_cores => process_reset_selected_cores <>= pure subroutine process_reset_selected_cores (process) class(process_t), intent(inout) :: process process%pcm%component_selected = .false. end subroutine process_reset_selected_cores @ %def process_reset_selected_cores @ <>= procedure :: select_components => process_select_components <>= pure subroutine process_select_components (process, indices) class(process_t), intent(inout) :: process integer, dimension(:), intent(in) :: indices associate (pcm => process%pcm) pcm%component_selected(indices) = .true. end associate end subroutine process_select_components @ %def process_select_components @ <>= procedure :: component_is_selected => process_component_is_selected <>= pure function process_component_is_selected (process, index) result (val) logical :: val class(process_t), intent(in) :: process integer, intent(in) :: index associate (pcm => process%pcm) val = pcm%component_selected(index) end associate end function process_component_is_selected @ %def process_component_is_selected @ <>= procedure :: get_coupling_powers => process_get_coupling_powers <>= pure subroutine process_get_coupling_powers (process, alpha_power, alphas_power) class(process_t), intent(in) :: process integer, intent(out) :: alpha_power, alphas_power call process%component(1)%config%get_coupling_powers (alpha_power, alphas_power) end subroutine process_get_coupling_powers @ %def process_get_coupling_powers @ <>= procedure :: get_real_component => process_get_real_component <>= function process_get_real_component (process) result (i_real) integer :: i_real class(process_t), intent(in) :: process integer :: i_component type(process_component_def_t), pointer :: config => null () i_real = 0 do i_component = 1, size (process%component) config => process%get_component_def_ptr (i_component) if (config%get_nlo_type () == NLO_REAL) then i_real = i_component exit end if end do end function process_get_real_component @ %def process_get_real_component @ <>= procedure :: extract_active_component_mci => process_extract_active_component_mci <>= function process_extract_active_component_mci (process) result (i_active) integer :: i_active class(process_t), intent(in) :: process integer :: i_mci, j, i_component, n_active call count_n_active () if (n_active /= 1) i_active = 0 contains subroutine count_n_active () n_active = 0 do i_mci = 1, size (process%mci_entry) associate (mci_entry => process%mci_entry(i_mci)) do j = 1, size (mci_entry%i_component) i_component = mci_entry%i_component(j) associate (component => process%component (i_component)) if (component%can_be_integrated ()) then i_active = i_mci n_active = n_active + 1 end if end associate end do end associate end do end subroutine count_n_active end function process_extract_active_component_mci @ %def process_extract_active_component_mci @ <>= procedure :: uses_real_partition => process_uses_real_partition <>= function process_uses_real_partition (process) result (val) logical :: val class(process_t), intent(in) :: process val = any (process%mci_entry%real_partition_type /= REAL_FULL) end function process_uses_real_partition @ %def process_uses_real_partition @ Return the MD5 sums that summarize the process component definitions. These values should be independent of parameters, beam details, expressions, etc. They can be used for checking the integrity of a process when reusing an old event file. <>= procedure :: get_md5sum_prc => process_get_md5sum_prc <>= function process_get_md5sum_prc (process, i_component) result (md5sum) character(32) :: md5sum class(process_t), intent(in) :: process integer, intent(in) :: i_component if (process%component(i_component)%active) then md5sum = process%component(i_component)%config%get_md5sum () else md5sum = "" end if end function process_get_md5sum_prc @ %def process_get_md5sum_prc @ Return the MD5 sums that summarize the state of the MCI integrators. These values should encode all process data, integration and phase space configuration, etc., and the integration results. They can thus be used for checking the integrity of an event-generation setup when reusing an old event file. <>= procedure :: get_md5sum_mci => process_get_md5sum_mci <>= function process_get_md5sum_mci (process, i_mci) result (md5sum) character(32) :: md5sum class(process_t), intent(in) :: process integer, intent(in) :: i_mci md5sum = process%mci_entry(i_mci)%get_md5sum () end function process_get_md5sum_mci @ %def process_get_md5sum_mci @ Return the MD5 sum of the process configuration. This should encode the process setup, data, and expressions, but no integration results. <>= procedure :: get_md5sum_cfg => process_get_md5sum_cfg <>= function process_get_md5sum_cfg (process) result (md5sum) character(32) :: md5sum class(process_t), intent(in) :: process md5sum = process%config%md5sum end function process_get_md5sum_cfg @ %def process_get_md5sum_cfg @ <>= procedure :: get_n_cores => process_get_n_cores <>= function process_get_n_cores (process) result (n) integer :: n class(process_t), intent(in) :: process n = process%pcm%n_cores end function process_get_n_cores @ %def process_get_n_cores @ <>= procedure :: get_base_i_term => process_get_base_i_term <>= function process_get_base_i_term (process, i_component) result (i_term) integer :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_component i_term = process%component(i_component)%i_term(1) end function process_get_base_i_term @ %def process_get_base_i_term @ <>= procedure :: get_core_term => process_get_core_term <>= function process_get_core_term (process, i_term) result (core) class(prc_core_t), pointer :: core class(process_t), intent(in), target :: process integer, intent(in) :: i_term integer :: i_core i_core = process%term(i_term)%i_core core => process%core_entry(i_core)%get_core_ptr () end function process_get_core_term @ %def process_get_core_term @ <>= procedure :: get_core_ptr => process_get_core_ptr <>= function process_get_core_ptr (process, i_core) result (core) class(prc_core_t), pointer :: core class(process_t), intent(in), target :: process integer, intent(in) :: i_core if (allocated (process%core_entry)) then core => process%core_entry(i_core)%get_core_ptr () else core => null () end if end function process_get_core_ptr @ %def process_get_core_ptr @ <>= procedure :: get_term_ptr => process_get_term_ptr <>= function process_get_term_ptr (process, i) result (term) type(process_term_t), pointer :: term class(process_t), intent(in), target :: process integer, intent(in) :: i term => process%term(i) end function process_get_term_ptr @ %def process_get_term_ptr @ <>= procedure :: get_i_term => process_get_i_term <>= function process_get_i_term (process, i_core) result (i_term) integer :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_core do i_term = 1, process%get_n_terms () if (process%term(i_term)%i_core == i_core) return end do i_term = -1 end function process_get_i_term @ %def process_get_i_term @ <>= procedure :: set_i_mci_work => process_set_i_mci_work <>= subroutine process_set_i_mci_work (process, i_mci) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci process%mci_entry(i_mci)%i_mci = i_mci end subroutine process_set_i_mci_work @ %def process_set_i_mci_work @ <>= procedure :: get_i_mci_work => process_get_i_mci_work <>= pure function process_get_i_mci_work (process, i_mci) result (i_mci_work) integer :: i_mci_work class(process_t), intent(in) :: process integer, intent(in) :: i_mci i_mci_work = process%mci_entry(i_mci)%i_mci end function process_get_i_mci_work @ %def process_get_i_mci_work @ <>= procedure :: get_i_sub => process_get_i_sub <>= elemental function process_get_i_sub (process, i_term) result (i_sub) integer :: i_sub class(process_t), intent(in) :: process integer, intent(in) :: i_term i_sub = process%term(i_term)%i_sub end function process_get_i_sub @ %def process_get_i_sub @ <>= procedure :: get_i_term_virtual => process_get_i_term_virtual <>= elemental function process_get_i_term_virtual (process) result (i_term) integer :: i_term class(process_t), intent(in) :: process integer :: i_component i_term = 0 do i_component = 1, size (process%component) if (process%component(i_component)%get_nlo_type () == NLO_VIRTUAL) & i_term = process%component(i_component)%i_term(1) end do end function process_get_i_term_virtual @ %def process_get_i_term_virtual @ <>= generic :: component_is_active => component_is_active_single procedure :: component_is_active_single => process_component_is_active_single <>= elemental function process_component_is_active_single (process, i_comp) result (val) logical :: val class(process_t), intent(in) :: process integer, intent(in) :: i_comp val = process%component(i_comp)%is_active () end function process_component_is_active_single @ %def process_component_is_active_single @ <>= generic :: component_is_active => component_is_active_all procedure :: component_is_active_all => process_component_is_active_all <>= pure function process_component_is_active_all (process) result (val) logical, dimension(:), allocatable :: val class(process_t), intent(in) :: process allocate (val (size (process%component))) val = process%component%is_active () end function process_component_is_active_all @ %def process_component_is_active_all @ \subsection{Default iterations} If the user does not specify the passes and iterations for integration, we should be able to give reasonable defaults. These depend on the process, therefore we implement the following procedures as methods of the process object. The algorithm is not very sophisticated yet, it may be improved by looking at the process in more detail. We investigate only the first process component, assuming that it characterizes the complexity of the process reasonable well. The number of passes is limited to two: one for adaption, one for integration. <>= procedure :: get_n_pass_default => process_get_n_pass_default procedure :: adapt_grids_default => process_adapt_grids_default procedure :: adapt_weights_default => process_adapt_weights_default <>= function process_get_n_pass_default (process) result (n_pass) class(process_t), intent(in) :: process integer :: n_pass integer :: n_eff type(process_component_def_t), pointer :: config config => process%component(1)%config n_eff = config%get_n_tot () - 2 select case (n_eff) case (1) n_pass = 1 case default n_pass = 2 end select end function process_get_n_pass_default function process_adapt_grids_default (process, pass) result (flag) class(process_t), intent(in) :: process integer, intent(in) :: pass logical :: flag integer :: n_eff type(process_component_def_t), pointer :: config config => process%component(1)%config n_eff = config%get_n_tot () - 2 select case (n_eff) case (1) flag = .false. case default select case (pass) case (1); flag = .true. case (2); flag = .false. case default call msg_bug ("adapt grids default: impossible pass index") end select end select end function process_adapt_grids_default function process_adapt_weights_default (process, pass) result (flag) class(process_t), intent(in) :: process integer, intent(in) :: pass logical :: flag integer :: n_eff type(process_component_def_t), pointer :: config config => process%component(1)%config n_eff = config%get_n_tot () - 2 select case (n_eff) case (1) flag = .false. case default select case (pass) case (1); flag = .true. case (2); flag = .false. case default call msg_bug ("adapt weights default: impossible pass index") end select end select end function process_adapt_weights_default @ %def process_get_n_pass_default @ %def process_adapt_grids_default @ %def process_adapt_weights_default @ The number of iterations and calls per iteration depends on the number of outgoing particles. <>= procedure :: get_n_it_default => process_get_n_it_default procedure :: get_n_calls_default => process_get_n_calls_default <>= function process_get_n_it_default (process, pass) result (n_it) class(process_t), intent(in) :: process integer, intent(in) :: pass integer :: n_it integer :: n_eff type(process_component_def_t), pointer :: config config => process%component(1)%config n_eff = config%get_n_tot () - 2 select case (pass) case (1) select case (n_eff) case (1); n_it = 1 case (2); n_it = 3 case (3); n_it = 5 case (4:5); n_it = 10 case (6); n_it = 15 case (7:); n_it = 20 end select case (2) select case (n_eff) case (:3); n_it = 3 case (4:); n_it = 5 end select end select end function process_get_n_it_default function process_get_n_calls_default (process, pass) result (n_calls) class(process_t), intent(in) :: process integer, intent(in) :: pass integer :: n_calls integer :: n_eff type(process_component_def_t), pointer :: config config => process%component(1)%config n_eff = config%get_n_tot () - 2 select case (pass) case (1) select case (n_eff) case (1); n_calls = 100 case (2); n_calls = 1000 case (3); n_calls = 5000 case (4); n_calls = 10000 case (5); n_calls = 20000 case (6:); n_calls = 50000 end select case (2) select case (n_eff) case (:3); n_calls = 10000 case (4); n_calls = 20000 case (5); n_calls = 50000 case (6); n_calls = 100000 case (7:); n_calls = 200000 end select end select end function process_get_n_calls_default @ %def process_get_n_it_default @ %def process_get_n_calls_default @ \subsection{Constant process data} Manually set the Run ID (unit test only). <>= procedure :: set_run_id => process_set_run_id <>= subroutine process_set_run_id (process, run_id) class(process_t), intent(inout) :: process type(string_t), intent(in) :: run_id process%meta%run_id = run_id end subroutine process_set_run_id @ %def process_set_run_id @ The following methods return basic process data that stay constant after initialization. The process and IDs. <>= procedure :: get_id => process_get_id procedure :: get_num_id => process_get_num_id procedure :: get_run_id => process_get_run_id procedure :: get_library_name => process_get_library_name <>= function process_get_id (process) result (id) class(process_t), intent(in) :: process type(string_t) :: id id = process%meta%id end function process_get_id function process_get_num_id (process) result (id) class(process_t), intent(in) :: process integer :: id id = process%meta%num_id end function process_get_num_id function process_get_run_id (process) result (id) class(process_t), intent(in) :: process type(string_t) :: id id = process%meta%run_id end function process_get_run_id function process_get_library_name (process) result (id) class(process_t), intent(in) :: process type(string_t) :: id id = process%meta%lib_name end function process_get_library_name @ %def process_get_id process_get_num_id @ %def process_get_run_id process_get_library_name @ The number of incoming particles. <>= procedure :: get_n_in => process_get_n_in <>= function process_get_n_in (process) result (n) class(process_t), intent(in) :: process integer :: n n = process%config%n_in end function process_get_n_in @ %def process_get_n_in @ The number of MCI data sets. <>= procedure :: get_n_mci => process_get_n_mci <>= function process_get_n_mci (process) result (n) class(process_t), intent(in) :: process integer :: n n = process%config%n_mci end function process_get_n_mci @ %def process_get_n_mci @ The number of process components, total. <>= procedure :: get_n_components => process_get_n_components <>= function process_get_n_components (process) result (n) class(process_t), intent(in) :: process integer :: n n = process%meta%n_components end function process_get_n_components @ %def process_get_n_components @ The number of process terms, total. <>= procedure :: get_n_terms => process_get_n_terms <>= function process_get_n_terms (process) result (n) class(process_t), intent(in) :: process integer :: n n = process%config%n_terms end function process_get_n_terms @ %def process_get_n_terms @ Return the indices of the components that belong to a specific MCI entry. <>= procedure :: get_i_component => process_get_i_component <>= subroutine process_get_i_component (process, i_mci, i_component) class(process_t), intent(in) :: process integer, intent(in) :: i_mci integer, dimension(:), intent(out), allocatable :: i_component associate (mci_entry => process%mci_entry(i_mci)) allocate (i_component (size (mci_entry%i_component))) i_component = mci_entry%i_component end associate end subroutine process_get_i_component @ %def process_get_i_component @ Return the ID of a specific component. <>= procedure :: get_component_id => process_get_component_id <>= function process_get_component_id (process, i_component) result (id) class(process_t), intent(in) :: process integer, intent(in) :: i_component type(string_t) :: id id = process%meta%component_id(i_component) end function process_get_component_id @ %def process_get_component_id @ Return a pointer to the definition of a specific component. <>= procedure :: get_component_def_ptr => process_get_component_def_ptr <>= function process_get_component_def_ptr (process, i_component) result (ptr) type(process_component_def_t), pointer :: ptr class(process_t), intent(in) :: process integer, intent(in) :: i_component ptr => process%config%process_def%get_component_def_ptr (i_component) end function process_get_component_def_ptr @ %def process_get_component_def_ptr @ These procedures extract and restore (by transferring the allocation) the process core. This is useful for changing process parameters from outside this module. <>= procedure :: extract_core => process_extract_core procedure :: restore_core => process_restore_core <>= subroutine process_extract_core (process, i_term, core) class(process_t), intent(inout) :: process integer, intent(in) :: i_term class(prc_core_t), intent(inout), allocatable :: core integer :: i_core i_core = process%term(i_term)%i_core call move_alloc (from = process%core_entry(i_core)%core, to = core) end subroutine process_extract_core subroutine process_restore_core (process, i_term, core) class(process_t), intent(inout) :: process integer, intent(in) :: i_term class(prc_core_t), intent(inout), allocatable :: core integer :: i_core i_core = process%term(i_term)%i_core call move_alloc (from = core, to = process%core_entry(i_core)%core) end subroutine process_restore_core @ %def process_extract_core @ %def process_restore_core @ The block of process constants. <>= procedure :: get_constants => process_get_constants <>= function process_get_constants (process, i_core) result (data) type(process_constants_t) :: data class(process_t), intent(in) :: process integer, intent(in) :: i_core data = process%core_entry(i_core)%core%data end function process_get_constants @ %def process_get_constants @ <>= procedure :: get_config => process_get_config <>= function process_get_config (process) result (config) type(process_config_data_t) :: config class(process_t), intent(in) :: process config = process%config end function process_get_config @ %def process_get_config @ Construct an MD5 sum for the constant data, including the NLO type. For the NLO type [[NLO_MISMATCH]], we pretend that this was [[NLO_SUBTRACTION]] instead. -TODO: should not depend explicitly on NLO data. +TODO wk 2018: should not depend explicitly on NLO data. <>= procedure :: get_md5sum_constants => process_get_md5sum_constants <>= function process_get_md5sum_constants (process, i_component, & type_string, nlo_type) result (this_md5sum) character(32) :: this_md5sum class(process_t), intent(in) :: process integer, intent(in) :: i_component type(string_t), intent(in) :: type_string integer, intent(in) :: nlo_type type(process_constants_t) :: data integer :: unit call process%env%fill_process_constants (process%meta%id, i_component, data) unit = data%fill_unit_for_md5sum (.false.) write (unit, '(A)') char(type_string) select case (nlo_type) case (NLO_MISMATCH) write (unit, '(I0)') NLO_SUBTRACTION case default write (unit, '(I0)') nlo_type end select rewind (unit) this_md5sum = md5sum (unit) close (unit) end function process_get_md5sum_constants @ %def process_get_md5sum_constants @ Return the set of outgoing flavors that are associated with a particular term. We deduce this from the effective interaction. <>= procedure :: get_term_flv_out => process_get_term_flv_out <>= subroutine process_get_term_flv_out (process, i_term, flv) class(process_t), intent(in), target :: process integer, intent(in) :: i_term type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv type(interaction_t), pointer :: int int => process%term(i_term)%int_eff if (.not. associated (int)) int => process%term(i_term)%int call interaction_get_flv_out (int, flv) end subroutine process_get_term_flv_out @ %def process_get_term_flv_out @ Return true if there is any unstable particle in any of the process terms. We decide this based on the provided model instance, not the one that is stored in the process object. <>= procedure :: contains_unstable => process_contains_unstable <>= function process_contains_unstable (process, model) result (flag) class(process_t), intent(in) :: process class(model_data_t), intent(in), target :: model logical :: flag integer :: i_term type(flavor_t), dimension(:,:), allocatable :: flv flag = .false. do i_term = 1, process%get_n_terms () call process%get_term_flv_out (i_term, flv) call flv%set_model (model) flag = .not. all (flv%is_stable ()) deallocate (flv) if (flag) return end do end function process_contains_unstable @ %def process_contains_unstable @ The nominal process energy. <>= procedure :: get_sqrts => process_get_sqrts <>= function process_get_sqrts (process) result (sqrts) class(process_t), intent(in) :: process real(default) :: sqrts sqrts = process%beam_config%data%get_sqrts () end function process_get_sqrts @ %def process_get_sqrts @ The beam polarization in case of simple degrees. <>= procedure :: get_polarization => process_get_polarization <>= function process_get_polarization (process) result (pol) class(process_t), intent(in) :: process real(default), dimension(2) :: pol pol = process%beam_config%data%get_polarization () end function process_get_polarization @ %def process_get_polarization @ <>= procedure :: get_meta => process_get_meta <>= function process_get_meta (process) result (meta) type(process_metadata_t) :: meta class(process_t), intent(in) :: process meta = process%meta end function process_get_meta @ %def process_get_meta <>= procedure :: has_matrix_element => process_has_matrix_element <>= function process_has_matrix_element (process, i, is_term_index) result (active) logical :: active class(process_t), intent(in) :: process integer, intent(in), optional :: i logical, intent(in), optional :: is_term_index integer :: i_component logical :: is_term is_term = .false. if (present (i)) then if (present (is_term_index)) is_term = is_term_index if (is_term) then i_component = process%term(i)%i_component else i_component = i end if active = process%component(i_component)%active else active = any (process%component%active) end if end function process_has_matrix_element @ %def process_has_matrix_element @ Pointer to the beam data object. <>= procedure :: get_beam_data_ptr => process_get_beam_data_ptr <>= function process_get_beam_data_ptr (process) result (beam_data) class(process_t), intent(in), target :: process type(beam_data_t), pointer :: beam_data beam_data => process%beam_config%data end function process_get_beam_data_ptr @ %def process_get_beam_data_ptr @ <>= procedure :: get_beam_config => process_get_beam_config <>= function process_get_beam_config (process) result (beam_config) type(process_beam_config_t) :: beam_config class(process_t), intent(in) :: process beam_config = process%beam_config end function process_get_beam_config @ %def process_get_beam_config @ <>= procedure :: get_beam_config_ptr => process_get_beam_config_ptr <>= function process_get_beam_config_ptr (process) result (beam_config) type(process_beam_config_t), pointer :: beam_config class(process_t), intent(in), target :: process beam_config => process%beam_config end function process_get_beam_config_ptr @ %def process_get_beam_config_ptr @ Return true if lab and c.m.\ frame coincide for this process. <>= procedure :: cm_frame => process_cm_frame <>= function process_cm_frame (process) result (flag) class(process_t), intent(in), target :: process logical :: flag type(beam_data_t), pointer :: beam_data beam_data => process%beam_config%data flag = beam_data%cm_frame () end function process_cm_frame @ %def process_cm_frame @ Get the PDF set currently in use, if any. <>= procedure :: get_pdf_set => process_get_pdf_set <>= function process_get_pdf_set (process) result (pdf_set) class(process_t), intent(in) :: process integer :: pdf_set pdf_set = process%beam_config%get_pdf_set () end function process_get_pdf_set @ %def process_get_pdf_set @ <>= procedure :: pcm_contains_pdfs => process_pcm_contains_pdfs <>= function process_pcm_contains_pdfs (process) result (has_pdfs) logical :: has_pdfs class(process_t), intent(in) :: process has_pdfs = process%pcm%has_pdfs end function process_pcm_contains_pdfs @ %def process_pcm_contains_pdfs @ Get the beam spectrum file currently in use, if any. <>= procedure :: get_beam_file => process_get_beam_file <>= function process_get_beam_file (process) result (file) class(process_t), intent(in) :: process type(string_t) :: file file = process%beam_config%get_beam_file () end function process_get_beam_file @ %def process_get_beam_file @ Pointer to the process variable list. <>= procedure :: get_var_list_ptr => process_get_var_list_ptr <>= function process_get_var_list_ptr (process) result (ptr) class(process_t), intent(in), target :: process type(var_list_t), pointer :: ptr ptr => process%env%get_var_list_ptr () end function process_get_var_list_ptr @ %def process_get_var_list_ptr @ Pointer to the common model. <>= procedure :: get_model_ptr => process_get_model_ptr <>= function process_get_model_ptr (process) result (ptr) class(process_t), intent(in) :: process class(model_data_t), pointer :: ptr ptr => process%config%model end function process_get_model_ptr @ %def process_get_model_ptr @ Use the embedded RNG factory to spawn a new random-number generator instance. (This modifies the state of the factory.) <>= procedure :: make_rng => process_make_rng <>= subroutine process_make_rng (process, rng) class(process_t), intent(inout) :: process class(rng_t), intent(out), allocatable :: rng if (allocated (process%rng_factory)) then call process%rng_factory%make (rng) else call msg_bug ("Process: make rng: factory not allocated") end if end subroutine process_make_rng @ %def process_make_rng @ \subsection{Compute an amplitude} Each process variant should allow for computing an amplitude value directly, without generating a process instance. The process component is selected by the index [[i]]. The term within the process component is selected by [[j]]. The momentum combination is transferred as the array [[p]]. The function sets the specific quantum state via the indices of a flavor [[f]], helicity [[h]], and color [[c]] combination. Each index refers to the list of flavor, helicity, and color states, respectively, as stored in the process data. Optionally, we may set factorization and renormalization scale. If unset, the partonic c.m.\ energy is inserted. The function checks arguments for validity. For invalid arguments (quantum states), we return zero. <>= procedure :: compute_amplitude => process_compute_amplitude <>= function process_compute_amplitude & (process, i_core, i, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced) & result (amp) class(process_t), intent(in), target :: process integer, intent(in) :: i_core integer, intent(in) :: i, j type(vector4_t), dimension(:), intent(in) :: p integer, intent(in) :: f, h, c real(default), intent(in), optional :: fac_scale, ren_scale real(default), intent(in), allocatable, optional :: alpha_qcd_forced real(default) :: fscale, rscale real(default), allocatable :: aqcd_forced complex(default) :: amp class(prc_core_t), pointer :: core amp = 0 if (0 < i .and. i <= process%meta%n_components) then if (process%component(i)%active) then associate (core => process%core_entry(i_core)%core) associate (data => core%data) if (size (p) == data%n_in + data%n_out & .and. 0 < f .and. f <= data%n_flv & .and. 0 < h .and. h <= data%n_hel & .and. 0 < c .and. c <= data%n_col) then if (present (fac_scale)) then fscale = fac_scale else fscale = sum (p(data%n_in+1:)) ** 1 end if if (present (ren_scale)) then rscale = ren_scale else rscale = fscale end if if (present (alpha_qcd_forced)) then if (allocated (alpha_qcd_forced)) & allocate (aqcd_forced, source = alpha_qcd_forced) end if amp = core%compute_amplitude (j, p, f, h, c, & fscale, rscale, aqcd_forced) end if end associate end associate else amp = 0 end if end if end function process_compute_amplitude @ %def process_compute_amplitude @ Sanity check for the process library. We abort the program if it has changed after process initialization. <>= procedure :: check_library_sanity => process_check_library_sanity <>= subroutine process_check_library_sanity (process) class(process_t), intent(in) :: process call process%env%check_lib_sanity (process%meta) end subroutine process_check_library_sanity @ %def process_check_library_sanity @ Reset the association to a process library. <>= procedure :: reset_library_ptr => process_reset_library_ptr <>= subroutine process_reset_library_ptr (process) class(process_t), intent(inout) :: process call process%env%reset_lib_ptr () end subroutine process_reset_library_ptr @ %def process_reset_library_ptr @ <>= procedure :: set_component_type => process_set_component_type <>= subroutine process_set_component_type (process, i_component, i_type) class(process_t), intent(inout) :: process integer, intent(in) :: i_component, i_type process%component(i_component)%component_type = i_type end subroutine process_set_component_type @ %def process_set_component_type @ <>= procedure :: set_counter_mci_entry => process_set_counter_mci_entry <>= subroutine process_set_counter_mci_entry (process, i_mci, counter) class(process_t), intent(inout) :: process integer, intent(in) :: i_mci type(process_counter_t), intent(in) :: counter process%mci_entry(i_mci)%counter = counter end subroutine process_set_counter_mci_entry @ %def process_set_counter_mci_entry @ This is for suppression of numerical noise in the integration results stored in the [[process_mci_entry]] type. As the error and efficiency enter the MD5 sum, we recompute it. <>= procedure :: pacify => process_pacify <>= subroutine process_pacify (process, efficiency_reset, error_reset) class(process_t), intent(inout) :: process logical, intent(in), optional :: efficiency_reset, error_reset logical :: eff_reset, err_reset integer :: i eff_reset = .false. err_reset = .false. if (present (efficiency_reset)) eff_reset = efficiency_reset if (present (error_reset)) err_reset = error_reset if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) call process%mci_entry(i)%results%pacify (efficiency_reset) if (allocated (process%mci_entry(i)%mci)) then associate (mci => process%mci_entry(i)%mci) if (process%mci_entry(i)%mci%error_known & .and. err_reset) & mci%error = 0 if (process%mci_entry(i)%mci%efficiency_known & .and. eff_reset) & mci%efficiency = 1 call mci%pacify (efficiency_reset, error_reset) call mci%compute_md5sum () end associate end if end do end if end subroutine process_pacify @ %def process_pacify @ The following methods are used only in the unit tests; the access process internals directly that would otherwise be hidden. <>= procedure :: test_allocate_sf_channels procedure :: test_set_component_sf_channel procedure :: test_get_mci_ptr <>= subroutine test_allocate_sf_channels (process, n) class(process_t), intent(inout) :: process integer, intent(in) :: n call process%beam_config%allocate_sf_channels (n) end subroutine test_allocate_sf_channels subroutine test_set_component_sf_channel (process, c) class(process_t), intent(inout) :: process integer, dimension(:), intent(in) :: c call process%component(1)%phs_config%set_sf_channel (c) end subroutine test_set_component_sf_channel subroutine test_get_mci_ptr (process, mci) class(process_t), intent(in), target :: process class(mci_t), intent(out), pointer :: mci mci => process%mci_entry(1)%mci end subroutine test_get_mci_ptr @ %def test_allocate_sf_channels @ %def test_set_component_sf_channel @ %def test_get_mci_ptr @ <>= procedure :: init_mci_work => process_init_mci_work <>= subroutine process_init_mci_work (process, mci_work, i) class(process_t), intent(in), target :: process type(mci_work_t), intent(out) :: mci_work integer, intent(in) :: i call mci_work%init (process%mci_entry(i)) end subroutine process_init_mci_work @ %def process_init_mci_work @ Prepare the process core with type [[test_me]], or otherwise the externally provided [[type_string]] version. The toy dispatchers as a procedure argument come handy, knowing that we need to support only the [[test_me]] and [[template]] matrix-element types. <>= procedure :: setup_test_cores => process_setup_test_cores <>= subroutine process_setup_test_cores (process, type_string) class(process_t), intent(inout) :: process class(prc_core_t), allocatable :: core type(string_t), intent(in), optional :: type_string if (present (type_string)) then select case (char (type_string)) case ("template") call process%setup_cores (dispatch_template_core) case ("test_me") call process%setup_cores (dispatch_test_me_core) case default call msg_bug ("process setup test cores: unsupported type string") end select else call process%setup_cores (dispatch_test_me_core) end if end subroutine process_setup_test_cores subroutine dispatch_test_me_core (core, core_def, model, & helicity_selection, qcd, use_color_factors, has_beam_pol) use prc_test_core, only: test_t class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_def_t), intent(in) :: core_def class(model_data_t), intent(in), target, optional :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol allocate (test_t :: core) end subroutine dispatch_test_me_core subroutine dispatch_template_core (core, core_def, model, & helicity_selection, qcd, use_color_factors, has_beam_pol) use prc_template_me, only: prc_template_me_t class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_def_t), intent(in) :: core_def class(model_data_t), intent(in), target, optional :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol allocate (prc_template_me_t :: core) select type (core) type is (prc_template_me_t) call core%set_parameters (model) end select end subroutine dispatch_template_core @ %def process_setup_test_cores @ <>= procedure :: get_connected_states => process_get_connected_states <>= function process_get_connected_states (process, i_component, & connected_terms) result (connected) type(connected_state_t), dimension(:), allocatable :: connected class(process_t), intent(in) :: process integer, intent(in) :: i_component type(connected_state_t), dimension(:), intent(in) :: connected_terms integer :: i, i_conn integer :: n_conn n_conn = 0 do i = 1, process%get_n_terms () if (process%term(i)%i_component == i_component) then n_conn = n_conn + 1 end if end do allocate (connected (n_conn)) i_conn = 1 do i = 1, process%get_n_terms () if (process%term(i)%i_component == i_component) then connected (i_conn) = connected_terms(i) i_conn = i_conn + 1 end if end do end function process_get_connected_states @ %def process_get_connected_states @ \subsection{NLO specifics} These subroutines (and the NLO specific properties they work on) could potentially be moved to [[pcm_nlo_t]] and used more generically in [[process_t]] with an appropriate interface in [[pcm_t]] -TODO: This is used only by event initialization, which deals with an incomplete +TODO wk 2018: This is used only by event initialization, which deals with an incomplete process object. <>= procedure :: init_nlo_settings => process_init_nlo_settings <>= subroutine process_init_nlo_settings (process, var_list) class(process_t), intent(inout) :: process type(var_list_t), intent(in), target :: var_list select type (pcm => process%pcm) type is (pcm_nlo_t) call pcm%init_nlo_settings (var_list) if (debug_active (D_SUBTRACTION) .or. debug_active (D_VIRTUAL)) & call pcm%settings%write () class default call msg_fatal ("Attempt to set nlo_settings with a non-NLO pcm!") end select end subroutine process_init_nlo_settings @ %def process_init_nlo_settings @ <>= generic :: get_nlo_type_component => get_nlo_type_component_single procedure :: get_nlo_type_component_single => process_get_nlo_type_component_single <>= elemental function process_get_nlo_type_component_single (process, i_component) result (val) integer :: val class(process_t), intent(in) :: process integer, intent(in) :: i_component val = process%component(i_component)%get_nlo_type () end function process_get_nlo_type_component_single @ %def process_get_nlo_type_component_single @ <>= generic :: get_nlo_type_component => get_nlo_type_component_all procedure :: get_nlo_type_component_all => process_get_nlo_type_component_all <>= pure function process_get_nlo_type_component_all (process) result (val) integer, dimension(:), allocatable :: val class(process_t), intent(in) :: process allocate (val (size (process%component))) val = process%component%get_nlo_type () end function process_get_nlo_type_component_all @ %def process_get_nlo_type_component_all @ <>= procedure :: is_nlo_calculation => process_is_nlo_calculation <>= function process_is_nlo_calculation (process) result (nlo) logical :: nlo class(process_t), intent(in) :: process select type (pcm => process%pcm) type is (pcm_nlo_t) nlo = .true. class default nlo = .false. end select end function process_is_nlo_calculation @ %def process_is_nlo_calculation @ <>= procedure :: is_combined_nlo_integration & => process_is_combined_nlo_integration <>= function process_is_combined_nlo_integration (process) result (combined) logical :: combined class(process_t), intent(in) :: process select type (pcm => process%pcm) type is (pcm_nlo_t) combined = pcm%settings%combined_integration class default combined = .false. end select end function process_is_combined_nlo_integration @ %def process_is_combined_nlo_integration @ <>= procedure :: component_is_real_finite => process_component_is_real_finite <>= pure function process_component_is_real_finite (process, i_component) & result (val) logical :: val class(process_t), intent(in) :: process integer, intent(in) :: i_component val = process%component(i_component)%component_type == COMP_REAL_FIN end function process_component_is_real_finite @ %def process_component_is_real_finite @ Return nlo data of a process component <>= procedure :: get_component_nlo_type => process_get_component_nlo_type <>= elemental function process_get_component_nlo_type (process, i_component) & result (nlo_type) integer :: nlo_type class(process_t), intent(in) :: process integer, intent(in) :: i_component nlo_type = process%component(i_component)%config%get_nlo_type () end function process_get_component_nlo_type @ %def process_get_component_nlo_type @ Return a pointer to the core that belongs to a component. <>= procedure :: get_component_core_ptr => process_get_component_core_ptr <>= function process_get_component_core_ptr (process, i_component) result (core) class(process_t), intent(in), target :: process integer, intent(in) :: i_component class(prc_core_t), pointer :: core integer :: i_core i_core = process%pcm%get_i_core(i_component) core => process%core_entry(i_core)%core end function process_get_component_core_ptr @ %def process_get_component_core_ptr @ <>= procedure :: get_component_associated_born & => process_get_component_associated_born <>= function process_get_component_associated_born (process, i_component) & result (i_born) class(process_t), intent(in) :: process integer, intent(in) :: i_component integer :: i_born i_born = process%component(i_component)%config%get_associated_born () end function process_get_component_associated_born @ %def process_get_component_associated_born @ <>= procedure :: get_first_real_component => process_get_first_real_component <>= function process_get_first_real_component (process) result (i_real) integer :: i_real class(process_t), intent(in) :: process i_real = process%component(1)%config%get_associated_real () end function process_get_first_real_component @ %def process_get_first_real_component @ <>= procedure :: get_first_real_term => process_get_first_real_term <>= function process_get_first_real_term (process) result (i_real) integer :: i_real class(process_t), intent(in) :: process integer :: i_component, i_term i_component = process%component(1)%config%get_associated_real () i_real = 0 do i_term = 1, size (process%term) if (process%term(i_term)%i_component == i_component) then i_real = i_term exit end if end do if (i_real == 0) call msg_fatal ("Did not find associated real term!") end function process_get_first_real_term @ %def process_get_first_real_term @ <>= procedure :: get_associated_real_fin => process_get_associated_real_fin <>= elemental function process_get_associated_real_fin (process, i_component) result (i_real) integer :: i_real class(process_t), intent(in) :: process integer, intent(in) :: i_component i_real = process%component(i_component)%config%get_associated_real_fin () end function process_get_associated_real_fin @ %def process_get_associated_real_fin @ <>= procedure :: select_i_term => process_select_i_term <>= pure function process_select_i_term (process, i_mci) result (i_term) integer :: i_term class(process_t), intent(in) :: process integer, intent(in) :: i_mci integer :: i_component, i_sub i_component = process%mci_entry(i_mci)%i_component(1) i_term = process%component(i_component)%i_term(1) i_sub = process%term(i_term)%i_sub if (i_sub > 0) & i_term = process%term(i_sub)%i_term_global end function process_select_i_term @ %def process_select_i_term @ Would be better to do this at the level of the writer of the core but one has to bring NLO information there. <>= procedure :: prepare_any_external_code & => process_prepare_any_external_code <>= subroutine process_prepare_any_external_code (process) class(process_t), intent(inout), target :: process integer :: i call msg_debug2 (D_PROCESS_INTEGRATION, & "process_prepare_external_code") associate (pcm => process%pcm) do i = 1, pcm%n_cores call pcm%prepare_any_external_code ( & process%core_entry(i), i, & process%get_library_name (), & process%config%model, & process%env%get_var_list_ptr ()) end do end associate end subroutine process_prepare_any_external_code @ %def process_prepare_any_external_code @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process config} <<[[process_config.f90]]>>= <> module process_config <> <> use format_utils, only: write_separator use io_units use md5 use os_interface use diagnostics use sf_base use sf_mappings use mappings, only: mapping_defaults_t use phs_forests, only: phs_parameters_t use sm_qcd use physics_defs use integration_results use model_data use models use interactions use quantum_numbers use flavors use helicities use colors use rng_base use state_matrices use process_libraries use process_constants use prc_core use prc_external use prc_openloops, only: prc_openloops_t use prc_threshold, only: prc_threshold_t use beams use dispatch_beams, only: dispatch_qcd use mci_base use beam_structures use phs_base use variables use expr_base use blha_olp_interfaces, only: prc_blha_t <> <> <> <> contains <> end module process_config @ %def process_config @ Identifiers for the NLO setup. <>= integer, parameter, public :: COMP_DEFAULT = 0 integer, parameter, public :: COMP_REAL_FIN = 1 integer, parameter, public :: COMP_MASTER = 2 integer, parameter, public :: COMP_VIRT = 3 integer, parameter, public :: COMP_REAL = 4 integer, parameter, public :: COMP_REAL_SING = 5 integer, parameter, public :: COMP_MISMATCH = 6 integer, parameter, public :: COMP_PDF = 7 integer, parameter, public :: COMP_SUB = 8 integer, parameter, public :: COMP_RESUM = 9 @ \subsection{Output selection flags} We declare a number of identifiers for write methods, so they only displays selected parts. The identifiers can be supplied to the [[vlist]] array argument of the standard F2008 derived-type writer call. <>= integer, parameter, public :: F_PACIFY = 1 integer, parameter, public :: F_SHOW_VAR_LIST = 11 integer, parameter, public :: F_SHOW_EXPRESSIONS = 12 integer, parameter, public :: F_SHOW_LIB = 13 integer, parameter, public :: F_SHOW_MODEL = 14 integer, parameter, public :: F_SHOW_QCD = 15 integer, parameter, public :: F_SHOW_OS_DATA = 16 integer, parameter, public :: F_SHOW_RNG = 17 integer, parameter, public :: F_SHOW_BEAMS = 18 @ %def SHOW_VAR_LIST @ %def SHOW_EXPRESSIONS @ This is a simple function that returns true if a flag value is present in [[v_list]], but not its negative. If neither is present, it returns [[default]]. <>= public :: flagged <>= function flagged (v_list, id, def) result (flag) logical :: flag integer, dimension(:), intent(in) :: v_list integer, intent(in) :: id logical, intent(in), optional :: def logical :: default_result default_result = .false.; if (present (def)) default_result = def if (default_result) then flag = all (v_list /= -id) else flag = all (v_list /= -id) .and. any (v_list == id) end if end function flagged @ %def flagged @ Related: if flag is set (unset), append [[value]] (its negative) to the [[v_list]], respectively. [[v_list]] must be allocated. <>= public :: set_flag <>= subroutine set_flag (v_list, value, flag) integer, dimension(:), intent(inout), allocatable :: v_list integer, intent(in) :: value logical, intent(in), optional :: flag if (present (flag)) then if (flag) then v_list = [v_list, value] else v_list = [v_list, -value] end if end if end subroutine set_flag @ %def set_flag @ \subsection{Generic configuration data} This information concerns physical and technical properties of the process. It is fixed upon initialization, using data from the process specification and the variable list. The number [[n_in]] is the number of incoming beam particles, simultaneously the number of incoming partons, 1 for a decay and 2 for a scattering process. (The number of outgoing partons may depend on the process component.) The number [[n_components]] is the number of components that constitute the current process. The number [[n_terms]] is the number of distinct contributions to the scattering matrix that constitute the current process. Each component may generate several terms. The number [[n_mci]] is the number of independent MC integration configurations that this process uses. Distinct process components that share a MCI configuration may be combined pointwise. (Nevertheless, a given MC variable set may correspond to several ``nearby'' kinematical configurations.) This is also the number of distinct sampling-function results that this process can generate. Process components that use distinct variable sets are added only once after an integration pass has completed. The [[model]] pointer identifies the physics model and its parameters. This is a pointer to an external object. Various [[parse_node_t]] objects are taken from the SINDARIN input. They encode expressions for evaluating cuts and scales. The workspaces for evaluating those expressions are set up in the [[effective_state]] subobjects. Note that these are really pointers, so the actual nodes are not stored inside the process object. The [[md5sum]] is taken and used to verify the process configuration when re-reading data from file. <>= public :: process_config_data_t <>= type :: process_config_data_t class(process_def_t), pointer :: process_def => null () integer :: n_in = 0 integer :: n_components = 0 integer :: n_terms = 0 integer :: n_mci = 0 type(string_t) :: model_name class(model_data_t), pointer :: model => null () type(qcd_t) :: qcd class(expr_factory_t), allocatable :: ef_cuts class(expr_factory_t), allocatable :: ef_scale class(expr_factory_t), allocatable :: ef_fac_scale class(expr_factory_t), allocatable :: ef_ren_scale class(expr_factory_t), allocatable :: ef_weight character(32) :: md5sum = "" contains <> end type process_config_data_t @ %def process_config_data_t @ Here, we may compress the expressions for cuts etc. <>= procedure :: write => process_config_data_write <>= subroutine process_config_data_write (config, u, counters, model, expressions) class(process_config_data_t), intent(in) :: config integer, intent(in) :: u logical, intent(in) :: counters logical, intent(in) :: model logical, intent(in) :: expressions write (u, "(1x,A)") "Configuration data:" if (counters) then write (u, "(3x,A,I0)") "Number of incoming particles = ", & config%n_in write (u, "(3x,A,I0)") "Number of process components = ", & config%n_components write (u, "(3x,A,I0)") "Number of process terms = ", & config%n_terms write (u, "(3x,A,I0)") "Number of MCI configurations = ", & config%n_mci end if if (associated (config%model)) then write (u, "(3x,A,A)") "Model = ", char (config%model_name) if (model) then call write_separator (u) call config%model%write (u) call write_separator (u) end if else write (u, "(3x,A,A,A)") "Model = ", char (config%model_name), & " [not associated]" end if call config%qcd%write (u, show_md5sum = .false.) call write_separator (u) if (expressions) then if (allocated (config%ef_cuts)) then call write_separator (u) write (u, "(3x,A)") "Cut expression:" call config%ef_cuts%write (u) end if if (allocated (config%ef_scale)) then call write_separator (u) write (u, "(3x,A)") "Scale expression:" call config%ef_scale%write (u) end if if (allocated (config%ef_fac_scale)) then call write_separator (u) write (u, "(3x,A)") "Factorization scale expression:" call config%ef_fac_scale%write (u) end if if (allocated (config%ef_ren_scale)) then call write_separator (u) write (u, "(3x,A)") "Renormalization scale expression:" call config%ef_ren_scale%write (u) end if if (allocated (config%ef_weight)) then call write_separator (u) write (u, "(3x,A)") "Weight expression:" call config%ef_weight%write (u) end if else call write_separator (u) write (u, "(3x,A)") "Expressions (cut, scales, weight): [not shown]" end if if (config%md5sum /= "") then call write_separator (u) write (u, "(3x,A,A,A)") "MD5 sum (config) = '", config%md5sum, "'" end if end subroutine process_config_data_write @ %def process_config_data_write @ Initialize. We use information from the process metadata and from the process library, given the process ID. We also store the currently active OS data set. The model pointer references the model data within the [[env]] record. That should be an instance of the global model. We initialize the QCD object, unless the environment information is unavailable (unit tests). The RNG factory object is imported by moving the allocation. <>= procedure :: init => process_config_data_init <>= subroutine process_config_data_init (config, meta, env) class(process_config_data_t), intent(out) :: config type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env config%process_def => env%lib%get_process_def_ptr (meta%id) config%n_in = config%process_def%get_n_in () config%n_components = size (meta%component_id) config%model => env%get_model_ptr () config%model_name = config%model%get_name () if (env%got_var_list ()) then call dispatch_qcd & (config%qcd, env%get_var_list_ptr (), env%get_os_data ()) end if end subroutine process_config_data_init @ %def process_config_data_init @ Current implementation: nothing to finalize. <>= procedure :: final => process_config_data_final <>= subroutine process_config_data_final (config) class(process_config_data_t), intent(inout) :: config end subroutine process_config_data_final @ %def process_config_data_final @ Return a copy of the QCD data block. <>= procedure :: get_qcd => process_config_data_get_qcd <>= function process_config_data_get_qcd (config) result (qcd) class(process_config_data_t), intent(in) :: config type(qcd_t) :: qcd qcd = config%qcd end function process_config_data_get_qcd @ %def process_config_data_get_qcd @ Compute the MD5 sum of the configuration data. This encodes, in particular, the model and the expressions for cut, scales, weight, etc. It should not contain the IDs and number of components, etc., since the MD5 sum should be useful for integrating individual components. This is done only once. If the MD5 sum is nonempty, the calculation is skipped. <>= procedure :: compute_md5sum => process_config_data_compute_md5sum <>= subroutine process_config_data_compute_md5sum (config) class(process_config_data_t), intent(inout) :: config integer :: u if (config%md5sum == "") then u = free_unit () open (u, status = "scratch", action = "readwrite") call config%write (u, counters = .false., & model = .true., expressions = .true.) rewind (u) config%md5sum = md5sum (u) close (u) end if end subroutine process_config_data_compute_md5sum @ %def process_config_data_compute_md5sum @ <>= procedure :: get_md5sum => process_config_data_get_md5sum <>= pure function process_config_data_get_md5sum (config) result (md5) character(32) :: md5 class(process_config_data_t), intent(in) :: config md5 = config%md5sum end function process_config_data_get_md5sum @ %def process_config_data_get_md5sum @ \subsection{Environment} This record stores a snapshot of the process environment at the point where the process object is created. Model and variable list are implemented as pointer, so they always have the [[target]] attribute. For unit-testing purposes, setting the var list is optional. If not set, the pointer is null. <>= public :: process_environment_t <>= type :: process_environment_t private type(model_t), pointer :: model => null () type(var_list_t), pointer :: var_list => null () logical :: var_list_is_set = .false. type(process_library_t), pointer :: lib => null () type(beam_structure_t) :: beam_structure type(os_data_t) :: os_data contains <> end type process_environment_t @ %def process_environment_t @ Model and local var list are snapshots and need a finalizer. <>= procedure :: final => process_environment_final <>= subroutine process_environment_final (env) class(process_environment_t), intent(inout) :: env if (associated (env%model)) then call env%model%final () deallocate (env%model) end if if (associated (env%var_list)) then call env%var_list%final (follow_link=.true.) deallocate (env%var_list) end if end subroutine process_environment_final @ %def process_environment_final @ Output, DTIO compatible. <>= procedure :: write => process_environment_write procedure :: write_formatted => process_environment_write_formatted ! generic :: write (formatted) => write_formatted <>= subroutine process_environment_write (env, unit, & show_var_list, show_model, show_lib, show_beams, show_os_data) class(process_environment_t), intent(in) :: env integer, intent(in), optional :: unit logical, intent(in), optional :: show_var_list logical, intent(in), optional :: show_model logical, intent(in), optional :: show_lib logical, intent(in), optional :: show_beams logical, intent(in), optional :: show_os_data integer :: u, iostat integer, dimension(:), allocatable :: v_list character(0) :: iomsg u = given_output_unit (unit) allocate (v_list (0)) call set_flag (v_list, F_SHOW_VAR_LIST, show_var_list) call set_flag (v_list, F_SHOW_MODEL, show_model) call set_flag (v_list, F_SHOW_LIB, show_lib) call set_flag (v_list, F_SHOW_BEAMS, show_beams) call set_flag (v_list, F_SHOW_OS_DATA, show_os_data) call env%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg) end subroutine process_environment_write @ %def process_environment_write @ DTIO standard write. <>= subroutine process_environment_write_formatted & (dtv, unit, iotype, v_list, iostat, iomsg) class(process_environment_t), intent(in) :: dtv integer, intent(in) :: unit character(*), intent(in) :: iotype integer, dimension(:), intent(in) :: v_list integer, intent(out) :: iostat character(*), intent(inout) :: iomsg associate (env => dtv) if (flagged (v_list, F_SHOW_VAR_LIST, .true.)) then write (unit, "(1x,A)") "Variable list:" if (associated (env%var_list)) then call write_separator (unit) call env%var_list%write (unit) else write (unit, "(3x,A)") "[not allocated]" end if call write_separator (unit) end if if (flagged (v_list, F_SHOW_MODEL, .true.)) then write (unit, "(1x,A)") "Model:" if (associated (env%model)) then call write_separator (unit) call env%model%write (unit) else write (unit, "(3x,A)") "[not allocated]" end if call write_separator (unit) end if if (flagged (v_list, F_SHOW_LIB, .true.)) then write (unit, "(1x,A)") "Process library:" if (associated (env%lib)) then call write_separator (unit) call env%lib%write (unit) else write (unit, "(3x,A)") "[not allocated]" end if end if if (flagged (v_list, F_SHOW_BEAMS, .true.)) then call write_separator (unit) call env%beam_structure%write (unit) end if if (flagged (v_list, F_SHOW_OS_DATA, .true.)) then write (unit, "(1x,A)") "Operating-system data:" call write_separator (unit) call env%os_data%write (unit) end if end associate iostat = 0 end subroutine process_environment_write_formatted @ %def process_environment_write_formatted @ Initialize: Make a snapshot of the provided model. Make a link to the current process library. Also make a snapshot of the variable list, if provided. If none is provided, there is an empty variable list nevertheless, so a pointer lookup does not return null. If no beam structure is provided, the beam-structure member is empty and will yield a number of zero beams when queried. <>= procedure :: init => process_environment_init <>= subroutine process_environment_init & (env, model, lib, os_data, var_list, beam_structure) class(process_environment_t), intent(out) :: env type(model_t), intent(in), target :: model type(process_library_t), intent(in), target :: lib type(os_data_t), intent(in) :: os_data type(var_list_t), intent(in), target, optional :: var_list type(beam_structure_t), intent(in), optional :: beam_structure allocate (env%model) call env%model%init_instance (model) env%lib => lib env%os_data = os_data allocate (env%var_list) if (present (var_list)) then call env%var_list%init_snapshot (var_list, follow_link=.true.) env%var_list_is_set = .true. end if if (present (beam_structure)) then env%beam_structure = beam_structure end if end subroutine process_environment_init @ %def process_environment_init @ Indicate whether a variable list has been provided upon initialization. <>= procedure :: got_var_list => process_environment_got_var_list <>= function process_environment_got_var_list (env) result (flag) class(process_environment_t), intent(in) :: env logical :: flag flag = env%var_list_is_set end function process_environment_got_var_list @ %def process_environment_got_var_list @ Return a pointer to the variable list. <>= procedure :: get_var_list_ptr => process_environment_get_var_list_ptr <>= function process_environment_get_var_list_ptr (env) result (var_list) class(process_environment_t), intent(in) :: env type(var_list_t), pointer :: var_list var_list => env%var_list end function process_environment_get_var_list_ptr @ %def process_environment_get_var_list_ptr @ Return a pointer to the model, if it exists. <>= procedure :: get_model_ptr => process_environment_get_model_ptr <>= function process_environment_get_model_ptr (env) result (model) class(process_environment_t), intent(in) :: env type(model_t), pointer :: model model => env%model end function process_environment_get_model_ptr @ %def process_environment_get_model_ptr @ Return the process library pointer. <>= procedure :: get_lib_ptr => process_environment_get_lib_ptr <>= function process_environment_get_lib_ptr (env) result (lib) class(process_environment_t), intent(inout) :: env type(process_library_t), pointer :: lib lib => env%lib end function process_environment_get_lib_ptr @ %def process_environment_get_lib_ptr @ Clear the process library pointer, in case the library is deleted. <>= procedure :: reset_lib_ptr => process_environment_reset_lib_ptr <>= subroutine process_environment_reset_lib_ptr (env) class(process_environment_t), intent(inout) :: env env%lib => null () end subroutine process_environment_reset_lib_ptr @ %def process_environment_reset_lib_ptr @ Check whether the process library has changed, in case the library is recompiled, etc. <>= procedure :: check_lib_sanity => process_environment_check_lib_sanity <>= subroutine process_environment_check_lib_sanity (env, meta) class(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta if (associated (env%lib)) then if (env%lib%get_update_counter () /= meta%lib_update_counter) then call msg_fatal ("Process '" // char (meta%id) & // "': library has been recompiled after integration") end if end if end subroutine process_environment_check_lib_sanity @ %def process_environment_check_lib_sanity @ Fill the [[data]] block using the appropriate process-library access entry. <>= procedure :: fill_process_constants => & process_environment_fill_process_constants <>= subroutine process_environment_fill_process_constants & (env, id, i_component, data) class(process_environment_t), intent(in) :: env type(string_t), intent(in) :: id integer, intent(in) :: i_component type(process_constants_t), intent(out) :: data call env%lib%fill_constants (id, i_component, data) end subroutine process_environment_fill_process_constants @ %def process_environment_fill_process_constants @ Return the entire beam structure. <>= procedure :: get_beam_structure => process_environment_get_beam_structure <>= function process_environment_get_beam_structure (env) result (beam_structure) class(process_environment_t), intent(in) :: env type(beam_structure_t) :: beam_structure beam_structure = env%beam_structure end function process_environment_get_beam_structure @ %def process_environment_get_beam_structure @ Check the beam structure for PDFs. <>= procedure :: has_pdfs => process_environment_has_pdfs <>= function process_environment_has_pdfs (env) result (flag) class(process_environment_t), intent(in) :: env logical :: flag flag = env%beam_structure%has_pdf () end function process_environment_has_pdfs @ %def process_environment_has_pdfs @ Check the beam structure for polarized beams. <>= procedure :: has_polarized_beams => process_environment_has_polarized_beams <>= function process_environment_has_polarized_beams (env) result (flag) class(process_environment_t), intent(in) :: env logical :: flag flag = env%beam_structure%has_polarized_beams () end function process_environment_has_polarized_beams @ %def process_environment_has_polarized_beams @ Return a copy of the OS data block. <>= procedure :: get_os_data => process_environment_get_os_data <>= function process_environment_get_os_data (env) result (os_data) class(process_environment_t), intent(in) :: env type(os_data_t) :: os_data os_data = env%os_data end function process_environment_get_os_data @ %def process_environment_get_os_data @ \subsection{Metadata} This information describes the process. It is fixed upon initialization. The [[id]] string is the name of the process object, as given by the user. The matrix element generator will use this string for naming Fortran procedures and types, so it should qualify as a Fortran name. The [[num_id]] is meaningful if nonzero. It is used for communication with external programs or file standards which do not support string IDs. The [[run_id]] string distinguishes among several runs for the same process. It identifies process instances with respect to adapted integration grids and similar run-specific data. The run ID is kept when copying processes for creating instances, however, so it does not distinguish event samples. The [[lib_name]] identifies the process library where the process definition and the process driver are located. The [[lib_index]] is the index of entry in the process library that corresponds to the current process. The [[component_id]] array identifies the individual process components. The [[component_description]] is an array of human-readable strings that characterize the process components, for instance [[a, b => c, d]]. The [[active]] mask array marks those components which are active. The others are skipped. <>= public :: process_metadata_t <>= type :: process_metadata_t integer :: type = PRC_UNKNOWN type(string_t) :: id integer :: num_id = 0 type(string_t) :: run_id type(string_t), allocatable :: lib_name integer :: lib_update_counter = 0 integer :: lib_index = 0 integer :: n_components = 0 type(string_t), dimension(:), allocatable :: component_id type(string_t), dimension(:), allocatable :: component_description logical, dimension(:), allocatable :: active contains <> end type process_metadata_t @ %def process_metadata_t @ Output: ID and run ID. We write the variable list only upon request. <>= procedure :: write => process_metadata_write <>= subroutine process_metadata_write (meta, u, screen) class(process_metadata_t), intent(in) :: meta integer, intent(in) :: u logical, intent(in) :: screen integer :: i select case (meta%type) case (PRC_UNKNOWN) if (screen) then write (msg_buffer, "(A)") "Process [undefined]" else write (u, "(1x,A)") "Process [undefined]" end if return case (PRC_DECAY) if (screen) then write (msg_buffer, "(A,1x,A,A,A)") "Process [decay]:", & "'", char (meta%id), "'" else write (u, "(1x,A)", advance="no") "Process [decay]:" end if case (PRC_SCATTERING) if (screen) then write (msg_buffer, "(A,1x,A,A,A)") "Process [scattering]:", & "'", char (meta%id), "'" else write (u, "(1x,A)", advance="no") "Process [scattering]:" end if case default call msg_bug ("process_write: undefined process type") end select if (screen) then call msg_message () else write (u, "(1x,A,A,A)") "'", char (meta%id), "'" end if if (meta%num_id /= 0) then if (screen) then write (msg_buffer, "(2x,A,I0)") "ID (num) = ", meta%num_id call msg_message () else write (u, "(3x,A,I0)") "ID (num) = ", meta%num_id end if end if if (screen) then if (meta%run_id /= "") then write (msg_buffer, "(2x,A,A,A)") "Run ID = '", & char (meta%run_id), "'" call msg_message () end if else write (u, "(3x,A,A,A)") "Run ID = '", char (meta%run_id), "'" end if if (allocated (meta%lib_name)) then if (screen) then write (msg_buffer, "(2x,A,A,A)") "Library name = '", & char (meta%lib_name), "'" call msg_message () else write (u, "(3x,A,A,A)") "Library name = '", & char (meta%lib_name), "'" end if else if (screen) then write (msg_buffer, "(2x,A)") "Library name = [not associated]" call msg_message () else write (u, "(3x,A)") "Library name = [not associated]" end if end if if (screen) then write (msg_buffer, "(2x,A,I0)") "Process index = ", meta%lib_index call msg_message () else write (u, "(3x,A,I0)") "Process index = ", meta%lib_index end if if (allocated (meta%component_id)) then if (screen) then if (any (meta%active)) then write (msg_buffer, "(2x,A)") "Process components:" else write (msg_buffer, "(2x,A)") "Process components: [none]" end if call msg_message () else write (u, "(3x,A)") "Process components:" end if do i = 1, size (meta%component_id) if (.not. meta%active(i)) cycle if (screen) then write (msg_buffer, "(4x,I0,9A)") i, ": '", & char (meta%component_id (i)), "': ", & char (meta%component_description (i)) call msg_message () else write (u, "(5x,I0,9A)") i, ": '", & char (meta%component_id (i)), "': ", & char (meta%component_description (i)) end if end do end if if (screen) then write (msg_buffer, "(A)") repeat ("-", 72) call msg_message () else call write_separator (u) end if end subroutine process_metadata_write @ %def process_metadata_write @ Short output: list components. <>= procedure :: show => process_metadata_show <>= subroutine process_metadata_show (meta, u, model_name) class(process_metadata_t), intent(in) :: meta integer, intent(in) :: u type(string_t), intent(in) :: model_name integer :: i select case (meta%type) case (PRC_UNKNOWN) write (u, "(A)") "Process: [undefined]" return case default write (u, "(A)", advance="no") "Process:" end select write (u, "(1x,A)", advance="no") char (meta%id) select case (meta%num_id) case (0) case default write (u, "(1x,'(',I0,')')", advance="no") meta%num_id end select select case (char (model_name)) case ("") case default write (u, "(1x,'[',A,']')", advance="no") char (model_name) end select write (u, *) if (allocated (meta%component_id)) then do i = 1, size (meta%component_id) if (meta%active(i)) then write (u, "(2x,I0,':',1x,A)") i, & char (meta%component_description (i)) end if end do end if end subroutine process_metadata_show @ %def process_metadata_show @ Initialize. Find process ID and run ID. Also find the process ID in the process library and retrieve some metadata from there. <>= procedure :: init => process_metadata_init <>= subroutine process_metadata_init (meta, id, lib, var_list) class(process_metadata_t), intent(out) :: meta type(string_t), intent(in) :: id type(process_library_t), intent(in), target :: lib type(var_list_t), intent(in) :: var_list select case (lib%get_n_in (id)) case (1); meta%type = PRC_DECAY case (2); meta%type = PRC_SCATTERING case default call msg_bug ("Process '" // char (id) // "': impossible n_in") end select meta%id = id meta%run_id = var_list%get_sval (var_str ("$run_id")) allocate (meta%lib_name) meta%lib_name = lib%get_name () meta%lib_update_counter = lib%get_update_counter () if (lib%contains (id)) then meta%lib_index = lib%get_entry_index (id) meta%num_id = lib%get_num_id (id) call lib%get_component_list (id, meta%component_id) meta%n_components = size (meta%component_id) call lib%get_component_description_list & (id, meta%component_description) allocate (meta%active (meta%n_components), source = .true.) else call msg_fatal ("Process library doesn't contain process '" & // char (id) // "'") end if if (.not. lib%is_active ()) then call msg_bug ("Process init: inactive library not handled yet") end if end subroutine process_metadata_init @ %def process_metadata_init @ Mark a component as inactive. <>= procedure :: deactivate_component => process_metadata_deactivate_component <>= subroutine process_metadata_deactivate_component (meta, i) class(process_metadata_t), intent(inout) :: meta integer, intent(in) :: i call msg_message ("Process component '" & // char (meta%component_id(i)) // "': matrix element vanishes") meta%active(i) = .false. end subroutine process_metadata_deactivate_component @ %def process_metadata_deactivate_component @ \subsection{Phase-space configuration} A process can have a number of independent phase-space configuration entries, depending on the process definition and evaluation algorithm. Each entry holds various configuration-parameter data and the actual [[phs_config_t]] record, which can vary in concrete type. <>= public :: process_phs_config_t <>= type :: process_phs_config_t type(phs_parameters_t) :: phs_par type(mapping_defaults_t) :: mapping_defs class(phs_config_t), allocatable :: phs_config contains <> end type process_phs_config_t @ %def process_phs_config_t @ Output, DTIO compatible. <>= procedure :: write => process_phs_config_write procedure :: write_formatted => process_phs_config_write_formatted ! generic :: write (formatted) => write_formatted <>= subroutine process_phs_config_write (phs_config, unit) class(process_phs_config_t), intent(in) :: phs_config integer, intent(in), optional :: unit integer :: u, iostat integer, dimension(:), allocatable :: v_list character(0) :: iomsg u = given_output_unit (unit) allocate (v_list (0)) call phs_config%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg) end subroutine process_phs_config_write @ %def process_phs_config_write @ DTIO standard write. <>= subroutine process_phs_config_write_formatted & (dtv, unit, iotype, v_list, iostat, iomsg) class(process_phs_config_t), intent(in) :: dtv integer, intent(in) :: unit character(*), intent(in) :: iotype integer, dimension(:), intent(in) :: v_list integer, intent(out) :: iostat character(*), intent(inout) :: iomsg associate (phs_config => dtv) write (unit, "(1x, A)") "Phase-space configuration entry:" call phs_config%phs_par%write (unit) call phs_config%mapping_defs%write (unit) end associate iostat = 0 end subroutine process_phs_config_write_formatted @ %def process_phs_config_write_formatted @ \subsection{Beam configuration} The object [[data]] holds all details about the initial beam configuration. The allocatable array [[sf]] holds the structure-function configuration blocks. There are [[n_strfun]] entries in the structure-function chain (not counting the initial beam object). We maintain [[n_channel]] independent parameterizations of this chain. If this is greater than zero, we need a multi-channel sampling algorithm, where for each point one channel is selected to generate kinematics. The number of parameters that are required for generating a structure-function chain is [[n_sfpar]]. The flag [[azimuthal_dependence]] tells whether the process setup is symmetric about the beam axis in the c.m.\ system. This implies that there is no transversal beam polarization. The flag [[lab_is_cm_frame]] is obvious. <>= public :: process_beam_config_t <>= type :: process_beam_config_t type(beam_data_t) :: data integer :: n_strfun = 0 integer :: n_channel = 1 integer :: n_sfpar = 0 type(sf_config_t), dimension(:), allocatable :: sf type(sf_channel_t), dimension(:), allocatable :: sf_channel logical :: azimuthal_dependence = .false. logical :: lab_is_cm_frame = .true. character(32) :: md5sum = "" logical :: sf_trace = .false. type(string_t) :: sf_trace_file contains <> end type process_beam_config_t @ %def process_beam_config_t @ Here we write beam data only if they are actually used. The [[verbose]] flag is passed to the beam-data writer. <>= procedure :: write => process_beam_config_write <>= subroutine process_beam_config_write (object, unit, verbose) class(process_beam_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i, c u = given_output_unit (unit) call object%data%write (u, verbose = verbose) if (object%data%initialized) then write (u, "(3x,A,L1)") "Azimuthal dependence = ", & object%azimuthal_dependence write (u, "(3x,A,L1)") "Lab frame is c.m. frame = ", & object%lab_is_cm_frame if (object%md5sum /= "") then write (u, "(3x,A,A,A)") "MD5 sum (beams/strf) = '", & object%md5sum, "'" end if if (allocated (object%sf)) then do i = 1, size (object%sf) call object%sf(i)%write (u) end do if (any_sf_channel_has_mapping (object%sf_channel)) then write (u, "(1x,A,L1)") "Structure-function mappings per channel:" do c = 1, object%n_channel write (u, "(3x,I0,':')", advance="no") c call object%sf_channel(c)%write (u) end do end if end if end if end subroutine process_beam_config_write @ %def process_beam_config_write @ The beam data have a finalizer. We assume that there is none for the structure-function data. <>= procedure :: final => process_beam_config_final <>= subroutine process_beam_config_final (object) class(process_beam_config_t), intent(inout) :: object call object%data%final () end subroutine process_beam_config_final @ %def process_beam_config_final @ Initialize the beam setup with a given beam structure object. <>= procedure :: init_beam_structure => process_beam_config_init_beam_structure <>= subroutine process_beam_config_init_beam_structure & (beam_config, beam_structure, sqrts, model, decay_rest_frame) class(process_beam_config_t), intent(out) :: beam_config type(beam_structure_t), intent(in) :: beam_structure logical, intent(in), optional :: decay_rest_frame real(default), intent(in) :: sqrts class(model_data_t), intent(in), target :: model call beam_config%data%init_structure (beam_structure, & sqrts, model, decay_rest_frame) beam_config%lab_is_cm_frame = beam_config%data%cm_frame () end subroutine process_beam_config_init_beam_structure @ %def process_beam_config_init_beam_structure @ Initialize the beam setup for a scattering process with specified flavor combination, other properties taken from the beam structure object (if any). <>= procedure :: init_scattering => process_beam_config_init_scattering <>= subroutine process_beam_config_init_scattering & (beam_config, flv_in, sqrts, beam_structure) class(process_beam_config_t), intent(out) :: beam_config type(flavor_t), dimension(2), intent(in) :: flv_in real(default), intent(in) :: sqrts type(beam_structure_t), intent(in), optional :: beam_structure if (present (beam_structure)) then if (beam_structure%polarized ()) then call beam_config%data%init_sqrts (sqrts, flv_in, & beam_structure%get_smatrix (), beam_structure%get_pol_f ()) else call beam_config%data%init_sqrts (sqrts, flv_in) end if else call beam_config%data%init_sqrts (sqrts, flv_in) end if end subroutine process_beam_config_init_scattering @ %def process_beam_config_init_scattering @ Initialize the beam setup for a decay process with specified flavor, other properties taken from the beam structure object (if present). For a cascade decay, we set [[rest_frame]] to false, indicating a event-wise varying momentum. The beam data itself are initialized for the particle at rest. <>= procedure :: init_decay => process_beam_config_init_decay <>= subroutine process_beam_config_init_decay & (beam_config, flv_in, rest_frame, beam_structure) class(process_beam_config_t), intent(out) :: beam_config type(flavor_t), dimension(1), intent(in) :: flv_in logical, intent(in), optional :: rest_frame type(beam_structure_t), intent(in), optional :: beam_structure if (present (beam_structure)) then if (beam_structure%polarized ()) then call beam_config%data%init_decay (flv_in, & beam_structure%get_smatrix (), beam_structure%get_pol_f (), & rest_frame = rest_frame) else call beam_config%data%init_decay (flv_in, rest_frame = rest_frame) end if else call beam_config%data%init_decay (flv_in, & rest_frame = rest_frame) end if beam_config%lab_is_cm_frame = beam_config%data%cm_frame () end subroutine process_beam_config_init_decay @ %def process_beam_config_init_decay @ Print an informative message. <>= procedure :: startup_message => process_beam_config_startup_message <>= subroutine process_beam_config_startup_message & (beam_config, unit, beam_structure) class(process_beam_config_t), intent(in) :: beam_config integer, intent(in), optional :: unit type(beam_structure_t), intent(in), optional :: beam_structure integer :: u u = free_unit () open (u, status="scratch", action="readwrite") if (present (beam_structure)) then call beam_structure%write (u) end if call beam_config%data%write (u) rewind (u) do read (u, "(1x,A)", end=1) msg_buffer call msg_message () end do 1 continue close (u) end subroutine process_beam_config_startup_message @ %def process_beam_config_startup_message @ Allocate the structure-function array. <>= procedure :: init_sf_chain => process_beam_config_init_sf_chain <>= subroutine process_beam_config_init_sf_chain & (beam_config, sf_config, sf_trace_file) class(process_beam_config_t), intent(inout) :: beam_config type(sf_config_t), dimension(:), intent(in) :: sf_config type(string_t), intent(in), optional :: sf_trace_file integer :: i beam_config%n_strfun = size (sf_config) allocate (beam_config%sf (beam_config%n_strfun)) do i = 1, beam_config%n_strfun associate (sf => sf_config(i)) call beam_config%sf(i)%init (sf%i, sf%data) if (.not. sf%data%is_generator ()) then beam_config%n_sfpar = beam_config%n_sfpar + sf%data%get_n_par () end if end associate end do if (present (sf_trace_file)) then beam_config%sf_trace = .true. beam_config%sf_trace_file = sf_trace_file end if end subroutine process_beam_config_init_sf_chain @ %def process_beam_config_init_sf_chain @ Allocate the structure-function mapping channel array, given the requested number of channels. <>= procedure :: allocate_sf_channels => process_beam_config_allocate_sf_channels <>= subroutine process_beam_config_allocate_sf_channels (beam_config, n_channel) class(process_beam_config_t), intent(inout) :: beam_config integer, intent(in) :: n_channel beam_config%n_channel = n_channel call allocate_sf_channels (beam_config%sf_channel, & n_channel = n_channel, & n_strfun = beam_config%n_strfun) end subroutine process_beam_config_allocate_sf_channels @ %def process_beam_config_allocate_sf_channels @ Set a structure-function mapping channel for an array of structure-function entries, for a single channel. (The default is no mapping.) <>= procedure :: set_sf_channel => process_beam_config_set_sf_channel <>= subroutine process_beam_config_set_sf_channel (beam_config, c, sf_channel) class(process_beam_config_t), intent(inout) :: beam_config integer, intent(in) :: c type(sf_channel_t), intent(in) :: sf_channel beam_config%sf_channel(c) = sf_channel end subroutine process_beam_config_set_sf_channel @ %def process_beam_config_set_sf_channel @ Print an informative startup message. <>= procedure :: sf_startup_message => process_beam_config_sf_startup_message <>= subroutine process_beam_config_sf_startup_message & (beam_config, sf_string, unit) class(process_beam_config_t), intent(in) :: beam_config type(string_t), intent(in) :: sf_string integer, intent(in), optional :: unit if (beam_config%n_strfun > 0) then call msg_message ("Beam structure: " // char (sf_string), unit = unit) write (msg_buffer, "(A,3(1x,I0,1x,A))") & "Beam structure:", & beam_config%n_channel, "channels,", & beam_config%n_sfpar, "dimensions" call msg_message (unit = unit) if (beam_config%sf_trace) then call msg_message ("Beam structure: tracing & &values in '" // char (beam_config%sf_trace_file) // "'") end if end if end subroutine process_beam_config_sf_startup_message @ %def process_beam_config_startup_message @ Return the PDF set currently in use, if any. This should be unique, so we scan the structure functions until we get a nonzero number. (This implies that if the PDF set is not unique (e.g., proton and photon structure used together), this does not work correctly.) <>= procedure :: get_pdf_set => process_beam_config_get_pdf_set <>= function process_beam_config_get_pdf_set (beam_config) result (pdf_set) class(process_beam_config_t), intent(in) :: beam_config integer :: pdf_set integer :: i pdf_set = 0 if (allocated (beam_config%sf)) then do i = 1, size (beam_config%sf) pdf_set = beam_config%sf(i)%get_pdf_set () if (pdf_set /= 0) return end do end if end function process_beam_config_get_pdf_set @ %def process_beam_config_get_pdf_set @ Return the beam file. <>= procedure :: get_beam_file => process_beam_config_get_beam_file <>= function process_beam_config_get_beam_file (beam_config) result (file) class(process_beam_config_t), intent(in) :: beam_config type(string_t) :: file integer :: i file = "" if (allocated (beam_config%sf)) then do i = 1, size (beam_config%sf) file = beam_config%sf(i)%get_beam_file () if (file /= "") return end do end if end function process_beam_config_get_beam_file @ %def process_beam_config_get_beam_file @ Compute the MD5 sum for the complete beam setup. We rely on the default output of [[write]] to contain all relevant data. This is done only once, when the MD5 sum is still empty. <>= procedure :: compute_md5sum => process_beam_config_compute_md5sum <>= subroutine process_beam_config_compute_md5sum (beam_config) class(process_beam_config_t), intent(inout) :: beam_config integer :: u if (beam_config%md5sum == "") then u = free_unit () open (u, status = "scratch", action = "readwrite") call beam_config%write (u, verbose=.true.) rewind (u) beam_config%md5sum = md5sum (u) close (u) end if end subroutine process_beam_config_compute_md5sum @ %def process_beam_config_compute_md5sum @ <>= procedure :: get_md5sum => process_beam_config_get_md5sum <>= pure function process_beam_config_get_md5sum (beam_config) result (md5) character(32) :: md5 class(process_beam_config_t), intent(in) :: beam_config md5 = beam_config%md5sum end function process_beam_config_get_md5sum @ %def process_beam_config_get_md5sum @ <>= procedure :: has_structure_function => process_beam_config_has_structure_function <>= pure function process_beam_config_has_structure_function (beam_config) result (has_sf) logical :: has_sf class(process_beam_config_t), intent(in) :: beam_config has_sf = beam_config%n_strfun > 0 end function process_beam_config_has_structure_function @ %def process_beam_config_has_structure_function @ \subsection{Process components} A process component is an individual contribution to a process (scattering or decay) which needs not be physical. The sum over all components should be physical. The [[index]] indentifies this component within its parent process. The actual process component is stored in the [[core]] subobject. We use a polymorphic subobject instead of an extension of [[process_component_t]], because the individual entries in the array of process components can have different types. In short, [[process_component_t]] is a wrapper for the actual process variants. If the [[active]] flag is false, we should skip this component. This happens if the associated process has vanishing matrix element. The index array [[i_term]] points to the individual terms generated by this component. The indices refer to the parent process. The index [[i_mci]] is the index of the MC integrator and parameter set which are associated to this process component. <>= public :: process_component_t <>= type :: process_component_t type(process_component_def_t), pointer :: config => null () integer :: index = 0 logical :: active = .false. integer, dimension(:), allocatable :: i_term integer :: i_mci = 0 class(phs_config_t), allocatable :: phs_config character(32) :: md5sum_phs = "" integer :: component_type = COMP_DEFAULT contains <> end type process_component_t @ %def process_component_t @ Finalizer. The MCI template may (potentially) need a finalizer. The process configuration finalizer may include closing an open scratch file. <>= procedure :: final => process_component_final <>= subroutine process_component_final (object) class(process_component_t), intent(inout) :: object if (allocated (object%phs_config)) then call object%phs_config%final () end if end subroutine process_component_final @ %def process_component_final @ The meaning of [[verbose]] depends on the process variant. <>= procedure :: write => process_component_write <>= subroutine process_component_write (object, unit) class(process_component_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (associated (object%config)) then write (u, "(1x,A,I0)") "Component #", object%index call object%config%write (u) if (object%md5sum_phs /= "") then write (u, "(3x,A,A,A)") "MD5 sum (phs) = '", & object%md5sum_phs, "'" end if else write (u, "(1x,A)") "Process component: [not allocated]" end if if (.not. object%active) then write (u, "(1x,A)") "[Inactive]" return end if write (u, "(1x,A)") "Referenced data:" if (allocated (object%i_term)) then write (u, "(3x,A,999(1x,I0))") "Terms =", & object%i_term else write (u, "(3x,A)") "Terms = [undefined]" end if if (object%i_mci /= 0) then write (u, "(3x,A,I0)") "MC dataset = ", object%i_mci else write (u, "(3x,A)") "MC dataset = [undefined]" end if if (allocated (object%phs_config)) then call object%phs_config%write (u) end if end subroutine process_component_write @ %def process_component_write @ Initialize the component. <>= procedure :: init => process_component_init <>= subroutine process_component_init (component, & i_component, env, meta, config, & active, & phs_config_template) class(process_component_t), intent(out) :: component integer, intent(in) :: i_component type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config logical, intent(in) :: active class(phs_config_t), intent(in), allocatable :: phs_config_template type(process_constants_t) :: data component%index = i_component component%config => & config%process_def%get_component_def_ptr (i_component) component%active = active if (component%active) then allocate (component%phs_config, source = phs_config_template) call env%fill_process_constants (meta%id, i_component, data) call component%phs_config%init (data, config%model) end if end subroutine process_component_init @ %def process_component_init @ <>= procedure :: is_active => process_component_is_active <>= elemental function process_component_is_active (component) result (active) logical :: active class(process_component_t), intent(in) :: component active = component%active end function process_component_is_active @ %def process_component_is_active @ Finalize the phase-space configuration. <>= procedure :: configure_phs => process_component_configure_phs <>= subroutine process_component_configure_phs & (component, sqrts, beam_config, rebuild, & ignore_mismatch, subdir) class(process_component_t), intent(inout) :: component real(default), intent(in) :: sqrts type(process_beam_config_t), intent(in) :: beam_config logical, intent(in), optional :: rebuild logical, intent(in), optional :: ignore_mismatch type(string_t), intent(in), optional :: subdir logical :: no_strfun integer :: nlo_type no_strfun = beam_config%n_strfun == 0 nlo_type = component%config%get_nlo_type () call component%phs_config%configure (sqrts, & azimuthal_dependence = beam_config%azimuthal_dependence, & sqrts_fixed = no_strfun, & cm_frame = beam_config%lab_is_cm_frame .and. no_strfun, & rebuild = rebuild, ignore_mismatch = ignore_mismatch, & nlo_type = nlo_type, & subdir = subdir) end subroutine process_component_configure_phs @ %def process_component_configure_phs @ The process component possesses two MD5 sums: the checksum of the component definition, which should be available when the component is initialized, and the phase-space MD5 sum, which is available after configuration. <>= procedure :: compute_md5sum => process_component_compute_md5sum <>= subroutine process_component_compute_md5sum (component) class(process_component_t), intent(inout) :: component component%md5sum_phs = component%phs_config%get_md5sum () end subroutine process_component_compute_md5sum @ %def process_component_compute_md5sum @ Match phase-space channels with structure-function channels, where applicable. This calls a method of the [[phs_config]] phase-space implementation. <>= procedure :: collect_channels => process_component_collect_channels <>= subroutine process_component_collect_channels (component, coll) class(process_component_t), intent(inout) :: component type(phs_channel_collection_t), intent(inout) :: coll call component%phs_config%collect_channels (coll) end subroutine process_component_collect_channels @ %def process_component_collect_channels @ <>= procedure :: get_config => process_component_get_config <>= function process_component_get_config (component) & result (config) type(process_component_def_t) :: config class(process_component_t), intent(in) :: component config = component%config end function process_component_get_config @ %def process_component_get_config @ <>= procedure :: get_md5sum => process_component_get_md5sum <>= pure function process_component_get_md5sum (component) result (md5) type(string_t) :: md5 class(process_component_t), intent(in) :: component md5 = component%config%get_md5sum () // component%md5sum_phs end function process_component_get_md5sum @ %def process_component_get_md5sum @ Return the number of phase-space parameters. <>= procedure :: get_n_phs_par => process_component_get_n_phs_par <>= function process_component_get_n_phs_par (component) result (n_par) class(process_component_t), intent(in) :: component integer :: n_par n_par = component%phs_config%get_n_par () end function process_component_get_n_phs_par @ %def process_component_get_n_phs_par @ <>= procedure :: get_phs_config => process_component_get_phs_config <>= subroutine process_component_get_phs_config (component, phs_config) class(process_component_t), intent(in), target :: component class(phs_config_t), intent(out), pointer :: phs_config phs_config => component%phs_config end subroutine process_component_get_phs_config @ %def process_component_get_phs_config @ <>= procedure :: get_nlo_type => process_component_get_nlo_type <>= elemental function process_component_get_nlo_type (component) result (nlo_type) integer :: nlo_type class(process_component_t), intent(in) :: component nlo_type = component%config%get_nlo_type () end function process_component_get_nlo_type @ %def process_component_get_nlo_type @ <>= procedure :: needs_mci_entry => process_component_needs_mci_entry <>= function process_component_needs_mci_entry (component, combined_integration) result (value) logical :: value class(process_component_t), intent(in) :: component logical, intent(in), optional :: combined_integration value = component%active if (present (combined_integration)) then if (combined_integration) & value = value .and. component%component_type <= COMP_MASTER end if end function process_component_needs_mci_entry @ %def process_component_needs_mci_entry @ <>= procedure :: can_be_integrated => process_component_can_be_integrated <>= elemental function process_component_can_be_integrated (component) result (active) logical :: active class(process_component_t), intent(in) :: component active = component%config%can_be_integrated () end function process_component_can_be_integrated @ %def process_component_can_be_integrated @ \subsection{Process terms} For straightforward tree-level calculations, each process component corresponds to a unique elementary interaction. However, in the case of NLO calculations with subtraction terms, a process component may split into several separate contributions to the scattering, which are qualified by interactions with distinct kinematics and particle content. We represent their configuration as [[process_term_t]] objects, the actual instances will be introduced below as [[term_instance_t]]. In any case, the process term contains an elementary interaction with a definite quantum-number and momentum content. The index [[i_term_global]] identifies the term relative to the process. The index [[i_component]] identifies the process component which generates this term, relative to the parent process. The index [[i_term]] identifies the term relative to the process component (not the process). The [[data]] subobject holds all process constants. The number of allowed flavor/helicity/color combinations is stored as [[n_allowed]]. This is the total number of independent entries in the density matrix. For each combination, the index of the flavor, helicity, and color state is stored in the arrays [[flv]], [[hel]], and [[col]], respectively. The flag [[rearrange]] is true if we need to rearrange the particles of the hard interaction, to obtain the effective parton state. The interaction [[int]] holds the quantum state for the (resolved) hard interaction, the parent-child relations of the particles, and their momenta. The momenta are not filled yet; this is postponed to copies of [[int]] which go into the process instances. If recombination is in effect, we should allocate [[int_eff]] to describe the rearranged partonic state. This type is public only for use in a unit test. <>= public :: process_term_t <>= type :: process_term_t integer :: i_term_global = 0 integer :: i_component = 0 integer :: i_term = 0 integer :: i_sub = 0 integer :: i_core = 0 integer :: n_allowed = 0 type(process_constants_t) :: data real(default) :: alpha_s = 0 integer, dimension(:), allocatable :: flv, hel, col integer :: n_sub, n_sub_color, n_sub_spin type(interaction_t) :: int type(interaction_t), pointer :: int_eff => null () contains <> end type process_term_t @ %def process_term_t @ For the output, we skip the process constants and the tables of allowed quantum numbers. Those can also be read off from the interaction object. <>= procedure :: write => process_term_write <>= subroutine process_term_write (term, unit) class(process_term_t), intent(in) :: term integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A,I0)") "Term #", term%i_term_global write (u, "(3x,A,I0)") "Process component index = ", & term%i_component write (u, "(3x,A,I0)") "Term index w.r.t. component = ", & term%i_term call write_separator (u) write (u, "(1x,A)") "Hard interaction:" call write_separator (u) call term%int%basic_write (u) end subroutine process_term_write @ %def process_term_write @ Write an account of all quantum number states and their current status. <>= procedure :: write_state_summary => process_term_write_state_summary <>= subroutine process_term_write_state_summary (term, core, unit) class(process_term_t), intent(in) :: term class(prc_core_t), intent(in) :: core integer, intent(in), optional :: unit integer :: u, i, f, h, c type(state_iterator_t) :: it character :: sgn u = given_output_unit (unit) write (u, "(1x,A,I0)") "Term #", term%i_term_global call it%init (term%int%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () f = term%flv(i) h = term%hel(i) if (allocated (term%col)) then c = term%col(i) else c = 1 end if if (core%is_allowed (term%i_term, f, h, c)) then sgn = "+" else sgn = " " end if write (u, "(1x,A1,1x,I0,2x)", advance="no") sgn, i call quantum_numbers_write (it%get_quantum_numbers (), u) write (u, *) call it%advance () end do end subroutine process_term_write_state_summary @ %def process_term_write_state_summary @ Finalizer: the [[int]] and potentially [[int_eff]] components have a finalizer that we must call. <>= procedure :: final => process_term_final <>= subroutine process_term_final (term) class(process_term_t), intent(inout) :: term call term%int%final () end subroutine process_term_final @ %def process_term_final @ Initialize the term. We copy the process constants from the [[core]] object and set up the [[int]] hard interaction accordingly. The [[alpha_s]] value is useful for writing external event records. This is the constant value which may be overridden by a event-specific running value. If the model does not contain the strong coupling, the value is zero. The [[rearrange]] part is commented out; this or something equivalent could become relevant for NLO algorithms. <>= procedure :: init => process_term_init <>= subroutine process_term_init & (term, i_term_global, i_component, i_term, core, model, & nlo_type, use_beam_pol, subtraction_method, & has_pdfs, n_emitters) class(process_term_t), intent(inout), target :: term integer, intent(in) :: i_term_global integer, intent(in) :: i_component integer, intent(in) :: i_term class(prc_core_t), intent(inout) :: core class(model_data_t), intent(in), target :: model integer, intent(in), optional :: nlo_type logical, intent(in), optional :: use_beam_pol type(string_t), intent(in), optional :: subtraction_method logical, intent(in), optional :: has_pdfs integer, intent(in), optional :: n_emitters class(modelpar_data_t), pointer :: alpha_s_ptr logical :: use_internal_color term%i_term_global = i_term_global term%i_component = i_component term%i_term = i_term call core%get_constants (term%data, i_term) alpha_s_ptr => model%get_par_data_ptr (var_str ("alphas")) if (associated (alpha_s_ptr)) then term%alpha_s = alpha_s_ptr%get_real () else term%alpha_s = -1 end if use_internal_color = .false. if (present (subtraction_method)) & use_internal_color = (char (subtraction_method) == 'omega') & .or. (char (subtraction_method) == 'threshold') call term%setup_interaction (core, model, nlo_type = nlo_type, & pol_beams = use_beam_pol, use_internal_color = use_internal_color, & has_pdfs = has_pdfs, n_emitters = n_emitters) end subroutine process_term_init @ %def process_term_init @ We fetch the process constants which determine the quantum numbers and use those to create the interaction. The interaction contains incoming and outgoing particles, no virtuals. The incoming particles are parents of the outgoing ones. Keeping previous \whizard\ conventions, we invert the color assignment (but not flavor or helicity) for the incoming particles. When the color-flow square matrix is evaluated, this inversion is done again, so in the color-flow sequence we get the color assignments of the matrix element. \textbf{Why are these four subtraction entries for structure-function aware interactions?} Taking the soft or collinear limit of the real-emission matrix element, the behavior of the parton energy fractions has to be taken into account. In the pure real case, $x_\oplus$ and $x_\ominus$ are given by \begin{equation*} x_\oplus = \frac{\bar{x}_\oplus}{\sqrt{1-\xi}} \sqrt{\frac{2 - \xi(1-y)}{2 - \xi(1+y)}}, \quad x_\ominus = \frac{\bar{x}_\ominus}{\sqrt{1-\xi}} \sqrt{\frac{2 - \xi(1+y)}{2 - \xi(1-y)}}. \end{equation*} In the soft limit, $\xi \to 0$, this yields $x_\oplus = \bar{x}_\oplus$ and $x_\ominus = \bar{x}_\ominus$. In the collinear limit, $y \to 1$, it is $x_\oplus = \bar{x}_\oplus / (1 - \xi)$ and $x_\ominus = \bar{x}_\ominus$. Likewise, in the anti-collinear limit $y \-o -1$, the inverse relation holds. We therefore have to distinguish four cases with the PDF assignments $f(x_\oplus) \cdot f(x_\ominus)$, $f(\bar{x}_\oplus) \cdot f(\bar{x}_\ominus)$, $f\left(\bar{x}_\oplus / (1-\xi)\right) \cdot f(\bar{x}_\ominus)$ and $f(\bar{x}_\oplus) \cdot f\left(\bar{x}_\ominus / (1-\xi)\right)$. The [[n_emitters]] optional argument is provided by the caller if this term requires spin-correlated matrix elements, and thus involves additional subtractions. <>= procedure :: setup_interaction => process_term_setup_interaction <>= subroutine process_term_setup_interaction (term, core, model, & nlo_type, pol_beams, has_pdfs, use_internal_color, n_emitters) class(process_term_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core class(model_data_t), intent(in), target :: model logical, intent(in), optional :: pol_beams logical, intent(in), optional :: has_pdfs integer, intent(in), optional :: nlo_type logical, intent(in), optional :: use_internal_color integer, intent(in), optional :: n_emitters integer :: n, n_tot type(flavor_t), dimension(:), allocatable :: flv type(color_t), dimension(:), allocatable :: col type(helicity_t), dimension(:), allocatable :: hel type(quantum_numbers_t), dimension(:), allocatable :: qn logical :: is_pol, use_color integer :: nlo_t, n_sub is_pol = .false.; if (present (pol_beams)) is_pol = pol_beams nlo_t = BORN; if (present (nlo_type)) nlo_t = nlo_type n_tot = term%data%n_in + term%data%n_out call count_number_of_states () term%n_allowed = n call compute_n_sub (n_emitters, has_pdfs) call fill_quantum_numbers () call term%int%basic_init & (term%data%n_in, 0, term%data%n_out, set_relations = .true.) select type (core) class is (prc_blha_t) call setup_states_blha_olp () type is (prc_threshold_t) call setup_states_threshold () class is (prc_external_t) call setup_states_other_prc_external () class default call setup_states_omega () end select call term%int%freeze () contains subroutine count_number_of_states () integer :: f, h, c n = 0 select type (core) class is (prc_external_t) do f = 1, term%data%n_flv do h = 1, term%data%n_hel do c = 1, term%data%n_col n = n + 1 end do end do end do class default !!! Omega and all test cores do f = 1, term%data%n_flv do h = 1, term%data%n_hel do c = 1, term%data%n_col if (core%is_allowed (term%i_term, f, h, c)) n = n + 1 end do end do end do end select end subroutine count_number_of_states subroutine compute_n_sub (n_emitters, has_pdfs) integer, intent(in), optional :: n_emitters logical, intent(in), optional :: has_pdfs logical :: can_have_sub integer :: n_sub_color, n_sub_spin use_color = .false.; if (present (use_internal_color)) & use_color = use_internal_color can_have_sub = nlo_t == NLO_VIRTUAL .or. & (nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. & nlo_t == NLO_MISMATCH n_sub_color = 0; n_sub_spin = 0 if (can_have_sub) then if (.not. use_color) n_sub_color = n_tot * (n_tot - 1) / 2 if (nlo_t == NLO_REAL) then if (present (n_emitters)) then n_sub_spin = 16 * n_emitters end if end if end if n_sub = n_sub_color + n_sub_spin !!! For the virtual subtraction we also need the finite virtual contribution !!! corresponding to the $\epsilon^0$-pole if (nlo_t == NLO_VIRTUAL) n_sub = n_sub + 1 if (present (has_pdfs)) then if (has_pdfs & .and. ((nlo_t == NLO_REAL .and. can_have_sub) & .or. nlo_t == NLO_DGLAP)) then n_sub = n_sub + n_beam_structure_int end if end if term%n_sub = n_sub term%n_sub_color = n_sub_color term%n_sub_spin = n_sub_spin end subroutine compute_n_sub subroutine fill_quantum_numbers () integer :: nn logical :: can_have_sub select type (core) class is (prc_external_t) can_have_sub = nlo_t == NLO_VIRTUAL .or. & (nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. & nlo_t == NLO_MISMATCH .or. nlo_t == NLO_DGLAP if (can_have_sub) then nn = (n_sub + 1) * n else nn = n end if class default nn = n end select allocate (term%flv (nn), term%col (nn), term%hel (nn)) allocate (flv (n_tot), col (n_tot), hel (n_tot)) allocate (qn (n_tot)) end subroutine fill_quantum_numbers subroutine setup_states_blha_olp () integer :: s, f, c, h, i i = 0 associate (data => term%data) do s = 0, n_sub do f = 1, data%n_flv do h = 1, data%n_hel do c = 1, data%n_col i = i + 1 term%flv(i) = f term%hel(i) = h !!! Dummy-initialization of color term%col(i) = c call flv%init (data%flv_state (:,f), model) call color_init_from_array (col, & data%col_state(:,:,c), data%ghost_flag(:,c)) call col(1:data%n_in)%invert () if (is_pol) then select type (core) type is (prc_openloops_t) call hel%init (data%hel_state (:,h)) call qn%init (flv, hel, col, s) class default call msg_fatal ("Polarized beams only supported by OpenLoops") end select else call qn%init (flv, col, s) end if call qn%tag_hard_process () call term%int%add_state (qn) end do end do end do end do end associate end subroutine setup_states_blha_olp subroutine setup_states_threshold () integer :: s, f, c, h, i i = 0 n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1 associate (data => term%data) do s = 0, n_sub do f = 1, term%data%n_flv do h = 1, data%n_hel do c = 1, data%n_col i = i + 1 term%flv(i) = f term%hel(i) = h !!! Dummy-initialization of color term%col(i) = 1 call flv%init (term%data%flv_state (:,f), model) if (is_pol) then call hel%init (data%hel_state (:,h)) call qn%init (flv, hel, s) else call qn%init (flv, s) end if call qn%tag_hard_process () call term%int%add_state (qn) end do end do end do end do end associate end subroutine setup_states_threshold subroutine setup_states_other_prc_external () integer :: s, f, i, c, h if (is_pol) & call msg_fatal ("Polarized beams only supported by OpenLoops") i = 0 !!! n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1 associate (data => term%data) do s = 0, n_sub do f = 1, data%n_flv do h = 1, data%n_hel do c = 1, data%n_col i = i + 1 term%flv(i) = f term%hel(i) = h !!! Dummy-initialization of color term%col(i) = c call flv%init (data%flv_state (:,f), model) call color_init_from_array (col, & data%col_state(:,:,c), data%ghost_flag(:,c)) call col(1:data%n_in)%invert () call qn%init (flv, col, s) call qn%tag_hard_process () call term%int%add_state (qn) end do end do end do end do end associate end subroutine setup_states_other_prc_external subroutine setup_states_omega () integer :: f, h, c, i i = 0 associate (data => term%data) do f = 1, data%n_flv do h = 1, data%n_hel do c = 1, data%n_col if (core%is_allowed (term%i_term, f, h, c)) then i = i + 1 term%flv(i) = f term%hel(i) = h term%col(i) = c call flv%init (data%flv_state(:,f), model) call color_init_from_array (col, & data%col_state(:,:,c), & data%ghost_flag(:,c)) call col(:data%n_in)%invert () call hel%init (data%hel_state(:,h)) call qn%init (flv, col, hel) call qn%tag_hard_process () call term%int%add_state (qn) end if end do end do end do end associate end subroutine setup_states_omega end subroutine process_term_setup_interaction @ %def process_term_setup_interaction @ <>= procedure :: get_process_constants => process_term_get_process_constants <>= subroutine process_term_get_process_constants & (term, prc_constants) class(process_term_t), intent(inout) :: term type(process_constants_t), intent(out) :: prc_constants prc_constants = term%data end subroutine process_term_get_process_constants @ %def process_term_get_process_constants @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process call statistics} Very simple object for statistics. Could be moved to a more basic chapter. <<[[process_counter.f90]]>>= <> module process_counter use io_units <> <> <> <> contains <> end module process_counter @ %def process_counter @ This object can record process calls, categorized by evaluation status. It is a part of the [[mci_entry]] component below. <>= public :: process_counter_t <>= type :: process_counter_t integer :: total = 0 integer :: failed_kinematics = 0 integer :: failed_cuts = 0 integer :: has_passed = 0 integer :: evaluated = 0 integer :: complete = 0 contains <> end type process_counter_t @ %def process_counter_t @ Here are the corresponding numeric codes: <>= integer, parameter, public :: STAT_UNDEFINED = 0 integer, parameter, public :: STAT_INITIAL = 1 integer, parameter, public :: STAT_ACTIVATED = 2 integer, parameter, public :: STAT_BEAM_MOMENTA = 3 integer, parameter, public :: STAT_FAILED_KINEMATICS = 4 integer, parameter, public :: STAT_SEED_KINEMATICS = 5 integer, parameter, public :: STAT_HARD_KINEMATICS = 6 integer, parameter, public :: STAT_EFF_KINEMATICS = 7 integer, parameter, public :: STAT_FAILED_CUTS = 8 integer, parameter, public :: STAT_PASSED_CUTS = 9 integer, parameter, public :: STAT_EVALUATED_TRACE = 10 integer, parameter, public :: STAT_EVENT_COMPLETE = 11 @ %def STAT_UNDEFINED STAT_INITIAL STAT_ACTIVATED @ %def STAT_BEAM_MOMENTA STAT_FAILED_KINEMATICS @ %def STAT_SEED_KINEMATICS STAT_HARD_KINEMATICS STAT_EFF_KINEMATICS @ %def STAT_EVALUATED_TRACE STAT_EVENT_COMPLETE @ Output. <>= procedure :: write => process_counter_write <>= subroutine process_counter_write (object, unit) class(process_counter_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (object%total > 0) then write (u, "(1x,A)") "Call statistics (current run):" write (u, "(3x,A,I0)") "total = ", object%total write (u, "(3x,A,I0)") "failed kin. = ", object%failed_kinematics write (u, "(3x,A,I0)") "failed cuts = ", object%failed_cuts write (u, "(3x,A,I0)") "passed cuts = ", object%has_passed write (u, "(3x,A,I0)") "evaluated = ", object%evaluated else write (u, "(1x,A)") "Call statistics (current run): [no calls]" end if end subroutine process_counter_write @ %def process_counter_write @ Reset. Just enforce default initialization. <>= procedure :: reset => process_counter_reset <>= subroutine process_counter_reset (counter) class(process_counter_t), intent(out) :: counter counter%total = 0 counter%failed_kinematics = 0 counter%failed_cuts = 0 counter%has_passed = 0 counter%evaluated = 0 counter%complete = 0 end subroutine process_counter_reset @ %def process_counter_reset @ We record an event according to the lowest status code greater or equal to the actual status. This is actually done by the process instance; the process object just copies the instance counter. <>= procedure :: record => process_counter_record <>= subroutine process_counter_record (counter, status) class(process_counter_t), intent(inout) :: counter integer, intent(in) :: status if (status <= STAT_FAILED_KINEMATICS) then counter%failed_kinematics = counter%failed_kinematics + 1 else if (status <= STAT_FAILED_CUTS) then counter%failed_cuts = counter%failed_cuts + 1 else if (status <= STAT_PASSED_CUTS) then counter%has_passed = counter%has_passed + 1 else counter%evaluated = counter%evaluated + 1 end if counter%total = counter%total + 1 end subroutine process_counter_record @ %def process_counter_record @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Multi-channel integration} <<[[process_mci.f90]]>>= <> module process_mci <> <> use io_units use diagnostics use physics_defs use md5 use cputime use rng_base use mci_base use variables use integration_results use process_libraries use phs_base use process_counter use process_config <> <> <> <> contains <> end module process_mci @ %def process_mci \subsection{Process MCI entry} The [[process_mci_entry_t]] block contains, for each process component that is integrated independently, the configuration data for its MC input parameters. Each input parameter set is handled by a [[mci_t]] integrator. The MC input parameter set is broken down into the parameters required by the structure-function chain and the parameters required by the phase space of the elementary process. The MD5 sum collects all information about the associated processes that may affect the integration. It does not contain the MCI object itself or integration results. MC integration is organized in passes. Each pass may consist of several iterations, and for each iteration there is a number of calls. We store explicitly the values that apply to the current pass. Previous values are archived in the [[results]] object. The [[counter]] receives the counter statistics from the associated process instance, for diagnostics. The [[results]] object records results, broken down in passes and iterations. <>= public :: process_mci_entry_t <>= type :: process_mci_entry_t integer :: i_mci = 0 integer, dimension(:), allocatable :: i_component integer :: process_type = PRC_UNKNOWN integer :: n_par = 0 integer :: n_par_sf = 0 integer :: n_par_phs = 0 character(32) :: md5sum = "" integer :: pass = 0 integer :: n_it = 0 integer :: n_calls = 0 logical :: activate_timer = .false. real(default) :: error_threshold = 0 class(mci_t), allocatable :: mci type(process_counter_t) :: counter type(integration_results_t) :: results logical :: negative_weights logical :: combined_integration = .false. integer :: real_partition_type = REAL_FULL integer :: associated_real_component = 0 contains <> end type process_mci_entry_t @ %def process_mci_entry_t @ Finalizer for the [[mci]] component. <>= procedure :: final => process_mci_entry_final <>= subroutine process_mci_entry_final (object) class(process_mci_entry_t), intent(inout) :: object if (allocated (object%mci)) call object%mci%final () end subroutine process_mci_entry_final @ %def process_mci_entry_final @ Output. Write pass/iteration information only if set (the pass index is nonzero). Write the MCI block only if it exists (for some self-tests it does not). Write results only if there are any. <>= procedure :: write => process_mci_entry_write <>= subroutine process_mci_entry_write (object, unit, pacify) class(process_mci_entry_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u u = given_output_unit (unit) write (u, "(3x,A,I0)") "Associated components = ", object%i_component write (u, "(3x,A,I0)") "MC input parameters = ", object%n_par write (u, "(3x,A,I0)") "MC parameters (SF) = ", object%n_par_sf write (u, "(3x,A,I0)") "MC parameters (PHS) = ", object%n_par_phs if (object%pass > 0) then write (u, "(3x,A,I0)") "Current pass = ", object%pass write (u, "(3x,A,I0)") "Number of iterations = ", object%n_it write (u, "(3x,A,I0)") "Number of calls = ", object%n_calls end if if (object%md5sum /= "") then write (u, "(3x,A,A,A)") "MD5 sum (components) = '", object%md5sum, "'" end if if (allocated (object%mci)) then call object%mci%write (u) end if call object%counter%write (u) if (object%results%exist ()) then call object%results%write (u, suppress = pacify) call object%results%write_chain_weights (u) end if end subroutine process_mci_entry_write @ %def process_mci_entry_write @ Configure the MCI entry. This is intent(inout) since some specific settings may be done before this. The actual [[mci_t]] object is an instance of the [[mci_template]] argument, which determines the concrete types. In a unit-test context, the [[mci_template]] argument may be unallocated. We obtain the number of channels and the number of parameters, separately for the structure-function chain and for the associated process component. We assume that the phase-space object has already been configured. We assume that there is only one process component directly associated with a MCI entry. <>= procedure :: configure => process_mci_entry_configure <>= subroutine process_mci_entry_configure (mci_entry, mci_template, & process_type, i_mci, i_component, component, & n_sfpar, rng_factory) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_t), intent(in), allocatable :: mci_template integer, intent(in) :: process_type integer, intent(in) :: i_mci integer, intent(in) :: i_component type(process_component_t), intent(in), target :: component integer, intent(in) :: n_sfpar class(rng_factory_t), intent(inout) :: rng_factory class(rng_t), allocatable :: rng associate (phs_config => component%phs_config) mci_entry%i_mci = i_mci call mci_entry%create_component_list (i_component, component%get_config ()) mci_entry%n_par_sf = n_sfpar mci_entry%n_par_phs = phs_config%get_n_par () mci_entry%n_par = mci_entry%n_par_sf + mci_entry%n_par_phs mci_entry%process_type = process_type if (allocated (mci_template)) then allocate (mci_entry%mci, source = mci_template) call mci_entry%mci%record_index (mci_entry%i_mci) call mci_entry%mci%set_dimensions & (mci_entry%n_par, phs_config%get_n_channel ()) call mci_entry%mci%declare_flat_dimensions & (phs_config%get_flat_dimensions ()) if (phs_config%provides_equivalences) then call mci_entry%mci%declare_equivalences & (phs_config%channel, mci_entry%n_par_sf) end if if (phs_config%provides_chains) then call mci_entry%mci%declare_chains (phs_config%chain) end if call rng_factory%make (rng) call mci_entry%mci%import_rng (rng) end if call mci_entry%results%init (process_type) end associate end subroutine process_mci_entry_configure @ %def process_mci_entry_configure @ <>= integer, parameter, public :: REAL_FULL = 0 integer, parameter, public :: REAL_SINGULAR = 1 integer, parameter, public :: REAL_FINITE = 2 @ <>= procedure :: create_component_list => & process_mci_entry_create_component_list <>= subroutine process_mci_entry_create_component_list (mci_entry, & i_component, component_config) class (process_mci_entry_t), intent(inout) :: mci_entry integer, intent(in) :: i_component type(process_component_def_t), intent(in) :: component_config integer, dimension(:), allocatable :: i_list integer :: n integer, save :: i_rfin_offset = 0 call msg_debug (D_PROCESS_INTEGRATION, "process_mci_entry_create_component_list") if (mci_entry%combined_integration) then n = get_n_components (mci_entry%real_partition_type) allocate (i_list (n)) call msg_debug (D_PROCESS_INTEGRATION, & "mci_entry%real_partition_type", mci_entry%real_partition_type) select case (mci_entry%real_partition_type) case (REAL_FULL) i_list = component_config%get_association_list () allocate (mci_entry%i_component (size (i_list))) mci_entry%i_component = i_list case (REAL_SINGULAR) i_list = component_config%get_association_list (ASSOCIATED_REAL_FIN) allocate (mci_entry%i_component (size(i_list))) mci_entry%i_component = i_list case (REAL_FINITE) allocate (mci_entry%i_component (1)) mci_entry%i_component(1) = & component_config%get_associated_real_fin () + i_rfin_offset i_rfin_offset = i_rfin_offset + 1 end select else allocate (mci_entry%i_component (1)) mci_entry%i_component(1) = i_component end if contains function get_n_components (damping_type) result (n_components) integer :: n_components integer, intent(in) :: damping_type select case (damping_type) case (REAL_FULL) n_components = size (component_config%get_association_list ()) case (REAL_SINGULAR) n_components = size (component_config%get_association_list & (ASSOCIATED_REAL_FIN)) end select call msg_debug (D_PROCESS_INTEGRATION, "n_components", n_components) end function get_n_components end subroutine process_mci_entry_create_component_list @ %def process_mci_entry_create_component_list @ <>= procedure :: set_associated_real_component & => process_mci_entry_set_associated_real_component <>= subroutine process_mci_entry_set_associated_real_component (mci_entry, i) class(process_mci_entry_t), intent(inout) :: mci_entry integer, intent(in) :: i mci_entry%associated_real_component = i end subroutine process_mci_entry_set_associated_real_component @ %def process_mci_entry_set_associated_real_component @ Set some additional parameters. <>= procedure :: set_parameters => process_mci_entry_set_parameters <>= subroutine process_mci_entry_set_parameters (mci_entry, var_list) class(process_mci_entry_t), intent(inout) :: mci_entry type(var_list_t), intent(in) :: var_list integer :: integration_results_verbosity real(default) :: error_threshold integration_results_verbosity = & var_list%get_ival (var_str ("integration_results_verbosity")) error_threshold = & var_list%get_rval (var_str ("error_threshold")) mci_entry%activate_timer = & var_list%get_lval (var_str ("?integration_timer")) call mci_entry%results%set_verbosity (integration_results_verbosity) call mci_entry%results%set_error_threshold (error_threshold) end subroutine process_mci_entry_set_parameters @ %def process_mci_entry_set_parameters @ Compute an MD5 sum that summarizes all information that could influence integration results, for the associated process components. We take the process-configuration MD5 sum which represents parameters, cuts, etc., the MD5 sums for the process component definitions and their phase space objects (which should be configured), and the beam configuration MD5 sum. (The QCD setup is included in the process configuration data MD5 sum.) Done only once, when the MD5 sum is still empty. <>= procedure :: compute_md5sum => process_mci_entry_compute_md5sum <>= subroutine process_mci_entry_compute_md5sum (mci_entry, & config, component, beam_config) class(process_mci_entry_t), intent(inout) :: mci_entry type(process_config_data_t), intent(in) :: config type(process_component_t), dimension(:), intent(in) :: component type(process_beam_config_t), intent(in) :: beam_config type(string_t) :: buffer integer :: i if (mci_entry%md5sum == "") then buffer = config%get_md5sum () // beam_config%get_md5sum () do i = 1, size (component) if (component(i)%is_active ()) then buffer = buffer // component(i)%get_md5sum () end if end do mci_entry%md5sum = md5sum (char (buffer)) end if if (allocated (mci_entry%mci)) then call mci_entry%mci%set_md5sum (mci_entry%md5sum) end if end subroutine process_mci_entry_compute_md5sum @ %def process_mci_entry_compute_md5sum @ Test the MCI sampler by calling it a given number of time, discarding the results. The instance should be initialized. The [[mci_entry]] is [[intent(inout)]] because the integrator contains the random-number state. <>= procedure :: sampler_test => process_mci_entry_sampler_test <>= subroutine process_mci_entry_sampler_test (mci_entry, mci_sampler, n_calls) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_sampler_t), intent(inout), target :: mci_sampler integer, intent(in) :: n_calls call mci_entry%mci%sampler_test (mci_sampler, n_calls) end subroutine process_mci_entry_sampler_test @ %def process_mci_entry_sampler_test @ Integrate. The [[integrate]] method counts as an integration pass; the pass count is increased by one. We transfer the pass parameters (number of iterations and number of calls) to the actual integration routine. The [[mci_entry]] is [[intent(inout)]] because the integrator contains the random-number state. Note: The results are written to screen and to logfile. This behavior is hardcoded. <>= procedure :: integrate => process_mci_entry_integrate procedure :: final_integration => process_mci_entry_final_integration <>= subroutine process_mci_entry_integrate (mci_entry, mci_instance, & mci_sampler, n_it, n_calls, & adapt_grids, adapt_weights, final, pacify, & nlo_type) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_instance_t), intent(inout) :: mci_instance class(mci_sampler_t), intent(inout) :: mci_sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: adapt_grids logical, intent(in), optional :: adapt_weights logical, intent(in), optional :: final, pacify integer, intent(in), optional :: nlo_type integer :: u_log u_log = logfile_unit () mci_entry%pass = mci_entry%pass + 1 mci_entry%n_it = n_it mci_entry%n_calls = n_calls if (mci_entry%pass == 1) & call mci_entry%mci%startup_message (n_calls = n_calls) call mci_entry%mci%set_timer (active = mci_entry%activate_timer) call mci_entry%results%display_init (screen = .true., unit = u_log) call mci_entry%results%new_pass () if (present (nlo_type)) then select case (nlo_type) case (NLO_VIRTUAL, NLO_REAL, NLO_MISMATCH, NLO_DGLAP) mci_instance%negative_weights = .true. end select end if call mci_entry%mci%add_pass (adapt_grids, adapt_weights, final) call mci_entry%mci%start_timer () call mci_entry%mci%integrate (mci_instance, mci_sampler, n_it, & n_calls, mci_entry%results, pacify = pacify) call mci_entry%mci%stop_timer () if (signal_is_pending ()) return end subroutine process_mci_entry_integrate subroutine process_mci_entry_final_integration (mci_entry) class(process_mci_entry_t), intent(inout) :: mci_entry call mci_entry%results%display_final () call mci_entry%time_message () end subroutine process_mci_entry_final_integration @ %def process_mci_entry_integrate @ %def process_mci_entry_final_integration @ If appropriate, issue an informative message about the expected time for an event sample. <>= procedure :: get_time => process_mci_entry_get_time procedure :: time_message => process_mci_entry_time_message <>= subroutine process_mci_entry_get_time (mci_entry, time, sample) class(process_mci_entry_t), intent(in) :: mci_entry type(time_t), intent(out) :: time integer, intent(in) :: sample real(default) :: time_last_pass, efficiency, calls time_last_pass = mci_entry%mci%get_time () calls = mci_entry%results%get_n_calls () efficiency = mci_entry%mci%get_efficiency () if (time_last_pass > 0 .and. calls > 0 .and. efficiency > 0) then time = nint (time_last_pass / calls / efficiency * sample) end if end subroutine process_mci_entry_get_time subroutine process_mci_entry_time_message (mci_entry) class(process_mci_entry_t), intent(in) :: mci_entry type(time_t) :: time integer :: sample sample = 10000 call mci_entry%get_time (time, sample) if (time%is_known ()) then call msg_message ("Time estimate for generating 10000 events: " & // char (time%to_string_dhms ())) end if end subroutine process_mci_entry_time_message @ %def process_mci_entry_time_message @ Prepare event generation. (For the test integrator, this does nothing. It is relevant for the VAMP integrator.) <>= procedure :: prepare_simulation => process_mci_entry_prepare_simulation <>= subroutine process_mci_entry_prepare_simulation (mci_entry) class(process_mci_entry_t), intent(inout) :: mci_entry call mci_entry%mci%prepare_simulation () end subroutine process_mci_entry_prepare_simulation @ %def process_mci_entry_prepare_simulation @ Generate an event. The instance should be initialized, otherwise event generation is directed by the [[mci]] integrator subobject. The integrator instance is contained in a [[mci_work]] subobject of the process instance, which simultaneously serves as the sampler object. (We avoid the anti-aliasing rules if we assume that the sampling itself does not involve the integrator instance contained in the process instance.) Regarding weighted events, we only take events which are valid, which means that they have valid kinematics and have passed cuts. Therefore, we have a rejection loop. For unweighted events, the unweighting routine should already take care of this. The [[keep_failed]] flag determines whether events which failed cuts are nevertheless produced, to be recorded with zero weight. Alternatively, failed events are dropped, and this fact is recorded by the counter [[n_dropped]]. <>= procedure :: generate_weighted_event => & process_mci_entry_generate_weighted_event procedure :: generate_unweighted_event => & process_mci_entry_generate_unweighted_event <>= subroutine process_mci_entry_generate_weighted_event (mci_entry, & mci_instance, mci_sampler, keep_failed) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_instance_t), intent(inout) :: mci_instance class(mci_sampler_t), intent(inout) :: mci_sampler logical, intent(in) :: keep_failed logical :: generate_new generate_new = .true. call mci_instance%reset_n_event_dropped () REJECTION: do while (generate_new) call mci_entry%mci%generate_weighted_event (mci_instance, mci_sampler) if (signal_is_pending ()) return if (.not. mci_sampler%is_valid()) then if (keep_failed) then generate_new = .false. else call mci_instance%record_event_dropped () generate_new = .true. end if else generate_new = .false. end if end do REJECTION end subroutine process_mci_entry_generate_weighted_event subroutine process_mci_entry_generate_unweighted_event (mci_entry, mci_instance, mci_sampler) class(process_mci_entry_t), intent(inout) :: mci_entry class(mci_instance_t), intent(inout) :: mci_instance class(mci_sampler_t), intent(inout) :: mci_sampler call mci_entry%mci%generate_unweighted_event (mci_instance, mci_sampler) end subroutine process_mci_entry_generate_unweighted_event @ %def process_mci_entry_generate_weighted_event @ %def process_mci_entry_generate_unweighted_event @ Extract results. <>= procedure :: has_integral => process_mci_entry_has_integral procedure :: get_integral => process_mci_entry_get_integral procedure :: get_error => process_mci_entry_get_error procedure :: get_accuracy => process_mci_entry_get_accuracy procedure :: get_chi2 => process_mci_entry_get_chi2 procedure :: get_efficiency => process_mci_entry_get_efficiency <>= function process_mci_entry_has_integral (mci_entry) result (flag) class(process_mci_entry_t), intent(in) :: mci_entry logical :: flag flag = mci_entry%results%exist () end function process_mci_entry_has_integral function process_mci_entry_get_integral (mci_entry) result (integral) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: integral integral = mci_entry%results%get_integral () end function process_mci_entry_get_integral function process_mci_entry_get_error (mci_entry) result (error) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: error error = mci_entry%results%get_error () end function process_mci_entry_get_error function process_mci_entry_get_accuracy (mci_entry) result (accuracy) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: accuracy accuracy = mci_entry%results%get_accuracy () end function process_mci_entry_get_accuracy function process_mci_entry_get_chi2 (mci_entry) result (chi2) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: chi2 chi2 = mci_entry%results%get_chi2 () end function process_mci_entry_get_chi2 function process_mci_entry_get_efficiency (mci_entry) result (efficiency) class(process_mci_entry_t), intent(in) :: mci_entry real(default) :: efficiency efficiency = mci_entry%results%get_efficiency () end function process_mci_entry_get_efficiency @ %def process_mci_entry_get_integral process_mci_entry_get_error @ %def process_mci_entry_get_accuracy process_mci_entry_get_chi2 @ %def process_mci_entry_get_efficiency @ Return the MCI checksum. This may be the one used for configuration, but may also incorporate results, if they change the state of the integrator (adaptation). <>= procedure :: get_md5sum => process_mci_entry_get_md5sum <>= pure function process_mci_entry_get_md5sum (entry) result (md5sum) class(process_mci_entry_t), intent(in) :: entry character(32) :: md5sum md5sum = entry%mci%get_md5sum () end function process_mci_entry_get_md5sum @ %def process_mci_entry_get_md5sum @ \subsection{MC parameter set and MCI instance} For each process component that is associated with a multi-channel integration (MCI) object, the [[mci_work_t]] object contains the currently active parameter set. It also holds the implementation of the [[mci_instance_t]] that the integrator needs for doing its work. <>= public :: mci_work_t <>= type :: mci_work_t type(process_mci_entry_t), pointer :: config => null () real(default), dimension(:), allocatable :: x class(mci_instance_t), pointer :: mci => null () type(process_counter_t) :: counter logical :: keep_failed_events = .false. integer :: n_event_dropped = 0 contains <> end type mci_work_t @ %def mci_work_t @ First write configuration data, then the current values. <>= procedure :: write => mci_work_write <>= subroutine mci_work_write (mci_work, unit, testflag) class(mci_work_t), intent(in) :: mci_work integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u, i u = given_output_unit (unit) write (u, "(1x,A,I0,A)") "Active MCI instance #", & mci_work%config%i_mci, " =" write (u, "(2x)", advance="no") do i = 1, mci_work%config%n_par write (u, "(1x,F7.5)", advance="no") mci_work%x(i) if (i == mci_work%config%n_par_sf) & write (u, "(1x,'|')", advance="no") end do write (u, *) if (associated (mci_work%mci)) then call mci_work%mci%write (u, pacify = testflag) call mci_work%counter%write (u) end if end subroutine mci_work_write @ %def mci_work_write @ The [[mci]] component may require finalization. <>= procedure :: final => mci_work_final <>= subroutine mci_work_final (mci_work) class(mci_work_t), intent(inout) :: mci_work if (associated (mci_work%mci)) then call mci_work%mci%final () deallocate (mci_work%mci) end if end subroutine mci_work_final @ %def mci_work_final @ Initialize with the maximum length that we will need. Contents are not initialized. The integrator inside the [[mci_entry]] object is responsible for allocating and initializing its own instance, which is referred to by a pointer in the [[mci_work]] object. <>= procedure :: init => mci_work_init <>= subroutine mci_work_init (mci_work, mci_entry) class(mci_work_t), intent(out) :: mci_work type(process_mci_entry_t), intent(in), target :: mci_entry mci_work%config => mci_entry allocate (mci_work%x (mci_entry%n_par)) if (allocated (mci_entry%mci)) then call mci_entry%mci%allocate_instance (mci_work%mci) call mci_work%mci%init (mci_entry%mci) end if end subroutine mci_work_init @ %def mci_work_init @ Set parameters explicitly, either all at once, or separately for the structure-function and process parts. <>= procedure :: set => mci_work_set procedure :: set_x_strfun => mci_work_set_x_strfun procedure :: set_x_process => mci_work_set_x_process <>= subroutine mci_work_set (mci_work, x) class(mci_work_t), intent(inout) :: mci_work real(default), dimension(:), intent(in) :: x mci_work%x = x end subroutine mci_work_set subroutine mci_work_set_x_strfun (mci_work, x) class(mci_work_t), intent(inout) :: mci_work real(default), dimension(:), intent(in) :: x mci_work%x(1 : mci_work%config%n_par_sf) = x end subroutine mci_work_set_x_strfun subroutine mci_work_set_x_process (mci_work, x) class(mci_work_t), intent(inout) :: mci_work real(default), dimension(:), intent(in) :: x mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par) = x end subroutine mci_work_set_x_process @ %def mci_work_set @ %def mci_work_set_x_strfun @ %def mci_work_set_x_process @ Return the array of active components, i.e., those that correspond to the currently selected MC parameter set. <>= procedure :: get_active_components => mci_work_get_active_components <>= function mci_work_get_active_components (mci_work) result (i_component) class(mci_work_t), intent(in) :: mci_work integer, dimension(:), allocatable :: i_component allocate (i_component (size (mci_work%config%i_component))) i_component = mci_work%config%i_component end function mci_work_get_active_components @ %def mci_work_get_active_components @ Return the active parameters as a simple array with correct length. Do this separately for the structure-function parameters and the process parameters. <>= procedure :: get_x_strfun => mci_work_get_x_strfun procedure :: get_x_process => mci_work_get_x_process <>= pure function mci_work_get_x_strfun (mci_work) result (x) class(mci_work_t), intent(in) :: mci_work real(default), dimension(mci_work%config%n_par_sf) :: x x = mci_work%x(1 : mci_work%config%n_par_sf) end function mci_work_get_x_strfun pure function mci_work_get_x_process (mci_work) result (x) class(mci_work_t), intent(in) :: mci_work real(default), dimension(mci_work%config%n_par_phs) :: x x = mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par) end function mci_work_get_x_process @ %def mci_work_get_x_strfun @ %def mci_work_get_x_process @ Initialize and finalize event generation for the specified MCI entry. This also resets the counter. <>= procedure :: init_simulation => mci_work_init_simulation procedure :: final_simulation => mci_work_final_simulation <>= subroutine mci_work_init_simulation (mci_work, safety_factor, keep_failed_events) class(mci_work_t), intent(inout) :: mci_work real(default), intent(in), optional :: safety_factor logical, intent(in), optional :: keep_failed_events call mci_work%mci%init_simulation (safety_factor) call mci_work%counter%reset () if (present (keep_failed_events)) & mci_work%keep_failed_events = keep_failed_events end subroutine mci_work_init_simulation subroutine mci_work_final_simulation (mci_work) class(mci_work_t), intent(inout) :: mci_work call mci_work%mci%final_simulation () end subroutine mci_work_final_simulation @ %def mci_work_init_simulation @ %def mci_work_final_simulation @ Counter. <>= procedure :: reset_counter => mci_work_reset_counter procedure :: record_call => mci_work_record_call procedure :: get_counter => mci_work_get_counter <>= subroutine mci_work_reset_counter (mci_work) class(mci_work_t), intent(inout) :: mci_work call mci_work%counter%reset () end subroutine mci_work_reset_counter subroutine mci_work_record_call (mci_work, status) class(mci_work_t), intent(inout) :: mci_work integer, intent(in) :: status call mci_work%counter%record (status) end subroutine mci_work_record_call pure function mci_work_get_counter (mci_work) result (counter) class(mci_work_t), intent(in) :: mci_work type(process_counter_t) :: counter counter = mci_work%counter end function mci_work_get_counter @ %def mci_work_reset_counter @ %def mci_work_record_call @ %def mci_work_get_counter @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process component manager} <<[[pcm.f90]]>>= <> module pcm <> <> use constants, only: zero, two use diagnostics use lorentz use io_units, only: free_unit use os_interface use process_constants, only: process_constants_t use physics_defs use model_data, only: model_data_t use models, only: model_t use interactions, only: interaction_t use quantum_numbers, only: quantum_numbers_t, quantum_numbers_mask_t use flavors, only: flavor_t use variables, only: var_list_t use nlo_data, only: nlo_settings_t use mci_base, only: mci_t use phs_base, only: phs_config_t use mappings, only: mapping_defaults_t use phs_forests, only: phs_parameters_t use phs_fks, only: isr_kinematics_t, real_kinematics_t use phs_fks, only: phs_identifier_t use dispatch_fks, only: dispatch_fks_s use fks_regions, only: region_data_t use nlo_data, only: fks_template_t use phs_fks, only: phs_fks_generator_t use phs_fks, only: dalitz_plot_t use phs_fks, only: phs_fks_config_t, get_filtered_resonance_histories use dispatch_phase_space, only: dispatch_phs use process_libraries, only: process_component_def_t use real_subtraction, only: real_subtraction_t, soft_mismatch_t use real_subtraction, only: FIXED_ORDER_EVENTS, POWHEG use real_subtraction, only: real_partition_t, powheg_damping_simple_t use real_subtraction, only: real_partition_fixed_order_t use virtual, only: virtual_t use dglap_remnant, only: dglap_remnant_t use prc_threshold, only: threshold_def_t use resonances, only: resonance_history_t, resonance_history_set_t use nlo_data, only: FKS_DEFAULT, FKS_RESONANCES use blha_config, only: blha_master_t use blha_olp_interfaces, only: prc_blha_t use pcm_base use process_config use process_mci, only: process_mci_entry_t use process_mci, only: REAL_SINGULAR, REAL_FINITE <> <> <> contains <> end module pcm @ %def pcm @ \subsection{Default process component manager} This is the configuration object which has the duty of allocating the corresponding instance. The default version is trivial. <>= public :: pcm_default_t <>= type, extends (pcm_t) :: pcm_default_t contains <> end type pcm_default_t @ %def pcm_default_t <>= procedure :: allocate_instance => pcm_default_allocate_instance <>= subroutine pcm_default_allocate_instance (pcm, instance) class(pcm_default_t), intent(in) :: pcm class(pcm_instance_t), intent(inout), allocatable :: instance allocate (pcm_instance_default_t :: instance) end subroutine pcm_default_allocate_instance @ %def pcm_default_allocate_instance @ Finalizer: apply to core manager. <>= procedure :: final => pcm_default_final <>= subroutine pcm_default_final (pcm) class(pcm_default_t), intent(inout) :: pcm end subroutine pcm_default_final @ %def pcm_default_final @ <>= procedure :: is_nlo => pcm_default_is_nlo <>= function pcm_default_is_nlo (pcm) result (is_nlo) logical :: is_nlo class(pcm_default_t), intent(in) :: pcm is_nlo = .false. end function pcm_default_is_nlo @ %def pcm_default_is_nlo @ Initialize configuration data, using environment variables. <>= procedure :: init => pcm_default_init <>= subroutine pcm_default_init (pcm, env, meta) class(pcm_default_t), intent(out) :: pcm type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta pcm%has_pdfs = env%has_pdfs () call pcm%set_blha_defaults & (env%has_polarized_beams (), env%get_var_list_ptr ()) pcm%os_data = env%get_os_data () end subroutine pcm_default_init @ %def pcm_default_init @ <>= type, extends (pcm_instance_t) :: pcm_instance_default_t contains <> end type pcm_instance_default_t @ %def pcm_instance_default_t @ <>= procedure :: final => pcm_instance_default_final <>= subroutine pcm_instance_default_final (pcm_instance) class(pcm_instance_default_t), intent(inout) :: pcm_instance end subroutine pcm_instance_default_final @ %def pcm_instance_default_final @ \subsection{Implementations for the default manager} Categorize components. Nothing to do here, all components are of Born type. <>= procedure :: categorize_components => pcm_default_categorize_components <>= subroutine pcm_default_categorize_components (pcm, config) class(pcm_default_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config end subroutine pcm_default_categorize_components @ %def pcm_default_categorize_components @ \subsubsection{Phase-space configuration} Default setup for tree processes: a single phase-space configuration that is valid for all components. <>= procedure :: init_phs_config => pcm_default_init_phs_config <>= subroutine pcm_default_init_phs_config & (pcm, phs_entry, meta, env, phs_par, mapping_defs) class(pcm_default_t), intent(inout) :: pcm type(process_phs_config_t), & dimension(:), allocatable, intent(out) :: phs_entry type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env type(mapping_defaults_t), intent(in) :: mapping_defs type(phs_parameters_t), intent(in) :: phs_par allocate (phs_entry (1)) allocate (pcm%i_phs_config (pcm%n_components), source=1) call dispatch_phs (phs_entry(1)%phs_config, & env%get_var_list_ptr (), & env%get_os_data (), & meta%id, & mapping_defs, phs_par) end subroutine pcm_default_init_phs_config @ %def pcm_default_init_phs_config @ \subsubsection{Core management} The default component manager assigns one core per component. We allocate and configure the core objects, using the process-component configuration data. <>= procedure :: allocate_cores => pcm_default_allocate_cores <>= subroutine pcm_default_allocate_cores (pcm, config, core_entry) class(pcm_default_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry type(process_component_def_t), pointer :: component_def integer :: i allocate (pcm%i_core (pcm%n_components), source = 0) pcm%n_cores = pcm%n_components allocate (core_entry (pcm%n_cores)) do i = 1, pcm%n_cores pcm%i_core(i) = i core_entry(i)%i_component = i component_def => config%process_def%get_component_def_ptr (i) core_entry(i)%core_def => component_def%get_core_def_ptr () core_entry(i)%active = component_def%can_be_integrated () end do end subroutine pcm_default_allocate_cores @ %def pcm_default_allocate_cores @ Extra code is required for certain core types (threshold) or if BLHA uses an external OLP (Born only, this case) for getting its matrix elements. <>= procedure :: prepare_any_external_code => & pcm_default_prepare_any_external_code <>= subroutine pcm_default_prepare_any_external_code & (pcm, core_entry, i_core, libname, model, var_list) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry integer, intent(in) :: i_core type(string_t), intent(in) :: libname type(model_data_t), intent(in), target :: model type(var_list_t), intent(in) :: var_list if (core_entry%active) then associate (core => core_entry%core) if (core%needs_external_code ()) then call core%prepare_external_code & (core%data%flv_state, & var_list, pcm%os_data, libname, model, i_core, .false.) end if end associate end if end subroutine pcm_default_prepare_any_external_code @ %def pcm_default_prepare_any_external_code @ Allocate and configure the BLHA record for a specific core, assuming that the core type requires it. In the default case, this is a Born configuration. <>= procedure :: setup_blha => pcm_default_setup_blha <>= subroutine pcm_default_setup_blha (pcm, core_entry) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry allocate (core_entry%blha_config, source = pcm%blha_defaults) call core_entry%blha_config%set_born () end subroutine pcm_default_setup_blha @ %def pcm_default_setup_blha @ Apply the configuration, using [[pcm]] data. <>= procedure :: prepare_blha_core => pcm_default_prepare_blha_core <>= subroutine pcm_default_prepare_blha_core (pcm, core_entry, model) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry class(model_data_t), intent(in), target :: model integer :: n_in integer :: n_legs integer :: n_flv integer :: n_hel select type (core => core_entry%core) class is (prc_blha_t) associate (blha_config => core_entry%blha_config) n_in = core%data%n_in n_legs = core%data%get_n_tot () n_flv = core%data%n_flv n_hel = blha_config%get_n_hel (core%data%flv_state (1:n_in,1), model) call core%init_blha (blha_config, n_in, n_legs, n_flv, n_hel) call core%init_driver (pcm%os_data) end associate end select end subroutine pcm_default_prepare_blha_core @ %def pcm_default_prepare_blha_core @ Read the method settings from the variable list and store them in the BLHA master. This version: no NLO flag. <>= procedure :: set_blha_methods => pcm_default_set_blha_methods <>= subroutine pcm_default_set_blha_methods (pcm, blha_master, var_list) class(pcm_default_t), intent(in) :: pcm type(blha_master_t), intent(inout) :: blha_master type(var_list_t), intent(in) :: var_list call blha_master%set_methods (.false., var_list) end subroutine pcm_default_set_blha_methods @ %def pcm_default_set_blha_methods @ Produce the LO and NLO flavor-state tables (as far as available), as appropriate for BLHA configuration. The default version looks at the first process core only, to get the Born data. (Multiple cores are thus unsupported.) The NLO flavor table is left unallocated. <>= procedure :: get_blha_flv_states => pcm_default_get_blha_flv_states <>= subroutine pcm_default_get_blha_flv_states & (pcm, core_entry, flv_born, flv_real) class(pcm_default_t), intent(in) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry integer, dimension(:,:), allocatable, intent(out) :: flv_born integer, dimension(:,:), allocatable, intent(out) :: flv_real flv_born = core_entry(1)%core%data%flv_state end subroutine pcm_default_get_blha_flv_states @ %def pcm_default_get_blha_flv_states @ Allocate and configure the MCI (multi-channel integrator) records. There is one record per active process component. Second procedure: call the MCI dispatcher with default-setup arguments. <>= procedure :: setup_mci => pcm_default_setup_mci procedure :: call_dispatch_mci => pcm_default_call_dispatch_mci <>= subroutine pcm_default_setup_mci (pcm, mci_entry) class(pcm_default_t), intent(inout) :: pcm type(process_mci_entry_t), & dimension(:), allocatable, intent(out) :: mci_entry class(mci_t), allocatable :: mci_template integer :: i, i_mci pcm%n_mci = count (pcm%component_active) allocate (pcm%i_mci (pcm%n_components), source = 0) i_mci = 0 do i = 1, pcm%n_components if (pcm%component_active(i)) then i_mci = i_mci + 1 pcm%i_mci(i) = i_mci end if end do allocate (mci_entry (pcm%n_mci)) end subroutine pcm_default_setup_mci subroutine pcm_default_call_dispatch_mci (pcm, & dispatch_mci, var_list, process_id, mci_template) class(pcm_default_t), intent(inout) :: pcm procedure(dispatch_mci_proc) :: dispatch_mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id class(mci_t), allocatable, intent(out) :: mci_template call dispatch_mci (mci_template, var_list, process_id) end subroutine pcm_default_call_dispatch_mci @ %def pcm_default_setup_mci @ %def pcm_default_call_dispatch_mci @ Nothing left to do for the default algorithm. <>= procedure :: complete_setup => pcm_default_complete_setup <>= subroutine pcm_default_complete_setup (pcm, core_entry, component, model) class(pcm_default_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry type(process_component_t), dimension(:), intent(inout) :: component type(model_t), intent(in), target :: model end subroutine pcm_default_complete_setup @ %def pcm_default_complete_setup @ \subsubsection{Component management} Initialize a single component. We require all process-configuration blocks, and specific templates for the phase-space and integrator configuration. We also provide the current component index [[i]] and the [[active]] flag. In the default mode, all components are marked as master components. <>= procedure :: init_component => pcm_default_init_component <>= subroutine pcm_default_init_component & (pcm, component, i, active, & phs_config, env, meta, config) class(pcm_default_t), intent(in) :: pcm type(process_component_t), intent(out) :: component integer, intent(in) :: i logical, intent(in) :: active class(phs_config_t), allocatable, intent(in) :: phs_config type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config call component%init (i, & env, meta, config, & active, & phs_config) component%component_type = COMP_MASTER end subroutine pcm_default_init_component @ %def pcm_default_init_component @ \subsection{NLO process component manager} The NLO-aware version of the process-component manager. This is the configuration object, which has the duty of allocating the corresponding instance. This is the nontrivial NLO version. <>= public :: pcm_nlo_t <>= type, extends (pcm_t) :: pcm_nlo_t type(string_t) :: id logical :: combined_integration = .false. logical :: vis_fks_regions = .false. integer, dimension(:), allocatable :: nlo_type integer, dimension(:), allocatable :: nlo_type_core integer, dimension(:), allocatable :: component_type integer :: i_born = 0 integer :: i_real = 0 integer :: i_sub = 0 type(nlo_settings_t) :: settings type(region_data_t) :: region_data logical :: use_real_partition = .false. real(default) :: real_partition_scale = 0 class(real_partition_t), allocatable :: real_partition type(dalitz_plot_t) :: dalitz_plot type(quantum_numbers_t), dimension(:,:), allocatable :: qn_real, qn_born contains <> end type pcm_nlo_t @ %def pcm_nlo_t @ Initialize configuration data, using environment variables. <>= procedure :: init => pcm_nlo_init <>= subroutine pcm_nlo_init (pcm, env, meta) class(pcm_nlo_t), intent(out) :: pcm type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env type(var_list_t), pointer :: var_list type(fks_template_t) :: fks_template pcm%id = meta%id pcm%has_pdfs = env%has_pdfs () var_list => env%get_var_list_ptr () call dispatch_fks_s (fks_template, var_list) call pcm%settings%init (var_list, fks_template) pcm%combined_integration = & var_list%get_lval (var_str ('?combined_nlo_integration')) pcm%use_real_partition = & var_list%get_lval (var_str ("?nlo_use_real_partition")) pcm%real_partition_scale = & var_list%get_rval (var_str ("real_partition_scale")) pcm%vis_fks_regions = & var_list%get_lval (var_str ("?vis_fks_regions")) call pcm%set_blha_defaults & (env%has_polarized_beams (), env%get_var_list_ptr ()) pcm%os_data = env%get_os_data () end subroutine pcm_nlo_init @ %def pcm_nlo_init @ Init/rewrite NLO settings without the FKS template. <>= procedure :: init_nlo_settings => pcm_nlo_init_nlo_settings <>= subroutine pcm_nlo_init_nlo_settings (pcm, var_list) class(pcm_nlo_t), intent(inout) :: pcm type(var_list_t), intent(in), target :: var_list call pcm%settings%init (var_list) end subroutine pcm_nlo_init_nlo_settings @ %def pcm_nlo_init_nlo_settings @ As appropriate for the NLO/FKS algorithm, the category defined by the process, is called [[nlo_type]]. We refine this by setting the component category [[component_type]] separately. The component types [[COMP_MISMATCH]], [[COMP_PDF]], [[COMP_SUB]] are set only if the algorithm uses combined integration. Otherwise, they are set to [[COMP_DEFAULT]]. The component type [[COMP_REAL]] is further distinguished between [[COMP_REAL_SING]] or [[COMP_REAL_FIN]], if the algorithm uses real partitions. The former acts as a reference component for the latter, and we always assume that it is the first real component. Each component is assigned its own core. Exceptions: the finite-real component gets the same core as the singular-real component. The mismatch component gets the same core as the subtraction component. -TODO: this convention for real components can be improved. Check whether +TODO wk 2018: this convention for real components can be improved. Check whether all component types should be assigned, not just for combined integration. <>= procedure :: categorize_components => pcm_nlo_categorize_components <>= subroutine pcm_nlo_categorize_components (pcm, config) class(pcm_nlo_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config type(process_component_def_t), pointer :: component_def integer :: i allocate (pcm%nlo_type (pcm%n_components), source = COMPONENT_UNDEFINED) allocate (pcm%component_type (pcm%n_components), source = COMP_DEFAULT) do i = 1, pcm%n_components component_def => config%process_def%get_component_def_ptr (i) pcm%nlo_type(i) = component_def%get_nlo_type () if (pcm%combined_integration) then select case (pcm%nlo_type(i)) case (BORN) pcm%i_born = i pcm%component_type(i) = COMP_MASTER case (NLO_REAL) pcm%component_type(i) = COMP_REAL case (NLO_VIRTUAL) pcm%component_type(i) = COMP_VIRT case (NLO_MISMATCH) pcm%component_type(i) = COMP_MISMATCH case (NLO_DGLAP) pcm%component_type(i) = COMP_PDF case (NLO_SUBTRACTION) pcm%component_type(i) = COMP_SUB pcm%i_sub = i end select else select case (pcm%nlo_type(i)) case (BORN) pcm%i_born = i pcm%component_type(i) = COMP_MASTER case (NLO_REAL) pcm%component_type(i) = COMP_REAL case (NLO_VIRTUAL) pcm%component_type(i) = COMP_VIRT case (NLO_MISMATCH) pcm%component_type(i) = COMP_MISMATCH case (NLO_SUBTRACTION) pcm%i_sub = i end select end if end do call refine_real_type ( & pack ([(i, i=1, pcm%n_components)], & pcm%component_type==COMP_REAL)) contains subroutine refine_real_type (i_real) integer, dimension(:), intent(in) :: i_real pcm%i_real = i_real(1) if (pcm%use_real_partition) then pcm%component_type (i_real(1)) = COMP_REAL_SING pcm%component_type (i_real(2:)) = COMP_REAL_FIN end if end subroutine refine_real_type end subroutine pcm_nlo_categorize_components @ %def pcm_nlo_categorize_components @ \subsubsection{Phase-space initial configuration} Setup for the NLO/PHS processes: two phase-space configurations, (1) Born/wood, (2) real correction/FKS. All components use either one of these two configurations. -TODO: The [[first_real_component]] identifier is really ugly. Nothing should +TODO wk 2018: The [[first_real_component]] identifier is really ugly. Nothing should rely on the ordering. <>= procedure :: init_phs_config => pcm_nlo_init_phs_config <>= subroutine pcm_nlo_init_phs_config & (pcm, phs_entry, meta, env, phs_par, mapping_defs) class(pcm_nlo_t), intent(inout) :: pcm type(process_phs_config_t), & dimension(:), allocatable, intent(out) :: phs_entry type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env type(mapping_defaults_t), intent(in) :: mapping_defs type(phs_parameters_t), intent(in) :: phs_par integer :: i logical :: first_real_component allocate (phs_entry (2)) call dispatch_phs (phs_entry(1)%phs_config, & env%get_var_list_ptr (), & env%get_os_data (), & meta%id, & mapping_defs, phs_par, & var_str ("wood")) call dispatch_phs (phs_entry(2)%phs_config, & env%get_var_list_ptr (), & env%get_os_data (), & meta%id, & mapping_defs, phs_par, & var_str ("fks")) allocate (pcm%i_phs_config (pcm%n_components), source=0) first_real_component = .true. do i = 1, pcm%n_components select case (pcm%nlo_type(i)) case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION) pcm%i_phs_config(i) = 1 case (NLO_REAL) if (first_real_component) then pcm%i_phs_config(i) = 2 if (pcm%use_real_partition) first_real_component = .false. else pcm%i_phs_config(i) = 1 end if case (NLO_MISMATCH, NLO_DGLAP, GKS) pcm%i_phs_config(i) = 2 end select end do end subroutine pcm_nlo_init_phs_config @ %def pcm_nlo_init_phs_config @ \subsubsection{Core management} Allocate the core (matrix-element interface) objects that we will need for evaluation. Every component gets an associated core, except for the real-finite and mismatch components (if any). Those components are associated with their previous corresponding real-singular and subtraction cores, respectively. After cores are allocated, configure the region-data block that is maintained by the NLO process-component manager. <>= procedure :: allocate_cores => pcm_nlo_allocate_cores <>= subroutine pcm_nlo_allocate_cores (pcm, config, core_entry) class(pcm_nlo_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry type(process_component_def_t), pointer :: component_def integer :: i, i_core allocate (pcm%i_core (pcm%n_components), source = 0) pcm%n_cores = pcm%n_components & - count (pcm%component_type(:) == COMP_REAL_FIN) & - count (pcm%component_type(:) == COMP_MISMATCH) allocate (core_entry (pcm%n_cores)) allocate (pcm%nlo_type_core (pcm%n_cores), source = BORN) i_core = 0 do i = 1, pcm%n_components select case (pcm%component_type(i)) case default i_core = i_core + 1 pcm%i_core(i) = i_core pcm%nlo_type_core(i_core) = pcm%nlo_type(i) core_entry(i_core)%i_component = i component_def => config%process_def%get_component_def_ptr (i) core_entry(i_core)%core_def => component_def%get_core_def_ptr () select case (pcm%nlo_type(i)) case default core_entry(i)%active = component_def%can_be_integrated () case (NLO_REAL, NLO_SUBTRACTION) core_entry(i)%active = .true. end select case (COMP_REAL_FIN) pcm%i_core(i) = pcm%i_core(pcm%i_real) case (COMP_MISMATCH) pcm%i_core(i) = pcm%i_core(pcm%i_sub) end select end do end subroutine pcm_nlo_allocate_cores @ %def pcm_nlo_allocate_cores @ Extra code is required for certain core types (threshold) or if BLHA uses an external OLP for getting its matrix elements. OMega matrix elements, by definition, do not need extra code. NLO-virtual or subtraction matrix elements always need extra code. More precisely: for the Born and virtual matrix element, the extra code is accessed only if the component is active. The radiation (real) and the subtraction corrections (singular and finite), extra code is accessed in any case. The flavor state is taken from the [[region_data]] table in the [[pcm]] record. We use the Born and real flavor-state tables as appropriate. <>= procedure :: prepare_any_external_code => & pcm_nlo_prepare_any_external_code <>= subroutine pcm_nlo_prepare_any_external_code & (pcm, core_entry, i_core, libname, model, var_list) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry integer, intent(in) :: i_core type(string_t), intent(in) :: libname type(model_data_t), intent(in), target :: model type(var_list_t), intent(in) :: var_list integer, dimension(:,:), allocatable :: flv_born, flv_real integer :: i call pcm%region_data%get_all_flv_states (flv_born, flv_real) if (core_entry%active) then associate (core => core_entry%core) if (core%needs_external_code ()) then select case (pcm%nlo_type (core_entry%i_component)) case default call core%data%set_flv_state (flv_born) case (NLO_REAL) call core%data%set_flv_state (flv_real) end select call core%prepare_external_code & (core%data%flv_state, & var_list, pcm%os_data, libname, model, i_core, .true.) end if end associate end if end subroutine pcm_nlo_prepare_any_external_code @ %def pcm_nlo_prepare_any_external_code @ Allocate and configure the BLHA record for a specific core, assuming that the core type requires it. The configuration depends on the NLO type of the core. <>= procedure :: setup_blha => pcm_nlo_setup_blha <>= subroutine pcm_nlo_setup_blha (pcm, core_entry) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry allocate (core_entry%blha_config, source = pcm%blha_defaults) select case (pcm%nlo_type(core_entry%i_component)) case (BORN) call core_entry%blha_config%set_born () case (NLO_REAL) call core_entry%blha_config%set_real_trees () case (NLO_VIRTUAL) call core_entry%blha_config%set_loop () case (NLO_SUBTRACTION) call core_entry%blha_config%set_subtraction () call core_entry%blha_config%set_internal_color_correlations () case (NLO_DGLAP) call core_entry%blha_config%set_dglap () end select end subroutine pcm_nlo_setup_blha @ %def pcm_nlo_setup_blha @ After phase-space configuration data and core entries are available, we fill tables and compute the remaining NLO data that will steer the integration and subtraction algorithm. There are three parts: recognize a threshold-type process core (if it exists), prepare the region-data tables (always), and prepare for real partitioning (if requested). The real-component phase space acts as the source for resonance-history information, required for the region data. <>= procedure :: complete_setup => pcm_nlo_complete_setup <>= subroutine pcm_nlo_complete_setup (pcm, core_entry, component, model) class(pcm_nlo_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry type(process_component_t), dimension(:), intent(inout) :: component type(model_t), intent(in), target :: model integer :: i call pcm%handle_threshold_core (core_entry) call pcm%setup_region_data & (core_entry, component(pcm%i_real)%phs_config, model) call pcm%setup_real_partition () end subroutine pcm_nlo_complete_setup @ %def pcm_nlo_complete_setup @ Apply the BLHA configuration to a core object, using the region data from [[pcm]] for determining the particle content. <>= procedure :: prepare_blha_core => pcm_nlo_prepare_blha_core <>= subroutine pcm_nlo_prepare_blha_core (pcm, core_entry, model) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), intent(inout) :: core_entry class(model_data_t), intent(in), target :: model integer :: n_in integer :: n_legs integer :: n_flv integer :: n_hel select type (core => core_entry%core) class is (prc_blha_t) associate (blha_config => core_entry%blha_config) n_in = core%data%n_in select case (pcm%nlo_type(core_entry%i_component)) case (NLO_REAL) n_legs = pcm%region_data%get_n_legs_real () n_flv = pcm%region_data%get_n_flv_real () case default n_legs = pcm%region_data%get_n_legs_born () n_flv = pcm%region_data%get_n_flv_born () end select n_hel = blha_config%get_n_hel (core%data%flv_state (1:n_in,1), model) call core%init_blha (blha_config, n_in, n_legs, n_flv, n_hel) call core%init_driver (pcm%os_data) end associate end select end subroutine pcm_nlo_prepare_blha_core @ %def pcm_nlo_prepare_blha_core @ Read the method settings from the variable list and store them in the BLHA master. This version: NLO flag set. <>= procedure :: set_blha_methods => pcm_nlo_set_blha_methods <>= subroutine pcm_nlo_set_blha_methods (pcm, blha_master, var_list) class(pcm_nlo_t), intent(in) :: pcm type(blha_master_t), intent(inout) :: blha_master type(var_list_t), intent(in) :: var_list call blha_master%set_methods (.true., var_list) end subroutine pcm_nlo_set_blha_methods @ %def pcm_nlo_set_blha_methods @ Produce the LO and NLO flavor-state tables (as far as available), as appropriate for BLHA configuration. The NLO version copies the tables from the region data inside [[pcm]]. The core array is not needed. <>= procedure :: get_blha_flv_states => pcm_nlo_get_blha_flv_states <>= subroutine pcm_nlo_get_blha_flv_states & (pcm, core_entry, flv_born, flv_real) class(pcm_nlo_t), intent(in) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry integer, dimension(:,:), allocatable, intent(out) :: flv_born integer, dimension(:,:), allocatable, intent(out) :: flv_real call pcm%region_data%get_all_flv_states (flv_born, flv_real) end subroutine pcm_nlo_get_blha_flv_states @ %def pcm_nlo_get_blha_flv_states @ Allocate and configure the MCI (multi-channel integrator) records. The relation depends on the [[combined_integration]] setting. If we integrate components separately, each component gets its own record, except for the subtraction component. If we do the combination, there is one record for the master (Born) component and a second one for the real-finite component, if present. Each entry acquires some NLO-specific initialization. Generic configuration follows later. Second procedure: call the MCI dispatcher with NLO-setup arguments. <>= procedure :: setup_mci => pcm_nlo_setup_mci procedure :: call_dispatch_mci => pcm_nlo_call_dispatch_mci <>= subroutine pcm_nlo_setup_mci (pcm, mci_entry) class(pcm_nlo_t), intent(inout) :: pcm type(process_mci_entry_t), & dimension(:), allocatable, intent(out) :: mci_entry class(mci_t), allocatable :: mci_template integer :: i, i_mci if (pcm%combined_integration) then pcm%n_mci = 1 & + count (pcm%component_active(:) & & .and. pcm%component_type(:) == COMP_REAL_FIN) allocate (pcm%i_mci (pcm%n_components), source = 0) do i = 1, pcm%n_components if (pcm%component_active(i)) then select case (pcm%component_type(i)) case (COMP_MASTER) pcm%i_mci(i) = 1 case (COMP_REAL_FIN) pcm%i_mci(i) = 2 end select end if end do else pcm%n_mci = count (pcm%component_active(:) & & .and. pcm%nlo_type(:) /= NLO_SUBTRACTION) allocate (pcm%i_mci (pcm%n_components), source = 0) i_mci = 0 do i = 1, pcm%n_components if (pcm%component_active(i)) then select case (pcm%nlo_type(i)) case default i_mci = i_mci + 1 pcm%i_mci(i) = i_mci case (NLO_SUBTRACTION) end select end if end do end if allocate (mci_entry (pcm%n_mci)) mci_entry(:)%combined_integration = pcm%combined_integration if (pcm%use_real_partition) then do i = 1, pcm%n_components i_mci = pcm%i_mci(i) if (i_mci > 0) then select case (pcm%component_type(i)) case (COMP_REAL_FIN) mci_entry(i_mci)%real_partition_type = REAL_FINITE case default mci_entry(i_mci)%real_partition_type = REAL_SINGULAR end select end if end do end if end subroutine pcm_nlo_setup_mci subroutine pcm_nlo_call_dispatch_mci (pcm, & dispatch_mci, var_list, process_id, mci_template) class(pcm_nlo_t), intent(inout) :: pcm procedure(dispatch_mci_proc) :: dispatch_mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id class(mci_t), allocatable, intent(out) :: mci_template call dispatch_mci (mci_template, var_list, process_id, is_nlo = .true.) end subroutine pcm_nlo_call_dispatch_mci @ %def pcm_nlo_setup_mci @ %def pcm_nlo_call_dispatch_mci @ Check for a threshold core and adjust the configuration accordingly, before singular region data are considered. <>= procedure :: handle_threshold_core => pcm_nlo_handle_threshold_core <>= subroutine pcm_nlo_handle_threshold_core (pcm, core_entry) class(pcm_nlo_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry integer :: i do i = 1, size (core_entry) select type (core => core_entry(i)%core_def) type is (threshold_def_t) pcm%settings%factorization_mode = FACTORIZATION_THRESHOLD return end select end do end subroutine pcm_nlo_handle_threshold_core @ %def pcm_nlo_handle_threshold_core @ Configure the singular-region tables based on the process data for the Born and Real (singular) cores, using also the appropriate FKS phase-space configuration object. In passing, we may create a table of resonance histories that are relevant for the singular-region configuration. -TODO: check whether [[phs_entry]] needs to be intent(inout). +TODO wk 2018: check whether [[phs_entry]] needs to be intent(inout). <>= procedure :: setup_region_data => pcm_nlo_setup_region_data <>= subroutine pcm_nlo_setup_region_data (pcm, core_entry, phs_config, model) class(pcm_nlo_t), intent(inout) :: pcm type(core_entry_t), dimension(:), intent(in) :: core_entry class(phs_config_t), intent(inout) :: phs_config type(model_t), intent(in), target :: model type(process_constants_t) :: data_born, data_real integer, dimension (:,:), allocatable :: flavor_born, flavor_real type(resonance_history_t), dimension(:), allocatable :: resonance_histories type(var_list_t), pointer :: var_list logical :: success data_born = core_entry(pcm%i_core(pcm%i_born))%core%data data_real = core_entry(pcm%i_core(pcm%i_real))%core%data call data_born%get_flv_state (flavor_born) call data_real%get_flv_state (flavor_real) call pcm%region_data%init & (data_born%n_in, model, flavor_born, flavor_real, & pcm%settings%nlo_correction_type) associate (template => pcm%settings%fks_template) if (template%mapping_type == FKS_RESONANCES) then select type (phs_config) type is (phs_fks_config_t) call get_filtered_resonance_histories (phs_config, & data_born%n_in, flavor_born, model, & template%excluded_resonances, & resonance_histories, success) end select if (.not. success) template%mapping_type = FKS_DEFAULT end if call pcm%region_data%setup_fks_mappings (template, data_born%n_in) !!! Check again, mapping_type might have changed if (template%mapping_type == FKS_RESONANCES) then call pcm%region_data%set_resonance_mappings (resonance_histories) call pcm%region_data%init_resonance_information () pcm%settings%use_resonance_mappings = .true. end if end associate if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then call pcm%region_data%set_isr_pseudo_regions () call pcm%region_data%split_up_interference_regions_for_threshold () end if call pcm%region_data%compute_number_of_phase_spaces () call pcm%region_data%set_i_phs_to_i_con () call pcm%region_data%write_to_file & (pcm%id, pcm%vis_fks_regions, pcm%os_data) if (debug_active (D_SUBTRACTION)) & call pcm%region_data%check_consistency (.true.) end subroutine pcm_nlo_setup_region_data @ %def pcm_nlo_setup_region_data @ After region data are set up, we allocate and configure the [[real_partition]] objects, if requested. <>= procedure :: setup_real_partition => pcm_nlo_setup_real_partition <>= subroutine pcm_nlo_setup_real_partition (pcm) class(pcm_nlo_t), intent(inout) :: pcm if (pcm%use_real_partition) then if (.not. allocated (pcm%real_partition)) then allocate (real_partition_fixed_order_t :: pcm%real_partition) select type (partition => pcm%real_partition) type is (real_partition_fixed_order_t) call pcm%region_data%get_all_ftuples (partition%fks_pairs) partition%scale = pcm%real_partition_scale end select end if end if end subroutine pcm_nlo_setup_real_partition @ %def pcm_nlo_setup_real_partition @ Initialize a single component. We require all process-configuration blocks, and specific templates for the phase-space and integrator configuration. We also provide the current component index [[i]] and the [[active]] flag. For a subtraction component, the [[active]] flag is overridden. In the nlo mode, the component types have been determined before. -TODO: the component type need not be stored in the component; we may remove +TODO wk 2018: the component type need not be stored in the component; we may remove this when everything is controlled by [[pcm]]. <>= procedure :: init_component => pcm_nlo_init_component <>= subroutine pcm_nlo_init_component & (pcm, component, i, active, & phs_config, env, meta, config) class(pcm_nlo_t), intent(in) :: pcm type(process_component_t), intent(out) :: component integer, intent(in) :: i logical, intent(in) :: active class(phs_config_t), allocatable, intent(in) :: phs_config type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config logical :: activate select case (pcm%nlo_type(i)) case default; activate = active case (NLO_SUBTRACTION); activate = .false. end select call component%init (i, & env, meta, config, & activate, & phs_config) component%component_type = pcm%component_type(i) end subroutine pcm_nlo_init_component @ %def pcm_nlo_init_component @ Override the base method: record the active components in the PCM object, and report inactive components (except for the subtraction component). <>= procedure :: record_inactive_components => pcm_nlo_record_inactive_components <>= subroutine pcm_nlo_record_inactive_components (pcm, component, meta) class(pcm_nlo_t), intent(inout) :: pcm type(process_component_t), dimension(:), intent(in) :: component type(process_metadata_t), intent(inout) :: meta integer :: i pcm%component_active = component%active do i = 1, pcm%n_components select case (pcm%nlo_type(i)) case (NLO_SUBTRACTION) case default if (.not. component(i)%active) call meta%deactivate_component (i) end select end do end subroutine pcm_nlo_record_inactive_components @ %def pcm_nlo_record_inactive_components @ <>= procedure :: core_is_radiation => pcm_nlo_core_is_radiation <>= function pcm_nlo_core_is_radiation (pcm, i_core) result (is_rad) logical :: is_rad class(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_core is_rad = pcm%nlo_type(i_core) == NLO_REAL ! .and. .not. pcm%cm%sub(i_core) end function pcm_nlo_core_is_radiation @ %def pcm_nlo_core_is_radiation @ <>= procedure :: get_n_flv_born => pcm_nlo_get_n_flv_born <>= function pcm_nlo_get_n_flv_born (pcm_nlo) result (n_flv) integer :: n_flv class(pcm_nlo_t), intent(in) :: pcm_nlo n_flv = pcm_nlo%region_data%n_flv_born end function pcm_nlo_get_n_flv_born @ %def pcm_nlo_get_n_flv_born @ <>= procedure :: get_n_flv_real => pcm_nlo_get_n_flv_real <>= function pcm_nlo_get_n_flv_real (pcm_nlo) result (n_flv) integer :: n_flv class(pcm_nlo_t), intent(in) :: pcm_nlo n_flv = pcm_nlo%region_data%n_flv_real end function pcm_nlo_get_n_flv_real @ %def pcm_nlo_get_n_flv_real @ <>= procedure :: get_n_alr => pcm_nlo_get_n_alr <>= function pcm_nlo_get_n_alr (pcm) result (n_alr) integer :: n_alr class(pcm_nlo_t), intent(in) :: pcm n_alr = pcm%region_data%n_regions end function pcm_nlo_get_n_alr @ %def pcm_nlo_get_n_alr @ <>= procedure :: get_flv_states => pcm_nlo_get_flv_states <>= function pcm_nlo_get_flv_states (pcm, born) result (flv) integer, dimension(:,:), allocatable :: flv class(pcm_nlo_t), intent(in) :: pcm logical, intent(in) :: born if (born) then flv = pcm%region_data%get_flv_states_born () else flv = pcm%region_data%get_flv_states_real () end if end function pcm_nlo_get_flv_states @ %def pcm_nlo_get_flv_states @ <>= procedure :: get_qn => pcm_nlo_get_qn <>= function pcm_nlo_get_qn (pcm, born) result (qn) type(quantum_numbers_t), dimension(:,:), allocatable :: qn class(pcm_nlo_t), intent(in) :: pcm logical, intent(in) :: born if (born) then qn = pcm%qn_born else qn = pcm%qn_real end if end function pcm_nlo_get_qn @ %def pcm_nlo_get_qn @ Check if there are massive emitters. Since the mass-structure of all underlying Born configurations have to be the same (\textbf{This does not have to be the case when different components are generated at LO}) , we just use the first one to determine this. <>= procedure :: has_massive_emitter => pcm_nlo_has_massive_emitter <>= function pcm_nlo_has_massive_emitter (pcm) result (val) logical :: val class(pcm_nlo_t), intent(in) :: pcm integer :: i val = .false. associate (reg_data => pcm%region_data) do i = reg_data%n_in + 1, reg_data%n_legs_born if (any (i == reg_data%emitters)) & val = val .or. reg_data%flv_born(1)%massive(i) end do end associate end function pcm_nlo_has_massive_emitter @ %def pcm_nlo_has_massive_emitter @ Returns an array which specifies if the particle at position [[i]] is massive. <>= procedure :: get_mass_info => pcm_nlo_get_mass_info <>= function pcm_nlo_get_mass_info (pcm, i_flv) result (massive) class(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_flv logical, dimension(:), allocatable :: massive allocate (massive (size (pcm%region_data%flv_born(i_flv)%massive))) massive = pcm%region_data%flv_born(i_flv)%massive end function pcm_nlo_get_mass_info @ %def pcm_nlo_get_mass_info @ <>= procedure :: allocate_instance => pcm_nlo_allocate_instance <>= subroutine pcm_nlo_allocate_instance (pcm, instance) class(pcm_nlo_t), intent(in) :: pcm class(pcm_instance_t), intent(inout), allocatable :: instance allocate (pcm_instance_nlo_t :: instance) end subroutine pcm_nlo_allocate_instance @ %def pcm_nlo_allocate_instance @ <>= procedure :: init_qn => pcm_nlo_init_qn <>= subroutine pcm_nlo_init_qn (pcm, model) class(pcm_nlo_t), intent(inout) :: pcm class(model_data_t), intent(in) :: model integer, dimension(:,:), allocatable :: flv_states type(flavor_t), dimension(:), allocatable :: flv integer :: i type(quantum_numbers_t), dimension(:), allocatable :: qn allocate (flv_states (pcm%region_data%n_legs_born, pcm%region_data%n_flv_born)) flv_states = pcm%get_flv_states (.true.) allocate (pcm%qn_born (size (flv_states, dim = 1), size (flv_states, dim = 2))) allocate (flv (size (flv_states, dim = 1))) allocate (qn (size (flv_states, dim = 1))) do i = 1, pcm%get_n_flv_born () call flv%init (flv_states (:,i), model) call qn%init (flv) pcm%qn_born(:,i) = qn end do deallocate (flv); deallocate (qn) deallocate (flv_states) allocate (flv_states (pcm%region_data%n_legs_real, pcm%region_data%n_flv_real)) flv_states = pcm%get_flv_states (.false.) allocate (pcm%qn_real (size (flv_states, dim = 1), size (flv_states, dim = 2))) allocate (flv (size (flv_states, dim = 1))) allocate (qn (size (flv_states, dim = 1))) do i = 1, pcm%get_n_flv_real () call flv%init (flv_states (:,i), model) call qn%init (flv) pcm%qn_real(:,i) = qn end do end subroutine pcm_nlo_init_qn @ %def pcm_nlo_init_qn @ <>= procedure :: allocate_ps_matching => pcm_nlo_allocate_ps_matching <>= subroutine pcm_nlo_allocate_ps_matching (pcm) class(pcm_nlo_t), intent(inout) :: pcm if (.not. allocated (pcm%real_partition)) then allocate (powheg_damping_simple_t :: pcm%real_partition) end if end subroutine pcm_nlo_allocate_ps_matching @ %def pcm_nlo_allocate_ps_matching @ <>= procedure :: activate_dalitz_plot => pcm_nlo_activate_dalitz_plot <>= subroutine pcm_nlo_activate_dalitz_plot (pcm, filename) class(pcm_nlo_t), intent(inout) :: pcm type(string_t), intent(in) :: filename call pcm%dalitz_plot%init (free_unit (), filename, .false.) call pcm%dalitz_plot%write_header () end subroutine pcm_nlo_activate_dalitz_plot @ %def pcm_nlo_activate_dalitz_plot @ <>= procedure :: register_dalitz_plot => pcm_nlo_register_dalitz_plot <>= subroutine pcm_nlo_register_dalitz_plot (pcm, emitter, p) class(pcm_nlo_t), intent(inout) :: pcm integer, intent(in) :: emitter type(vector4_t), intent(in), dimension(:) :: p real(default) :: k0_n, k0_np1 k0_n = p(emitter)%p(0) k0_np1 = p(size(p))%p(0) call pcm%dalitz_plot%register (k0_n, k0_np1) end subroutine pcm_nlo_register_dalitz_plot @ %def pcm_nlo_register_dalitz_plot @ <>= procedure :: setup_phs_generator => pcm_nlo_setup_phs_generator <>= subroutine pcm_nlo_setup_phs_generator (pcm, pcm_instance, generator, & sqrts, mode, singular_jacobian) class(pcm_nlo_t), intent(in) :: pcm type(phs_fks_generator_t), intent(inout) :: generator type(pcm_instance_nlo_t), intent(in), target :: pcm_instance real(default), intent(in) :: sqrts integer, intent(in), optional:: mode logical, intent(in), optional :: singular_jacobian logical :: yorn yorn = .false.; if (present (singular_jacobian)) yorn = singular_jacobian call generator%connect_kinematics (pcm_instance%isr_kinematics, & pcm_instance%real_kinematics, pcm%has_massive_emitter ()) generator%n_in = pcm%region_data%n_in call generator%set_sqrts_hat (sqrts) call generator%set_emitters (pcm%region_data%emitters) call generator%setup_masses (pcm%region_data%n_legs_born) generator%is_massive = pcm%get_mass_info (1) generator%singular_jacobian = yorn if (present (mode)) generator%mode = mode end subroutine pcm_nlo_setup_phs_generator @ %def pcm_nlo_setup_phs_generator @ <>= procedure :: final => pcm_nlo_final <>= subroutine pcm_nlo_final (pcm) class(pcm_nlo_t), intent(inout) :: pcm if (allocated (pcm%real_partition)) deallocate (pcm%real_partition) call pcm%dalitz_plot%final () end subroutine pcm_nlo_final @ %def pcm_nlo_final @ <>= procedure :: is_nlo => pcm_nlo_is_nlo <>= function pcm_nlo_is_nlo (pcm) result (is_nlo) logical :: is_nlo class(pcm_nlo_t), intent(in) :: pcm is_nlo = .true. end function pcm_nlo_is_nlo @ %def pcm_nlo_is_nlo @ As a first implementation, it acts as a wrapper for the NLO controller object and the squared matrix-element collector. <>= public :: pcm_instance_nlo_t <>= type, extends (pcm_instance_t) :: pcm_instance_nlo_t logical :: use_internal_color_correlation = .true. type(real_kinematics_t), pointer :: real_kinematics => null () type(isr_kinematics_t), pointer :: isr_kinematics => null () type(real_subtraction_t) :: real_sub type(virtual_t) :: virtual type(soft_mismatch_t) :: soft_mismatch type(dglap_remnant_t) :: dglap_remnant integer, dimension(:), allocatable :: i_mci_to_real_component contains <> end type pcm_instance_nlo_t @ %def pcm_instance_nlo_t @ <>= procedure :: set_radiation_event => pcm_instance_nlo_set_radiation_event procedure :: set_subtraction_event => pcm_instance_nlo_set_subtraction_event <>= subroutine pcm_instance_nlo_set_radiation_event (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance pcm_instance%real_sub%radiation_event = .true. pcm_instance%real_sub%subtraction_event = .false. end subroutine pcm_instance_nlo_set_radiation_event subroutine pcm_instance_nlo_set_subtraction_event (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance pcm_instance%real_sub%radiation_event = .false. pcm_instance%real_sub%subtraction_event = .true. end subroutine pcm_instance_nlo_set_subtraction_event @ %def pcm_instance_nlo_set_radiation_event @ %def pcm_instance_nlo_set_subtraction_event <>= procedure :: disable_subtraction => pcm_instance_nlo_disable_subtraction <>= subroutine pcm_instance_nlo_disable_subtraction (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance pcm_instance%real_sub%subtraction_deactivated = .true. end subroutine pcm_instance_nlo_disable_subtraction @ %def pcm_instance_nlo_disable_subtraction @ <>= procedure :: init_config => pcm_instance_nlo_init_config <>= subroutine pcm_instance_nlo_init_config (pcm_instance, active_components, & nlo_types, sqrts, i_real_fin, model) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance logical, intent(in), dimension(:) :: active_components integer, intent(in), dimension(:) :: nlo_types real(default), intent(in) :: sqrts integer, intent(in) :: i_real_fin class(model_data_t), intent(in) :: model integer :: i_component call msg_debug (D_PROCESS_INTEGRATION, "pcm_instance_nlo_init_config") call pcm_instance%init_real_and_isr_kinematics (sqrts) select type (pcm => pcm_instance%config) type is (pcm_nlo_t) do i_component = 1, size (active_components) if (active_components(i_component) .or. pcm%settings%combined_integration) then select case (nlo_types(i_component)) case (NLO_REAL) if (i_component /= i_real_fin) then call pcm_instance%setup_real_component & (pcm%settings%fks_template%subtraction_disabled) end if case (NLO_VIRTUAL) call pcm_instance%init_virtual (model) case (NLO_MISMATCH) call pcm_instance%init_soft_mismatch () case (NLO_DGLAP) call pcm_instance%init_dglap_remnant () end select end if end do end select end subroutine pcm_instance_nlo_init_config @ %def pcm_instance_nlo_init_config @ <>= procedure :: setup_real_component => pcm_instance_nlo_setup_real_component <>= subroutine pcm_instance_nlo_setup_real_component (pcm_instance, & subtraction_disabled) class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance logical, intent(in) :: subtraction_disabled call pcm_instance%init_real_subtraction () if (subtraction_disabled) call pcm_instance%disable_subtraction () end subroutine pcm_instance_nlo_setup_real_component @ %def pcm_instance_nlo_setup_real_component @ <>= procedure :: init_real_and_isr_kinematics => & pcm_instance_nlo_init_real_and_isr_kinematics <>= subroutine pcm_instance_nlo_init_real_and_isr_kinematics (pcm_instance, sqrts) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance real(default) :: sqrts integer :: n_contr allocate (pcm_instance%real_kinematics) allocate (pcm_instance%isr_kinematics) select type (config => pcm_instance%config) type is (pcm_nlo_t) associate (region_data => config%region_data) if (allocated (region_data%alr_contributors)) then n_contr = size (region_data%alr_contributors) else if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) then n_contr = 2 else n_contr = 1 end if call pcm_instance%real_kinematics%init & (region_data%n_legs_real, region_data%n_phs, & region_data%n_regions, n_contr) if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) & call pcm_instance%real_kinematics%init_onshell & (region_data%n_legs_real, region_data%n_phs) pcm_instance%isr_kinematics%n_in = region_data%n_in end associate end select pcm_instance%isr_kinematics%beam_energy = sqrts / two end subroutine pcm_instance_nlo_init_real_and_isr_kinematics @ %def pcm_instance_nlo_init_real_and_isr_kinematics @ <>= procedure :: set_real_and_isr_kinematics => & pcm_instance_nlo_set_real_and_isr_kinematics <>= subroutine pcm_instance_nlo_set_real_and_isr_kinematics (pcm_instance, phs_identifiers, sqrts) class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers real(default), intent(in) :: sqrts call pcm_instance%real_sub%set_real_kinematics & (pcm_instance%real_kinematics) call pcm_instance%real_sub%set_isr_kinematics & (pcm_instance%isr_kinematics) end subroutine pcm_instance_nlo_set_real_and_isr_kinematics @ %def pcm_instance_nlo_set_real_and_isr_kinematics @ <>= procedure :: init_real_subtraction => pcm_instance_nlo_init_real_subtraction <>= subroutine pcm_instance_nlo_init_real_subtraction (pcm_instance) class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance select type (config => pcm_instance%config) type is (pcm_nlo_t) associate (region_data => config%region_data) call pcm_instance%real_sub%init (region_data, config%settings) if (allocated (config%settings%selected_alr)) then associate (selected_alr => config%settings%selected_alr) if (any (selected_alr < 0)) then call msg_fatal ("Fixed alpha region must be non-negative!") else if (any (selected_alr > region_data%n_regions)) then call msg_fatal ("Fixed alpha region is larger than the total"& &" number of singular regions!") else allocate (pcm_instance%real_sub%selected_alr (size (selected_alr))) pcm_instance%real_sub%selected_alr = selected_alr end if end associate end if end associate end select end subroutine pcm_instance_nlo_init_real_subtraction @ %def pcm_instance_nlo_init_real_subtraction @ <>= procedure :: set_momenta_and_scales_virtual => & pcm_instance_nlo_set_momenta_and_scales_virtual <>= subroutine pcm_instance_nlo_set_momenta_and_scales_virtual (pcm_instance, p, & ren_scale, fac_scale) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: ren_scale, fac_scale select type (config => pcm_instance%config) type is (pcm_nlo_t) associate (virtual => pcm_instance%virtual) call virtual%set_ren_scale (p, ren_scale) call virtual%set_fac_scale (p, fac_scale) call virtual%set_ellis_sexton_scale () end associate end select end subroutine pcm_instance_nlo_set_momenta_and_scales_virtual @ %def pcm_instance_nlo_set_momenta_and_scales_virtual @ <>= procedure :: set_fac_scale => pcm_instance_nlo_set_fac_scale <>= subroutine pcm_instance_nlo_set_fac_scale (pcm_instance, fac_scale) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance real(default), intent(in) :: fac_scale pcm_instance%isr_kinematics%fac_scale = fac_scale end subroutine pcm_instance_nlo_set_fac_scale @ %def pcm_instance_nlo_set_fac_scale @ <>= procedure :: set_momenta => pcm_instance_nlo_set_momenta <>= subroutine pcm_instance_nlo_set_momenta (pcm_instance, p_born, p_real, i_phs, cms) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance type(vector4_t), dimension(:), intent(in) :: p_born, p_real integer, intent(in) :: i_phs logical, intent(in), optional :: cms logical :: yorn yorn = .false.; if (present (cms)) yorn = cms associate (kinematics => pcm_instance%real_kinematics) if (yorn) then if (.not. kinematics%p_born_cms%initialized) & call kinematics%p_born_cms%init (size (p_born), 1) if (.not. kinematics%p_real_cms%initialized) & call kinematics%p_real_cms%init (size (p_real), 1) kinematics%p_born_cms%phs_point(1)%p = p_born kinematics%p_real_cms%phs_point(i_phs)%p = p_real else if (.not. kinematics%p_born_lab%initialized) & call kinematics%p_born_lab%init (size (p_born), 1) if (.not. kinematics%p_real_lab%initialized) & call kinematics%p_real_lab%init (size (p_real), 1) kinematics%p_born_lab%phs_point(1)%p = p_born kinematics%p_real_lab%phs_point(i_phs)%p = p_real end if end associate end subroutine pcm_instance_nlo_set_momenta @ %def pcm_instance_nlo_set_momenta @ <>= procedure :: get_momenta => pcm_instance_nlo_get_momenta <>= function pcm_instance_nlo_get_momenta (pcm_instance, i_phs, born_phsp, cms) result (p) type(vector4_t), dimension(:), allocatable :: p class(pcm_instance_nlo_t), intent(in) :: pcm_instance integer, intent(in) :: i_phs logical, intent(in) :: born_phsp logical, intent(in), optional :: cms logical :: yorn yorn = .false.; if (present (cms)) yorn = cms select type (config => pcm_instance%config) type is (pcm_nlo_t) if (born_phsp) then if (yorn) then allocate (p (1 : config%region_data%n_legs_born), & source = pcm_instance%real_kinematics%p_born_cms%phs_point(1)%p) else allocate (p (1 : config%region_data%n_legs_born), & source = pcm_instance%real_kinematics%p_born_lab%phs_point(1)%p) end if else if (yorn) then allocate (p (1 : config%region_data%n_legs_real), & source = pcm_instance%real_kinematics%p_real_cms%phs_point(i_phs)%p) else allocate (p ( 1 : config%region_data%n_legs_real), & source = pcm_instance%real_kinematics%p_real_lab%phs_point(i_phs)%p) end if end if end select end function pcm_instance_nlo_get_momenta @ %def pcm_instance_nlo_get_momenta @ <>= procedure :: get_xi_max => pcm_instance_nlo_get_xi_max <>= function pcm_instance_nlo_get_xi_max (pcm_instance, alr) result (xi_max) real(default) :: xi_max class(pcm_instance_nlo_t), intent(in) :: pcm_instance integer, intent(in) :: alr integer :: i_phs i_phs = pcm_instance%real_kinematics%alr_to_i_phs (alr) xi_max = pcm_instance%real_kinematics%xi_max (i_phs) end function pcm_instance_nlo_get_xi_max @ %def pcm_instance_nlo_get_xi_max @ <>= procedure :: get_n_born => pcm_instance_nlo_get_n_born <>= function pcm_instance_nlo_get_n_born (pcm_instance) result (n_born) integer :: n_born class(pcm_instance_nlo_t), intent(in) :: pcm_instance select type (config => pcm_instance%config) type is (pcm_nlo_t) n_born = config%region_data%n_legs_born end select end function pcm_instance_nlo_get_n_born @ %def pcm_instance_nlo_get_n_born @ <>= procedure :: get_n_real => pcm_instance_nlo_get_n_real <>= function pcm_instance_nlo_get_n_real (pcm_instance) result (n_real) integer :: n_real class(pcm_instance_nlo_t), intent(in) :: pcm_instance select type (config => pcm_instance%config) type is (pcm_nlo_t) n_real = config%region_data%n_legs_real end select end function pcm_instance_nlo_get_n_real @ %def pcm_instance_nlo_get_n_real @ <>= procedure :: get_n_regions => pcm_instance_nlo_get_n_regions <>= function pcm_instance_nlo_get_n_regions (pcm_instance) result (n_regions) integer :: n_regions class(pcm_instance_nlo_t), intent(in) :: pcm_instance select type (config => pcm_instance%config) type is (pcm_nlo_t) n_regions = config%region_data%n_regions end select end function pcm_instance_nlo_get_n_regions @ %def pcm_instance_nlo_get_n_regions @ <>= procedure :: set_x_rad => pcm_instance_nlo_set_x_rad <>= subroutine pcm_instance_nlo_set_x_rad (pcm_instance, x_tot) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance real(default), intent(in), dimension(:) :: x_tot integer :: n_par n_par = size (x_tot) if (n_par < 3) then pcm_instance%real_kinematics%x_rad = zero else pcm_instance%real_kinematics%x_rad = x_tot (n_par - 2 : n_par) end if end subroutine pcm_instance_nlo_set_x_rad @ %def pcm_instance_nlo_set_x_rad @ <>= procedure :: init_virtual => pcm_instance_nlo_init_virtual <>= subroutine pcm_instance_nlo_init_virtual (pcm_instance, model) class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance class(model_data_t), intent(in) :: model type(nlo_settings_t), pointer :: settings select type (config => pcm_instance%config) type is (pcm_nlo_t) associate (region_data => config%region_data) settings => config%settings call pcm_instance%virtual%init (region_data%get_flv_states_born (), & region_data%n_in, settings, & region_data%regions(1)%nlo_correction_type, model, config%has_pdfs) end associate end select end subroutine pcm_instance_nlo_init_virtual @ %def pcm_instance_nlo_init_virtual @ <>= procedure :: disable_virtual_subtraction => pcm_instance_nlo_disable_virtual_subtraction <>= subroutine pcm_instance_nlo_disable_virtual_subtraction (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance end subroutine pcm_instance_nlo_disable_virtual_subtraction @ %def pcm_instance_nlo_disable_virtual_subtraction @ <>= procedure :: compute_sqme_virt => pcm_instance_nlo_compute_sqme_virt <>= subroutine pcm_instance_nlo_compute_sqme_virt (pcm_instance, p, & alpha_coupling, separate_alrs, sqme_virt) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: alpha_coupling logical, intent(in) :: separate_alrs real(default), dimension(:), allocatable, intent(inout) :: sqme_virt type(vector4_t), dimension(:), allocatable :: pp associate (virtual => pcm_instance%virtual) allocate (pp (size (p))) if (virtual%settings%factorization_mode == FACTORIZATION_THRESHOLD) then pp = pcm_instance%real_kinematics%p_born_onshell%get_momenta (1) else pp = p end if select type (config => pcm_instance%config) type is (pcm_nlo_t) if (separate_alrs) then allocate (sqme_virt (config%get_n_flv_born ())) else allocate (sqme_virt (1)) end if sqme_virt = zero call virtual%evaluate (config%region_data, & alpha_coupling, pp, separate_alrs, sqme_virt) end select end associate end subroutine pcm_instance_nlo_compute_sqme_virt @ %def pcm_instance_nlo_compute_sqme_virt @ <>= procedure :: compute_sqme_mismatch => pcm_instance_nlo_compute_sqme_mismatch <>= subroutine pcm_instance_nlo_compute_sqme_mismatch (pcm_instance, & alpha_s, separate_alrs, sqme_mism) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance real(default), intent(in) :: alpha_s logical, intent(in) :: separate_alrs real(default), dimension(:), allocatable, intent(inout) :: sqme_mism select type (config => pcm_instance%config) type is (pcm_nlo_t) if (separate_alrs) then allocate (sqme_mism (config%get_n_flv_born ())) else allocate (sqme_mism (1)) end if sqme_mism = zero sqme_mism = pcm_instance%soft_mismatch%evaluate (alpha_s) end select end subroutine pcm_instance_nlo_compute_sqme_mismatch @ %def pcm_instance_nlo_compute_sqme_mismatch @ <>= procedure :: compute_sqme_dglap_remnant => pcm_instance_nlo_compute_sqme_dglap_remnant <>= subroutine pcm_instance_nlo_compute_sqme_dglap_remnant (pcm_instance, & alpha_s, separate_alrs, sqme_dglap) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance real(default), intent(in) :: alpha_s logical, intent(in) :: separate_alrs real(default), dimension(:), allocatable, intent(inout) :: sqme_dglap select type (config => pcm_instance%config) type is (pcm_nlo_t) if (separate_alrs) then allocate (sqme_dglap (config%get_n_flv_born ())) else allocate (sqme_dglap (1)) end if end select sqme_dglap = zero call pcm_instance%dglap_remnant%evaluate (alpha_s, separate_alrs, sqme_dglap) end subroutine pcm_instance_nlo_compute_sqme_dglap_remnant @ %def pcm_instance_nlo_compute_sqme_dglap_remnant @ <>= procedure :: set_fixed_order_event_mode => pcm_instance_nlo_set_fixed_order_event_mode <>= subroutine pcm_instance_nlo_set_fixed_order_event_mode (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance pcm_instance%real_sub%purpose = FIXED_ORDER_EVENTS end subroutine pcm_instance_nlo_set_fixed_order_event_mode <>= procedure :: set_powheg_mode => pcm_instance_nlo_set_powheg_mode <>= subroutine pcm_instance_nlo_set_powheg_mode (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance pcm_instance%real_sub%purpose = POWHEG end subroutine pcm_instance_nlo_set_powheg_mode @ %def pcm_instance_nlo_set_fixed_order_event_mode @ %def pcm_instance_nlo_set_powheg_mode @ <>= procedure :: init_soft_mismatch => pcm_instance_nlo_init_soft_mismatch <>= subroutine pcm_instance_nlo_init_soft_mismatch (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance select type (config => pcm_instance%config) type is (pcm_nlo_t) call pcm_instance%soft_mismatch%init (config%region_data, & pcm_instance%real_kinematics, config%settings%factorization_mode) end select end subroutine pcm_instance_nlo_init_soft_mismatch @ %def pcm_instance_nlo_init_soft_mismatch @ <>= procedure :: init_dglap_remnant => pcm_instance_nlo_init_dglap_remnant <>= subroutine pcm_instance_nlo_init_dglap_remnant (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance select type (config => pcm_instance%config) type is (pcm_nlo_t) call pcm_instance%dglap_remnant%init ( & config%settings, & config%region_data%n_flv_born, & pcm_instance%isr_kinematics, & config%region_data%get_flv_states_born (), config%get_n_alr ()) end select end subroutine pcm_instance_nlo_init_dglap_remnant @ %def pcm_instance_nlo_init_dglap_remnant @ <>= procedure :: is_fixed_order_nlo_events & => pcm_instance_nlo_is_fixed_order_nlo_events <>= function pcm_instance_nlo_is_fixed_order_nlo_events (pcm_instance) result (is_nlo) logical :: is_nlo class(pcm_instance_nlo_t), intent(in) :: pcm_instance is_nlo = pcm_instance%real_sub%purpose == FIXED_ORDER_EVENTS end function pcm_instance_nlo_is_fixed_order_nlo_events @ %def pcm_instance_nlo_is_fixed_order_nlo_events @ <>= procedure :: final => pcm_instance_nlo_final <>= subroutine pcm_instance_nlo_final (pcm_instance) class(pcm_instance_nlo_t), intent(inout) :: pcm_instance call pcm_instance%real_sub%final () call pcm_instance%virtual%final () call pcm_instance%soft_mismatch%final () call pcm_instance%dglap_remnant%final () if (associated (pcm_instance%real_kinematics)) then call pcm_instance%real_kinematics%final () nullify (pcm_instance%real_kinematics) end if if (associated (pcm_instance%isr_kinematics)) then nullify (pcm_instance%isr_kinematics) end if end subroutine pcm_instance_nlo_final @ %def pcm_instance_nlo_final @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Kinematics instance} In this data type we combine all objects (instances) necessary for generating (or recovering) a kinematical configuration. The components work together as an implementation of multi-channel phase space. [[sf_chain]] is an instance of the structure-function chain. It is used both for generating kinematics and, after the proper scale has been determined, evaluating the structure function entries. [[phs]] is an instance of the phase space for the elementary process. The array [[f]] contains the products of the Jacobians that originate from parameter mappings in the structure-function chain or in the phase space. We allocate this explicitly if either [[sf_chain]] or [[phs]] are explicitly allocated, otherwise we can take over a pointer. All components are implemented as pointers to (anonymous) targets. For each component, there is a flag that tells whether this component is to be regarded as a proper component (`owned' by the object) or as a pointer. @ <<[[kinematics.f90]]>>= <> module kinematics <> use format_utils, only: write_separator use diagnostics use io_units use lorentz use physics_defs use sf_base use phs_base use interactions use mci_base use phs_fks use fks_regions use process_config use process_mci use pcm, only: pcm_instance_nlo_t use ttv_formfactors, only: m1s_to_mpole <> <> <> contains <> end module kinematics @ %def kinematics <>= public :: kinematics_t <>= type :: kinematics_t integer :: n_in = 0 integer :: n_channel = 0 integer :: selected_channel = 0 type(sf_chain_instance_t), pointer :: sf_chain => null () class(phs_t), pointer :: phs => null () real(default), dimension(:), pointer :: f => null () real(default) :: phs_factor logical :: sf_chain_allocated = .false. logical :: phs_allocated = .false. logical :: f_allocated = .false. integer :: emitter = -1 integer :: i_phs = 0 integer :: i_con = 0 logical :: only_cm_frame = .false. logical :: new_seed = .true. logical :: threshold = .false. contains <> end type kinematics_t @ %def kinematics_t @ Output. Show only those components which are marked as owned. <>= procedure :: write => kinematics_write <>= subroutine kinematics_write (object, unit) class(kinematics_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, c u = given_output_unit (unit) if (object%f_allocated) then write (u, "(1x,A)") "Flux * PHS volume:" write (u, "(2x,ES19.12)") object%phs_factor write (u, "(1x,A)") "Jacobian factors per channel:" do c = 1, size (object%f) write (u, "(3x,I0,':',1x,ES14.7)", advance="no") c, object%f(c) if (c == object%selected_channel) then write (u, "(1x,A)") "[selected]" else write (u, *) end if end do end if if (object%sf_chain_allocated) then call write_separator (u) call object%sf_chain%write (u) end if if (object%phs_allocated) then call write_separator (u) call object%phs%write (u) end if end subroutine kinematics_write @ %def kinematics_write @ Finalizer. Delete only those components which are marked as owned. <>= procedure :: final => kinematics_final <>= subroutine kinematics_final (object) class(kinematics_t), intent(inout) :: object if (object%sf_chain_allocated) then call object%sf_chain%final () deallocate (object%sf_chain) object%sf_chain_allocated = .false. end if if (object%phs_allocated) then call object%phs%final () deallocate (object%phs) object%phs_allocated = .false. end if if (object%f_allocated) then deallocate (object%f) object%f_allocated = .false. end if end subroutine kinematics_final @ %def kinematics_final @ Set the flags indicating whether the phase space shall be set up for the calculation of the real contribution. For this case, also set the emitter. <>= procedure :: set_nlo_info => kinematics_set_nlo_info <>= subroutine kinematics_set_nlo_info (k, nlo_type) class(kinematics_t), intent(inout) :: k integer, intent(in) :: nlo_type if (nlo_type == NLO_VIRTUAL) k%only_cm_frame = .true. end subroutine kinematics_set_nlo_info @ %def kinematics_set_nlo_info @ Allocate the structure-function chain instance, initialize it as a copy of the [[sf_chain]] template, and prepare it for evaluation. The [[sf_chain]] remains a target because the (usually constant) beam momenta are taken from there. <>= procedure :: init_sf_chain => kinematics_init_sf_chain <>= subroutine kinematics_init_sf_chain (k, sf_chain, config, extended_sf) class(kinematics_t), intent(inout) :: k type(sf_chain_t), intent(in), target :: sf_chain type(process_beam_config_t), intent(in) :: config logical, intent(in), optional :: extended_sf integer :: n_strfun, n_channel integer :: c k%n_in = config%data%get_n_in () n_strfun = config%n_strfun n_channel = config%n_channel allocate (k%sf_chain) k%sf_chain_allocated = .true. call k%sf_chain%init (sf_chain, n_channel) if (n_strfun /= 0) then do c = 1, n_channel call k%sf_chain%set_channel (c, config%sf_channel(c)) end do end if call k%sf_chain%link_interactions () call k%sf_chain%exchange_mask () call k%sf_chain%init_evaluators (extended_sf = extended_sf) end subroutine kinematics_init_sf_chain @ %def kinematics_init_sf_chain @ Allocate and initialize the phase-space part and the array of Jacobian factors. <>= procedure :: init_phs => kinematics_init_phs <>= subroutine kinematics_init_phs (k, config) class(kinematics_t), intent(inout) :: k class(phs_config_t), intent(in), target :: config k%n_channel = config%get_n_channel () call config%allocate_instance (k%phs) call k%phs%init (config) k%phs_allocated = .true. allocate (k%f (k%n_channel)) k%f = 0 k%f_allocated = .true. end subroutine kinematics_init_phs @ %def kinematics_init_phs @ <>= procedure :: evaluate_radiation_kinematics => kinematics_evaluate_radiation_kinematics <>= subroutine kinematics_evaluate_radiation_kinematics (k, r_in) class(kinematics_t), intent(inout) :: k real(default), intent(in), dimension(:) :: r_in select type (phs => k%phs) type is (phs_fks_t) call phs%generate_radiation_variables & (r_in(phs%n_r_born + 1 : phs%n_r_born + 3), k%threshold) call phs%compute_cms_energy () end select end subroutine kinematics_evaluate_radiation_kinematics @ %def kinematics_evaluate_radiation_kinematics @ <>= procedure :: compute_xi_ref_momenta => kinematics_compute_xi_ref_momenta <>= subroutine kinematics_compute_xi_ref_momenta (k, reg_data, nlo_type) class(kinematics_t), intent(inout) :: k type(region_data_t), intent(in) :: reg_data integer, intent(in) :: nlo_type logical :: use_contributors use_contributors = allocated (reg_data%alr_contributors) select type (phs => k%phs) type is (phs_fks_t) if (use_contributors) then call phs%compute_xi_ref_momenta (contributors = reg_data%alr_contributors) else if (k%threshold) then if (.not. is_subtraction_component (k%emitter, nlo_type)) & call phs%compute_xi_ref_momenta_threshold () else call phs%compute_xi_ref_momenta () end if end select end subroutine kinematics_compute_xi_ref_momenta @ %def kinematics_compute_xi_ref_momenta @ Generate kinematics, given a phase-space channel and a MC parameter set. The main result is the momentum array [[p]], but we also fill the momentum entries in the structure-function chain and the Jacobian-factor array [[f]]. Regarding phase space, We fill only the parameter arrays for the selected channel. <>= procedure :: compute_selected_channel => kinematics_compute_selected_channel <>= subroutine kinematics_compute_selected_channel & (k, mci_work, phs_channel, p, success) class(kinematics_t), intent(inout) :: k type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel type(vector4_t), dimension(:), intent(out) :: p logical, intent(out) :: success integer :: sf_channel k%selected_channel = phs_channel sf_channel = k%phs%config%get_sf_channel (phs_channel) call k%sf_chain%compute_kinematics (sf_channel, mci_work%get_x_strfun ()) call k%sf_chain%get_out_momenta (p(1:k%n_in)) call k%phs%set_incoming_momenta (p(1:k%n_in)) call k%phs%compute_flux () call k%phs%select_channel (phs_channel) call k%phs%evaluate_selected_channel (phs_channel, & mci_work%get_x_process ()) select type (phs => k%phs) type is (phs_fks_t) if (phs%q_defined) then call phs%get_born_momenta (p) k%phs_factor = phs%get_overall_factor () success = .true. else k%phs_factor = 0 success = .false. end if class default if (phs%q_defined) then call k%phs%get_outgoing_momenta (p(k%n_in + 1 :)) k%phs_factor = k%phs%get_overall_factor () success = .true. if (k%only_cm_frame) then if (.not. k%lab_is_cm_frame()) & call k%boost_to_cm_frame (p) end if else k%phs_factor = 0 success = .false. end if end select end subroutine kinematics_compute_selected_channel @ %def kinematics_compute_selected_channel @ Complete kinematics by filling the non-selected phase-space parameter arrays. <>= procedure :: compute_other_channels => kinematics_compute_other_channels <>= subroutine kinematics_compute_other_channels (k, mci_work, phs_channel) class(kinematics_t), intent(inout) :: k type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel integer :: c, c_sf call k%phs%evaluate_other_channels (phs_channel) do c = 1, k%n_channel c_sf = k%phs%config%get_sf_channel (c) k%f(c) = k%sf_chain%get_f (c_sf) * k%phs%get_f (c) end do end subroutine kinematics_compute_other_channels @ %def kinematics_compute_other_channels @ Just fetch the outgoing momenta of the [[sf_chain]] subobject, which become the incoming (seed) momenta of the hard interaction. This is a stripped down-version of the above which we use when recovering kinematics. Momenta are known, but no MC parameters yet. (We do not use the [[get_out_momenta]] method of the chain, since this relies on the structure-function interactions, which are not necessary filled here. We do rely on the momenta of the last evaluator in the chain, however.) <>= procedure :: get_incoming_momenta => kinematics_get_incoming_momenta <>= subroutine kinematics_get_incoming_momenta (k, p) class(kinematics_t), intent(in) :: k type(vector4_t), dimension(:), intent(out) :: p type(interaction_t), pointer :: int integer :: i int => k%sf_chain%get_out_int_ptr () do i = 1, k%n_in p(i) = int%get_momentum (k%sf_chain%get_out_i (i)) end do end subroutine kinematics_get_incoming_momenta @ %def kinematics_get_incoming_momenta @ This inverts the remainder of the above [[compute]] method. We know the momenta and recover the rest, as far as needed. If we select a channel, we can complete the inversion and reconstruct the MC parameter set. <>= procedure :: recover_mcpar => kinematics_recover_mcpar <>= subroutine kinematics_recover_mcpar (k, mci_work, phs_channel, p) class(kinematics_t), intent(inout) :: k type(mci_work_t), intent(inout) :: mci_work integer, intent(in) :: phs_channel type(vector4_t), dimension(:), intent(in) :: p integer :: c, c_sf real(default), dimension(:), allocatable :: x_sf, x_phs c = phs_channel c_sf = k%phs%config%get_sf_channel (c) k%selected_channel = c call k%sf_chain%recover_kinematics (c_sf) call k%phs%set_incoming_momenta (p(1:k%n_in)) call k%phs%compute_flux () call k%phs%set_outgoing_momenta (p(k%n_in+1:)) call k%phs%inverse () do c = 1, k%n_channel c_sf = k%phs%config%get_sf_channel (c) k%f(c) = k%sf_chain%get_f (c_sf) * k%phs%get_f (c) end do k%phs_factor = k%phs%get_overall_factor () c = phs_channel c_sf = k%phs%config%get_sf_channel (c) allocate (x_sf (k%sf_chain%config%get_n_bound ())) allocate (x_phs (k%phs%config%get_n_par ())) call k%phs%select_channel (c) call k%sf_chain%get_mcpar (c_sf, x_sf) call k%phs%get_mcpar (c, x_phs) call mci_work%set_x_strfun (x_sf) call mci_work%set_x_process (x_phs) end subroutine kinematics_recover_mcpar @ %def kinematics_recover_mcpar @ This first part of [[recover_mcpar]]: just handle the sfchain. <>= procedure :: recover_sfchain => kinematics_recover_sfchain <>= subroutine kinematics_recover_sfchain (k, channel, p) class(kinematics_t), intent(inout) :: k integer, intent(in) :: channel type(vector4_t), dimension(:), intent(in) :: p k%selected_channel = channel call k%sf_chain%recover_kinematics (channel) end subroutine kinematics_recover_sfchain @ %def kinematics_recover_sfchain @ Retrieve the MC input parameter array for a specific channel. We assume that the kinematics is complete, so this is known for all channels. <>= procedure :: get_mcpar => kinematics_get_mcpar <>= subroutine kinematics_get_mcpar (k, phs_channel, r) class(kinematics_t), intent(in) :: k integer, intent(in) :: phs_channel real(default), dimension(:), intent(out) :: r integer :: sf_channel, n_par_sf, n_par_phs sf_channel = k%phs%config%get_sf_channel (phs_channel) n_par_phs = k%phs%config%get_n_par () n_par_sf = k%sf_chain%config%get_n_bound () if (n_par_sf > 0) then call k%sf_chain%get_mcpar (sf_channel, r(1:n_par_sf)) end if if (n_par_phs > 0) then call k%phs%get_mcpar (phs_channel, r(n_par_sf+1:)) end if end subroutine kinematics_get_mcpar @ %def kinematics_get_mcpar @ Evaluate the structure function chain, assuming that kinematics is known. The status must be precisely [[SF_DONE_KINEMATICS]]. We thus avoid evaluating the chain twice via different pointers to the same target. <>= procedure :: evaluate_sf_chain => kinematics_evaluate_sf_chain <>= subroutine kinematics_evaluate_sf_chain (k, fac_scale, sf_rescale) class(kinematics_t), intent(inout) :: k real(default), intent(in) :: fac_scale class(sf_rescale_t), intent(inout), optional :: sf_rescale select case (k%sf_chain%get_status ()) case (SF_DONE_KINEMATICS) call k%sf_chain%evaluate (fac_scale, sf_rescale) end select end subroutine kinematics_evaluate_sf_chain @ %def kinematics_evaluate_sf_chain @ Recover beam momenta, i.e., return the beam momenta stored in the current [[sf_chain]] to their source. This is a side effect. <>= procedure :: return_beam_momenta => kinematics_return_beam_momenta <>= subroutine kinematics_return_beam_momenta (k) class(kinematics_t), intent(in) :: k call k%sf_chain%return_beam_momenta () end subroutine kinematics_return_beam_momenta @ %def kinematics_return_beam_momenta @ Check wether the phase space is configured in the center-of-mass frame. Relevant for using the proper momenta input for BLHA matrix elements. <>= procedure :: lab_is_cm_frame => kinematics_lab_is_cm_frame <>= function kinematics_lab_is_cm_frame (k) result (cm_frame) logical :: cm_frame class(kinematics_t), intent(in) :: k cm_frame = k%phs%config%cm_frame end function kinematics_lab_is_cm_frame @ %def kinematics_lab_is_cm_frame @ Boost to center-of-mass frame <>= procedure :: boost_to_cm_frame => kinematics_boost_to_cm_frame <>= subroutine kinematics_boost_to_cm_frame (k, p) class(kinematics_t), intent(in) :: k type(vector4_t), intent(inout), dimension(:) :: p p = inverse (k%phs%lt_cm_to_lab) * p end subroutine kinematics_boost_to_cm_frame @ %def kinematics_boost_to_cm_frame @ <>= procedure :: modify_momenta_for_subtraction => kinematics_modify_momenta_for_subtraction <>= subroutine kinematics_modify_momenta_for_subtraction (k, p_in, p_out) class(kinematics_t), intent(inout) :: k type(vector4_t), intent(in), dimension(:) :: p_in type(vector4_t), intent(out), dimension(:), allocatable :: p_out allocate (p_out (size (p_in))) if (k%threshold) then select type (phs => k%phs) type is (phs_fks_t) p_out = phs%get_onshell_projected_momenta () end select else p_out = p_in end if end subroutine kinematics_modify_momenta_for_subtraction @ %def kinematics_modify_momenta_for_subtraction @ <>= procedure :: threshold_projection => kinematics_threshold_projection <>= subroutine kinematics_threshold_projection (k, pcm_instance, nlo_type) class(kinematics_t), intent(inout) :: k type(pcm_instance_nlo_t), intent(inout) :: pcm_instance integer, intent(in) :: nlo_type real(default) :: sqrts, mtop type(lorentz_transformation_t) :: L_to_cms type(vector4_t), dimension(:), allocatable :: p_tot integer :: n_tot n_tot = k%phs%get_n_tot () allocate (p_tot (size (pcm_instance%real_kinematics%p_born_cms%phs_point(1)%p))) select type (phs => k%phs) type is (phs_fks_t) p_tot = pcm_instance%real_kinematics%p_born_cms%phs_point(1)%p class default p_tot(1 : k%n_in) = phs%p p_tot(k%n_in + 1 : n_tot) = phs%q end select sqrts = sum (p_tot (1:k%n_in))**1 mtop = m1s_to_mpole (sqrts) L_to_cms = get_boost_for_threshold_projection (p_tot, sqrts, mtop) call pcm_instance%real_kinematics%p_born_cms%set_momenta (1, p_tot) associate (p_onshell => pcm_instance%real_kinematics%p_born_onshell%phs_point(1)%p) call threshold_projection_born (mtop, L_to_cms, p_tot, p_onshell) if (debug2_active (D_THRESHOLD)) then print *, 'On-shell projected Born: ' call vector4_write_set (p_onshell) end if end associate end subroutine kinematics_threshold_projection @ %def kinematics_threshold_projection @ <>= procedure :: evaluate_radiation => kinematics_evaluate_radiation <>= subroutine kinematics_evaluate_radiation (k, p_in, p_out, success) class(kinematics_t), intent(inout) :: k type(vector4_t), intent(in), dimension(:) :: p_in type(vector4_t), intent(out), dimension(:), allocatable :: p_out logical, intent(out) :: success type(vector4_t), dimension(:), allocatable :: p_real type(vector4_t), dimension(:), allocatable :: p_born real(default) :: xi_max_offshell, xi_offshell, y_offshell, jac_rand_dummy, phi select type (phs => k%phs) type is (phs_fks_t) allocate (p_born (size (p_in))) if (k%threshold) then p_born = phs%get_onshell_projected_momenta () else p_born = p_in end if if (.not. k%phs%is_cm_frame () .and. .not. k%threshold) then p_born = inverse (k%phs%lt_cm_to_lab) * p_born end if call phs%compute_xi_max (p_born, k%threshold) if (k%emitter >= 0) then allocate (p_real (size (p_born) + 1)) allocate (p_out (size (p_born) + 1)) if (k%emitter <= k%n_in) then call phs%generate_isr (k%i_phs, p_real) else if (k%threshold) then jac_rand_dummy = 1._default call compute_y_from_emitter (phs%generator%real_kinematics%x_rad (I_Y), & phs%generator%real_kinematics%p_born_cms%get_momenta(1), & k%n_in, k%emitter, .false., phs%generator%y_max, jac_rand_dummy, & y_offshell) call phs%compute_xi_max (k%emitter, k%i_phs, y_offshell, & phs%generator%real_kinematics%p_born_cms%get_momenta(1), & xi_max_offshell) xi_offshell = xi_max_offshell * phs%generator%real_kinematics%xi_tilde phi = phs%generator%real_kinematics%phi call phs%generate_fsr (k%emitter, k%i_phs, p_real, & xi_y_phi = [xi_offshell, y_offshell, phi], no_jacobians = .true.) call phs%generator%real_kinematics%p_real_cms%set_momenta (k%i_phs, p_real) call phs%generate_fsr_threshold (k%emitter, k%i_phs, p_real) if (debug2_active (D_SUBTRACTION)) & call generate_fsr_threshold_for_other_emitters (k%emitter, k%i_phs) else if (k%i_con > 0) then call phs%generate_fsr (k%emitter, k%i_phs, p_real, k%i_con) else call phs%generate_fsr (k%emitter, k%i_phs, p_real) end if end if success = check_scalar_products (p_real) if (debug2_active (D_SUBTRACTION)) then call msg_debug2 (D_SUBTRACTION, "Real phase-space: ") call vector4_write_set (p_real) end if p_out = p_real else allocate (p_out (size (p_in))); p_out = p_in success = .true. end if end select contains subroutine generate_fsr_threshold_for_other_emitters (emitter, i_phs) integer, intent(in) :: emitter, i_phs integer :: ii_phs, this_emitter select type (phs => k%phs) type is (phs_fks_t) do ii_phs = 1, size (phs%phs_identifiers) this_emitter = phs%phs_identifiers(ii_phs)%emitter if (ii_phs /= i_phs .and. this_emitter /= emitter) & call phs%generate_fsr_threshold (this_emitter, i_phs) end do end select end subroutine end subroutine kinematics_evaluate_radiation @ %def kinematics_evaluate_radiation @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Instances} <<[[instances.f90]]>>= <> module instances <> <> use io_units use format_utils, only: write_separator use constants use diagnostics use os_interface use numeric_utils use lorentz use mci_base use particles use sm_qcd, only: qcd_t use interactions use quantum_numbers use model_data use helicities use flavors use beam_structures use variables use pdg_arrays, only: is_quark use sf_base use isr_collinear use physics_defs use process_constants use process_libraries use state_matrices use integration_results use phs_base use prc_core, only: prc_core_t, prc_core_state_t !!! We should depend less on these modules (move it to pcm_nlo_t e.g.) use phs_wood, only: phs_wood_t use phs_fks use blha_olp_interfaces, only: prc_blha_t use blha_config, only: BLHA_AMP_COLOR_C use prc_external, only: prc_external_t, prc_external_state_t use prc_threshold, only: prc_threshold_t use blha_olp_interfaces, only: blha_result_array_size use prc_openloops, only: prc_openloops_t, openloops_state_t use prc_recola, only: prc_recola_t use blha_olp_interfaces, only: blha_color_c_fill_offdiag, blha_color_c_fill_diag use ttv_formfactors, only: m1s_to_mpole !!! local modules use parton_states use process_counter use pcm_base use pcm use process_config use process_mci use process use kinematics <> <> <> <> contains <> end module instances @ %def instances @ \subsection{Term instance} A [[term_instance_t]] object contains all data that describe a term. Each process component consists of one or more distinct terms which may differ in kinematics, but whose squared transition matrices have to be added pointwise. The [[active]] flag is set when this term is connected to an active process component. Inactive terms are skipped for kinematics and evaluation. The [[k_term]] object is the instance of the kinematics setup (structure-function chain, phase space, etc.) that applies specifically to this term. In ordinary cases, it consists of straight pointers to the seed kinematics. The [[amp]] array stores the amplitude values when we get them from evaluating the associated matrix-element code. The [[int_hard]] interaction describes the elementary hard process. It receives the momenta and the amplitude entries for each sampling point. The [[isolated]] object holds the effective parton state for the elementary interaction. The amplitude entries are computed from [[int_hard]]. The [[connected]] evaluator set convolutes this scattering matrix with the beam (and possibly structure-function) density matrix. The [[checked]] flag is set once we have applied cuts on this term. The result of this is stored in the [[passed]] flag. Once the term has passed cuts, we calculate the various scale and weight expressions. <>= type :: term_instance_t type(process_term_t), pointer :: config => null () logical :: active = .false. type(kinematics_t) :: k_term complex(default), dimension(:), allocatable :: amp type(interaction_t) :: int_hard type(isolated_state_t) :: isolated type(connected_state_t) :: connected class(prc_core_state_t), allocatable :: core_state logical :: checked = .false. logical :: passed = .false. real(default) :: scale = 0 real(default) :: fac_scale = 0 real(default) :: ren_scale = 0 real(default), allocatable :: alpha_qcd_forced real(default) :: weight = 1 type(vector4_t), dimension(:), allocatable :: p_seed type(vector4_t), dimension(:), allocatable :: p_hard class(pcm_instance_t), pointer :: pcm_instance => null () integer :: nlo_type = BORN integer, dimension(:), allocatable :: same_kinematics type(qn_index_map_t) :: connected_qn_index type(qn_index_map_t) :: hard_qn_index contains <> end type term_instance_t @ %def term_instance_t @ <>= procedure :: write => term_instance_write <>= subroutine term_instance_write (term, unit, show_eff_state, testflag) class(term_instance_t), intent(in) :: term integer, intent(in), optional :: unit logical, intent(in), optional :: show_eff_state logical, intent(in), optional :: testflag integer :: u logical :: state u = given_output_unit (unit) state = .true.; if (present (show_eff_state)) state = show_eff_state if (term%active) then if (associated (term%config)) then write (u, "(1x,A,I0,A,I0,A)") "Term #", term%config%i_term, & " (component #", term%config%i_component, ")" else write (u, "(1x,A)") "Term [undefined]" end if else write (u, "(1x,A,I0,A)") "Term #", term%config%i_term, & " [inactive]" end if if (term%checked) then write (u, "(3x,A,L1)") "passed cuts = ", term%passed end if if (term%passed) then write (u, "(3x,A,ES19.12)") "overall scale = ", term%scale write (u, "(3x,A,ES19.12)") "factorization scale = ", term%fac_scale write (u, "(3x,A,ES19.12)") "renormalization scale = ", term%ren_scale if (allocated (term%alpha_qcd_forced)) then write (u, "(3x,A,ES19.12)") "alpha(QCD) forced = ", & term%alpha_qcd_forced end if write (u, "(3x,A,ES19.12)") "reweighting factor = ", term%weight end if call term%k_term%write (u) call write_separator (u) write (u, "(1x,A)") "Amplitude (transition matrix of the & &hard interaction):" call write_separator (u) call term%int_hard%basic_write (u, testflag = testflag) if (state .and. term%isolated%has_trace) then call write_separator (u) write (u, "(1x,A)") "Evaluators for the hard interaction:" call term%isolated%write (u, testflag = testflag) end if if (state .and. term%connected%has_trace) then call write_separator (u) write (u, "(1x,A)") "Evaluators for the connected process:" call term%connected%write (u, testflag = testflag) end if end subroutine term_instance_write @ %def term_instance_write @ The interactions and evaluators must be finalized. <>= procedure :: final => term_instance_final <>= subroutine term_instance_final (term) class(term_instance_t), intent(inout) :: term if (allocated (term%amp)) deallocate (term%amp) if (allocated (term%core_state)) deallocate (term%core_state) if (allocated (term%alpha_qcd_forced)) & deallocate (term%alpha_qcd_forced) if (allocated (term%p_seed)) deallocate(term%p_seed) if (allocated (term%p_hard)) deallocate (term%p_hard) call term%k_term%final () call term%connected%final () call term%isolated%final () call term%int_hard%final () term%pcm_instance => null () end subroutine term_instance_final @ %def term_instance_final @ For initialization, we make use of defined assignment for the [[interaction_t]] type. This creates a deep copy. The hard interaction (incoming momenta) is linked to the structure function instance. In the isolated state, we either set pointers to both, or we create modified copies ([[rearrange]]) as effective structure-function chain and interaction, respectively. Finally, we set up the [[subevt]] component that will be used for evaluating observables, collecting particles from the trace evaluator in the effective connected state. Their quantum numbers must be determined by following back source links and set explicitly, since they are already eliminated in that trace. The [[rearrange]] parts are still commented out; they could become relevant for a NLO algorithm. <>= procedure :: init => term_instance_init <>= subroutine term_instance_init (term, process, i_term, real_finite) class(term_instance_t), intent(inout), target :: term type(process_t), intent(in), target:: process integer, intent(in) :: i_term logical, intent(in), optional :: real_finite class(prc_core_t), pointer :: core => null () type(process_beam_config_t) :: beam_config type(interaction_t), pointer :: sf_chain_int type(interaction_t), pointer :: src_int type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in type(state_matrix_t), pointer :: state_matrix type(flavor_t), dimension(:), allocatable :: flv_int, flv_src, f_in, f_out integer :: n_in, n_vir, n_out, n_tot, n_sub integer :: i, j logical :: me_already_squared, keep_fs_flavors logical :: decrease_n_tot logical :: requires_extended_sf me_already_squared = .false. keep_fs_flavors = .false. term%config => process%get_term_ptr (i_term) term%int_hard = term%config%int core => process%get_core_term (i_term) call core%allocate_workspace (term%core_state) select type (core) class is (prc_external_t) call reduce_interaction (term%int_hard, & core%includes_polarization (), .true., .false.) me_already_squared = .true. allocate (term%amp (term%int_hard%get_n_matrix_elements ())) class default allocate (term%amp (term%config%n_allowed)) end select if (allocated (term%core_state)) then select type (core_state => term%core_state) type is (openloops_state_t) call core_state%init_threshold (process%get_model_ptr ()) end select end if term%amp = cmplx (0, 0, default) decrease_n_tot = term%nlo_type == NLO_REAL .and. & term%config%i_term_global /= term%config%i_sub if (present (real_finite)) then if (real_finite) decrease_n_tot = .false. end if if (decrease_n_tot) then allocate (term%p_seed (term%int_hard%get_n_tot () - 1)) else allocate (term%p_seed (term%int_hard%get_n_tot ())) end if allocate (term%p_hard (term%int_hard%get_n_tot ())) sf_chain_int => term%k_term%sf_chain%get_out_int_ptr () n_in = term%int_hard%get_n_in () do j = 1, n_in i = term%k_term%sf_chain%get_out_i (j) call term%int_hard%set_source_link (j, sf_chain_int, i) end do call term%isolated%init (term%k_term%sf_chain, term%int_hard) allocate (mask_in (n_in)) mask_in = term%k_term%sf_chain%get_out_mask () select type (phs => term%k_term%phs) type is (phs_wood_t) if (me_already_squared) then call term%isolated%setup_identity_trace (core, mask_in, .true., .false.) else call term%isolated%setup_square_trace (core, mask_in, term%config%col, .false.) end if type is (phs_fks_t) select case (phs%mode) case (PHS_MODE_ADDITIONAL_PARTICLE) if (me_already_squared) then call term%isolated%setup_identity_trace (core, mask_in, .true., .false.) else keep_fs_flavors = term%config%data%n_flv > 1 call term%isolated%setup_square_trace (core, mask_in, term%config%col, & keep_fs_flavors) end if case (PHS_MODE_COLLINEAR_REMNANT) if (me_already_squared) then call term%isolated%setup_identity_trace (core, mask_in, .true., .false.) else call term%isolated%setup_square_trace (core, mask_in, term%config%col, .false.) end if end select class default call term%isolated%setup_square_trace (core, mask_in, term%config%col, .false.) end select if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL .and. & term%config%i_term_global == term%config%i_sub) .or. & term%nlo_type == NLO_MISMATCH) then n_sub = term%get_n_sub () else if (term%nlo_type == NLO_DGLAP) then n_sub = n_beam_structure_int else !!! No integration of real subtraction in interactions yet n_sub = 0 end if keep_fs_flavors = keep_fs_flavors .or. me_already_squared requires_extended_sf = term%nlo_type == NLO_DGLAP .or. & (term%is_subtraction () .and. process%pcm_contains_pdfs ()) call term%connected%setup_connected_trace (term%isolated, & undo_helicities = undo_helicities (core, me_already_squared), & keep_fs_flavors = keep_fs_flavors, & extended_sf = requires_extended_sf) associate (int_eff => term%isolated%int_eff) state_matrix => int_eff%get_state_matrix_ptr () n_tot = int_eff%get_n_tot () flv_int = quantum_numbers_get_flavor & (state_matrix%get_quantum_number (1)) allocate (f_in (n_in)) f_in = flv_int(1:n_in) deallocate (flv_int) end associate n_in = term%connected%trace%get_n_in () n_vir = term%connected%trace%get_n_vir () n_out = term%connected%trace%get_n_out () allocate (f_out (n_out)) do j = 1, n_out call term%connected%trace%find_source & (n_in + n_vir + j, src_int, i) if (associated (src_int)) then state_matrix => src_int%get_state_matrix_ptr () flv_src = quantum_numbers_get_flavor & (state_matrix%get_quantum_number (1)) f_out(j) = flv_src(i) deallocate (flv_src) end if end do beam_config = process%get_beam_config () call term%connected%setup_subevt (term%isolated%sf_chain_eff, & beam_config%data%flv, f_in, f_out) call term%connected%setup_var_list & (process%get_var_list_ptr (), beam_config%data) select type (core) class is (prc_external_t) select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) associate (is_born => .not. (term%nlo_type == NLO_REAL .and. .not. term%is_subtraction ())) ! Does connected%trace never have any helicity qn? call setup_qn_index (term%connected_qn_index, term%connected%trace, pcm_instance, & n_sub = n_sub, is_born = is_born, is_polarized = .false.) call setup_qn_index (term%hard_qn_index, term%int_hard, pcm_instance, & n_sub = n_sub, is_born = is_born, is_polarized = core%includes_polarization ()) end associate class default call term%connected_qn_index%init (term%connected%trace) call term%hard_qn_index%init (term%int_hard) end select class default call term%connected_qn_index%init (term%connected%trace) call term%hard_qn_index%init (term%int_hard) end select contains function undo_helicities (core, me_squared) result (val) logical :: val class(prc_core_t), intent(in) :: core logical, intent(in) :: me_squared select type (core) class is (prc_external_t) val = me_squared .and. .not. core%includes_polarization () class default val = .false. end select end function undo_helicities subroutine reduce_interaction (int, polarized_beams, keep_fs_flavors, & keep_colors) type(interaction_t), intent(inout) :: int logical, intent(in) :: polarized_beams logical, intent(in) :: keep_fs_flavors, keep_colors type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask logical, dimension(:), allocatable :: mask_f, mask_c, mask_h integer :: n_tot, n_in n_in = int%get_n_in (); n_tot = int%get_n_tot () allocate (qn_mask (n_tot)) allocate (mask_f (n_tot), mask_c (n_tot), mask_h (n_tot)) mask_c = .not. keep_colors mask_f (1 : n_in) = .false. if (keep_fs_flavors) then mask_f (n_in + 1 : ) = .false. else mask_f (n_in + 1 : ) = .true. end if if (polarized_beams) then mask_h (1 : n_in) = .false. else mask_h (1 : n_in) = .true. end if mask_h (n_in + 1 : ) = .true. call qn_mask%init (mask_f, mask_c, mask_h) call int%reduce_state_matrix (qn_mask, keep_order = .true.) end subroutine reduce_interaction <> end subroutine term_instance_init @ %def term_instance_init @ Setup index mapping from state matrix to index pair [[i_flv]], [[i_sub]]. <>= subroutine setup_qn_index (qn_index, int, pcm_instance, n_sub, is_born, is_polarized) type(qn_index_map_t), intent(out) :: qn_index class(interaction_t), intent(in) :: int class(pcm_instance_t), intent(in) :: pcm_instance integer, intent(in) :: n_sub logical, intent(in) :: is_born logical, intent(in) :: is_polarized integer :: i type(quantum_numbers_t), dimension(:, :), allocatable :: qn_config type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel select type (config => pcm_instance%config) type is (pcm_nlo_t) qn_config = config%get_qn (is_born) end select if (is_polarized) then ! term%config%data from higher scope call setup_qn_hel (int, term%config%data, qn_hel) call qn_index%init (int, qn_config, n_sub, qn_hel) call qn_index%set_helicity_flip (.true.) else call qn_index%init (int, qn_config, n_sub) end if end subroutine setup_qn_index @ %def setup_qn_index @ Setup beam polarisation quantum numbers, iff beam polarisation is required. We retrieve the full helicity information from [[term%config%data]] and reduce the information only to the inital state. Afterwards, we uniquify the initial state polarization by a applying a index (hash) table. The helicity information is fed into an array of quantum numbers to assign flavor, helicity and subtraction indices correctly to their matrix element. <>= subroutine setup_qn_hel (int, data, qn_hel) class(interaction_t), intent(in) :: int class(process_constants_t), intent(in) :: data type(quantum_numbers_t), dimension(:, :), allocatable, intent(out) :: qn_hel type(helicity_t), dimension(:), allocatable :: hel integer, dimension(:), allocatable :: index_table integer, dimension(:, :), allocatable :: hel_state integer :: i, j, n_hel_unique associate (n_in => int%get_n_in (), n_tot => int%get_n_tot ()) allocate (hel_state (n_tot, data%get_n_hel ()), & source = data%hel_state) allocate (index_table (data%get_n_hel ()), & source = 0) forall (j=1:data%get_n_hel (), i=n_in+1:n_tot) hel_state(i, j) = 0 n_hel_unique = 0 HELICITY: do i = 1, data%get_n_hel () do j = 1, data%get_n_hel () if (index_table (j) == 0) then index_table(j) = i; n_hel_unique = n_hel_unique + 1 cycle HELICITY else if (all (hel_state(:, i) == & hel_state(:, index_table(j)))) then cycle HELICITY end if end do end do HELICITY allocate (qn_hel (n_tot, n_hel_unique)) allocate (hel (n_tot)) do j = 1, n_hel_unique call hel%init (hel_state(:, index_table(j))) call qn_hel(:, j)%init (hel) end do end associate end subroutine setup_qn_hel @ %def setup_qn_hel @ <>= procedure :: init_from_process => term_instance_init_from_process <>= subroutine term_instance_init_from_process (term_instance, & process, i, pcm_instance, sf_chain) class(term_instance_t), intent(inout), target :: term_instance type(process_t), intent(in), target :: process integer, intent(in) :: i class(pcm_instance_t), intent(in), target :: pcm_instance type(sf_chain_t), intent(in), target :: sf_chain type(process_term_t) :: term integer :: i_component logical :: requires_extended_sf term = process%get_term_ptr (i) i_component = term%i_component if (i_component /= 0) then term_instance%pcm_instance => pcm_instance term_instance%nlo_type = process%get_nlo_type_component (i_component) requires_extended_sf = term_instance%nlo_type == NLO_DGLAP .or. & (term_instance%nlo_type == NLO_REAL .and. process%get_i_sub (i) == i) call term_instance%setup_kinematics (sf_chain, & process%get_beam_config_ptr (), & process%get_phs_config (i_component), & requires_extended_sf) call term_instance%init (process, i, & real_finite = process%component_is_real_finite (i_component)) select type (phs => term_instance%k_term%phs) type is (phs_fks_t) call term_instance%set_emitter (process%get_pcm_ptr ()) call term_instance%setup_fks_kinematics (process%get_var_list_ptr (), & process%get_beam_config_ptr ()) end select call term_instance%set_threshold (process%get_pcm_ptr ()) call term_instance%setup_expressions (process%get_meta (), process%get_config ()) end if end subroutine term_instance_init_from_process @ %def term_instance_init_from_process @ Initialize the seed-kinematics configuration. All subobjects are allocated explicitly. <>= procedure :: setup_kinematics => term_instance_setup_kinematics <>= subroutine term_instance_setup_kinematics (term, sf_chain, & beam_config, phs_config, extended_sf) class(term_instance_t), intent(inout) :: term type(sf_chain_t), intent(in), target :: sf_chain type(process_beam_config_t), intent(in), target :: beam_config class(phs_config_t), intent(in), target :: phs_config logical, intent(in) :: extended_sf select type (config => term%pcm_instance%config) type is (pcm_nlo_t) call term%k_term%init_sf_chain (sf_chain, beam_config, & extended_sf = config%has_pdfs .and. extended_sf) class default call term%k_term%init_sf_chain (sf_chain, beam_config) end select !!! Add one for additional Born matrix element call term%k_term%init_phs (phs_config) call term%k_term%set_nlo_info (term%nlo_type) select type (phs => term%k_term%phs) type is (phs_fks_t) call phs%allocate_momenta (phs_config, & .not. (term%nlo_type == NLO_REAL)) select type (config => term%pcm_instance%config) type is (pcm_nlo_t) call config%region_data%init_phs_identifiers (phs%phs_identifiers) !!! The triple select type pyramid of doom select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) if (allocated (pcm_instance%real_kinematics%alr_to_i_phs)) & call config%region_data%set_alr_to_i_phs (phs%phs_identifiers, & pcm_instance%real_kinematics%alr_to_i_phs) end select end select end select end subroutine term_instance_setup_kinematics @ %def term_instance_setup_kinematics @ <>= procedure :: setup_fks_kinematics => term_instance_setup_fks_kinematics <>= subroutine term_instance_setup_fks_kinematics (term, var_list, beam_config) class(term_instance_t), intent(inout), target :: term type(var_list_t), intent(in) :: var_list type(process_beam_config_t), intent(in) :: beam_config integer :: mode logical :: singular_jacobian if (.not. (term%nlo_type == NLO_REAL .or. term%nlo_type == NLO_DGLAP .or. & term%nlo_type == NLO_MISMATCH)) return singular_jacobian = var_list%get_lval (var_str ("?powheg_use_singular_jacobian")) if (term%nlo_type == NLO_REAL) then mode = check_generator_mode (GEN_REAL_PHASE_SPACE) else if (term%nlo_type == NLO_MISMATCH) then mode = check_generator_mode (GEN_SOFT_MISMATCH) else mode = PHS_MODE_UNDEFINED end if select type (phs => term%k_term%phs) type is (phs_fks_t) select type (config => term%pcm_instance%config) type is (pcm_nlo_t) select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) call config%setup_phs_generator (pcm_instance, & phs%generator, phs%config%sqrts, mode, singular_jacobian) if (beam_config%has_structure_function ()) then pcm_instance%isr_kinematics%isr_mode = SQRTS_VAR else pcm_instance%isr_kinematics%isr_mode = SQRTS_FIXED end if call msg_debug (D_PHASESPACE, "isr_mode: ", pcm_instance%isr_kinematics%isr_mode) end select end select class default call msg_fatal ("Phase space should be an FKS phase space!") end select contains function check_generator_mode (gen_mode_default) result (gen_mode) integer :: gen_mode integer, intent(in) :: gen_mode_default select type (config => term%pcm_instance%config) type is (pcm_nlo_t) associate (settings => config%settings) if (settings%test_coll_limit .and. settings%test_anti_coll_limit) & call msg_fatal ("You cannot check the collinear and anti-collinear limit "& &"at the same time!") if (settings%test_soft_limit .and. .not. settings%test_coll_limit & .and. .not. settings%test_anti_coll_limit) then gen_mode = GEN_SOFT_LIMIT_TEST else if (.not. settings%test_soft_limit .and. settings%test_coll_limit) then gen_mode = GEN_COLL_LIMIT_TEST else if (.not. settings%test_soft_limit .and. settings%test_anti_coll_limit) then gen_mode = GEN_ANTI_COLL_LIMIT_TEST else if (settings%test_soft_limit .and. settings%test_coll_limit) then gen_mode = GEN_SOFT_COLL_LIMIT_TEST else if (settings%test_soft_limit .and. settings%test_anti_coll_limit) then gen_mode = GEN_SOFT_ANTI_COLL_LIMIT_TEST else gen_mode = gen_mode_default end if end associate end select end function check_generator_mode end subroutine term_instance_setup_fks_kinematics @ %def term_instance_setup_fks_kinematics @ Setup seed kinematics, starting from the MC parameter set given as argument. As a result, the [[k_seed]] kinematics object is evaluated (except for the structure-function matrix-element evaluation, which we postpone until we know the factorization scale), and we have a valid [[p_seed]] momentum array. <>= procedure :: compute_seed_kinematics => term_instance_compute_seed_kinematics <>= subroutine term_instance_compute_seed_kinematics & (term, mci_work, phs_channel, success) class(term_instance_t), intent(inout), target :: term type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel logical, intent(out) :: success call term%k_term%compute_selected_channel & (mci_work, phs_channel, term%p_seed, success) end subroutine term_instance_compute_seed_kinematics @ %def term_instance_compute_seed_kinematics @ <>= procedure :: evaluate_radiation_kinematics => term_instance_evaluate_radiation_kinematics <>= subroutine term_instance_evaluate_radiation_kinematics (term, x) class(term_instance_t), intent(inout) :: term real(default), dimension(:), intent(in) :: x select type (phs => term%k_term%phs) type is (phs_fks_t) if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) & call term%k_term%evaluate_radiation_kinematics (x) end select end subroutine term_instance_evaluate_radiation_kinematics @ %def term_instance_evaluate_radiation_kinematics @ <>= procedure :: compute_xi_ref_momenta => term_instance_compute_xi_ref_momenta <>= subroutine term_instance_compute_xi_ref_momenta (term) class(term_instance_t), intent(inout) :: term select type (pcm => term%pcm_instance%config) type is (pcm_nlo_t) call term%k_term%compute_xi_ref_momenta (pcm%region_data, term%nlo_type) end select end subroutine term_instance_compute_xi_ref_momenta @ %def term_instance_compute_xi_ref_momenta @ <>= procedure :: generate_fsr_in => term_instance_generate_fsr_in <>= subroutine term_instance_generate_fsr_in (term) class(term_instance_t), intent(inout) :: term select type (phs => term%k_term%phs) type is (phs_fks_t) call phs%generate_fsr_in () end select end subroutine term_instance_generate_fsr_in @ %def term_instance_generate_fsr_in @ <>= procedure :: evaluate_projections => term_instance_evaluate_projections <>= subroutine term_instance_evaluate_projections (term) class(term_instance_t), intent(inout) :: term if (term%k_term%threshold .and. term%nlo_type > BORN) then if (debug2_active (D_THRESHOLD)) & print *, 'Evaluate on-shell projection: ', & char (component_status (term%nlo_type)) select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) call term%k_term%threshold_projection (pcm_instance, term%nlo_type) end select end if end subroutine term_instance_evaluate_projections @ %def term_instance_evaluate_projections @ <>= procedure :: redo_sf_chain => term_instance_redo_sf_chain <>= subroutine term_instance_redo_sf_chain (term, mci_work, phs_channel) class(term_instance_t), intent(inout) :: term type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel real(default), dimension(:), allocatable :: x integer :: sf_channel, n real(default) :: xi, y n = size (mci_work%get_x_strfun ()) if (n > 0) then allocate (x(n)) x = mci_work%get_x_strfun () associate (k => term%k_term) sf_channel = k%phs%config%get_sf_channel (phs_channel) call k%sf_chain%compute_kinematics (sf_channel, x) deallocate (x) end associate end if end subroutine term_instance_redo_sf_chain @ %def term_instance_redo_sf_chain @ Inverse: recover missing parts of the kinematics, given a complete set of seed momenta. Select a channel and reconstruct the MC parameter set. <>= procedure :: recover_mcpar => term_instance_recover_mcpar <>= subroutine term_instance_recover_mcpar (term, mci_work, phs_channel) class(term_instance_t), intent(inout), target :: term type(mci_work_t), intent(inout) :: mci_work integer, intent(in) :: phs_channel call term%k_term%recover_mcpar (mci_work, phs_channel, term%p_seed) end subroutine term_instance_recover_mcpar @ %def term_instance_recover_mcpar @ Part of [[recover_mcpar]], separately accessible. Reconstruct all kinematics data in the structure-function chain instance. <>= procedure :: recover_sfchain => term_instance_recover_sfchain <>= subroutine term_instance_recover_sfchain (term, channel) class(term_instance_t), intent(inout), target :: term integer, intent(in) :: channel call term%k_term%recover_sfchain (channel, term%p_seed) end subroutine term_instance_recover_sfchain @ %def term_instance_recover_sfchain @ Compute the momenta in the hard interactions, one for each term that constitutes this process component. In simple cases this amounts to just copying momenta. In more advanced cases, we may generate distinct sets of momenta from the seed kinematics. The interactions in the term instances are accessed individually. We may choose to calculate all terms at once together with the seed kinematics, use [[component%core_state]] for storage, and just fill the interactions here. <>= procedure :: compute_hard_kinematics => & term_instance_compute_hard_kinematics <>= subroutine term_instance_compute_hard_kinematics (term, skip_term, success) class(term_instance_t), intent(inout) :: term integer, intent(in), optional :: skip_term logical, intent(out) :: success type(vector4_t), dimension(:), allocatable :: p if (allocated (term%core_state)) & call term%core_state%reset_new_kinematics () if (present (skip_term)) then if (term%config%i_term_global == skip_term) return end if if (term%nlo_type == NLO_REAL .and. term%k_term%emitter >= 0) then call term%k_term%evaluate_radiation (term%p_seed, p, success) select type (config => term%pcm_instance%config) type is (pcm_nlo_t) if (config%dalitz_plot%active) then if (term%k_term%emitter > term%k_term%n_in) then if (p(term%k_term%emitter)**2 > tiny_07) & call config%register_dalitz_plot (term%k_term%emitter, p) end if end if end select else if (is_subtraction_component (term%k_term%emitter, term%nlo_type)) then call term%k_term%modify_momenta_for_subtraction (term%p_seed, p) success = .true. else allocate (p (size (term%p_seed))); p = term%p_seed success = .true. end if call term%int_hard%set_momenta (p) end subroutine term_instance_compute_hard_kinematics @ %def term_instance_compute_hard_kinematics @ Here, we invert this. We fetch the incoming momenta which reside in the appropriate [[sf_chain]] object, stored within the [[k_seed]] subobject. On the other hand, we have the outgoing momenta of the effective interaction. We rely on the process core to compute the remaining seed momenta and to fill the momenta within the hard interaction. (The latter is trivial if hard and effective interaction coincide.) After this is done, the incoming momenta in the trace evaluator that corresponds to the hard (effective) interaction, are still left undefined. We remedy this by calling [[receive_kinematics]] once. <>= procedure :: recover_seed_kinematics => & term_instance_recover_seed_kinematics <>= subroutine term_instance_recover_seed_kinematics (term) class(term_instance_t), intent(inout) :: term integer :: n_in n_in = term%k_term%n_in call term%k_term%get_incoming_momenta (term%p_seed(1:n_in)) associate (int_eff => term%isolated%int_eff) call int_eff%set_momenta (term%p_seed(1:n_in), outgoing = .false.) term%p_seed(n_in + 1 : ) = int_eff%get_momenta (outgoing = .true.) end associate call term%isolated%receive_kinematics () end subroutine term_instance_recover_seed_kinematics @ %def term_instance_recover_seed_kinematics @ Compute the integration parameters for all channels except the selected one. <>= procedure :: compute_other_channels => & term_instance_compute_other_channels <>= subroutine term_instance_compute_other_channels & (term, mci_work, phs_channel) class(term_instance_t), intent(inout), target :: term type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel call term%k_term%compute_other_channels (mci_work, phs_channel) end subroutine term_instance_compute_other_channels @ %def term_instance_compute_other_channels @ Recover beam momenta, i.e., return the beam momenta as currently stored in the kinematics subobject to their source. This is a side effect. <>= procedure :: return_beam_momenta => term_instance_return_beam_momenta <>= subroutine term_instance_return_beam_momenta (term) class(term_instance_t), intent(in) :: term call term%k_term%return_beam_momenta () end subroutine term_instance_return_beam_momenta @ %def term_instance_return_beam_momenta @ <>= procedure :: apply_real_partition => term_instance_apply_real_partition <>= subroutine term_instance_apply_real_partition (term, process) class(term_instance_t), intent(inout) :: term type(process_t), intent(in) :: process real(default) :: f, sqme integer :: i_component integer :: i_amp, n_amps logical :: is_subtraction i_component = term%config%i_component if (process%component_is_selected (i_component) .and. & process%get_component_nlo_type (i_component) == NLO_REAL) then is_subtraction = process%get_component_type (i_component) == COMP_REAL_SING & .and. term%k_term%emitter < 0 if (is_subtraction) return select type (pcm => process%get_pcm_ptr ()) type is (pcm_nlo_t) f = pcm%real_partition%get_f (term%p_hard) end select n_amps = term%connected%trace%get_n_matrix_elements () do i_amp = 1, n_amps sqme = real (term%connected%trace%get_matrix_element ( & term%connected_qn_index%get_index (i_amp, i_sub = 0))) call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_apply_real_partition") select type (pcm => term%pcm_instance%config) type is (pcm_nlo_t) select case (process%get_component_type (i_component)) case (COMP_REAL_FIN, COMP_REAL_SING) select case (process%get_component_type (i_component)) case (COMP_REAL_FIN) call msg_debug2 (D_PROCESS_INTEGRATION, "Real finite") sqme = sqme * (one - f) case (COMP_REAL_SING) call msg_debug2 (D_PROCESS_INTEGRATION, "Real singular") sqme = sqme * f end select end select end select call msg_debug2 (D_PROCESS_INTEGRATION, "apply_damping: sqme", sqme) call term%connected%trace%set_matrix_element (i_amp, cmplx (sqme, zero, default)) end do end if end subroutine term_instance_apply_real_partition @ %def term_instance_apply_real_partition @ <>= procedure :: get_lorentz_transformation => term_instance_get_lorentz_transformation <>= function term_instance_get_lorentz_transformation (term) result (lt) type(lorentz_transformation_t) :: lt class(term_instance_t), intent(in) :: term lt = term%k_term%phs%get_lorentz_transformation () end function term_instance_get_lorentz_transformation @ %def term_instance_get_lorentz_transformation @ <>= procedure :: get_p_hard => term_instance_get_p_hard <>= pure function term_instance_get_p_hard (term_instance) result (p_hard) type(vector4_t), dimension(:), allocatable :: p_hard class(term_instance_t), intent(in) :: term_instance allocate (p_hard (size (term_instance%p_hard))) p_hard = term_instance%p_hard end function term_instance_get_p_hard @ %def term_instance_get_p_hard @ <>= procedure :: set_emitter => term_instance_set_emitter <>= subroutine term_instance_set_emitter (term, pcm) class(term_instance_t), intent(inout) :: term class(pcm_t), intent(in) :: pcm integer :: i_phs logical :: set_emitter select type (pcm) type is (pcm_nlo_t) !!! Without resonances, i_alr = i_phs i_phs = term%config%i_term term%k_term%i_phs = term%config%i_term select type (phs => term%k_term%phs) type is (phs_fks_t) set_emitter = i_phs <= pcm%region_data%n_phs .and. term%nlo_type == NLO_REAL if (set_emitter) then term%k_term%emitter = phs%phs_identifiers(i_phs)%emitter select type (pcm => term%pcm_instance%config) type is (pcm_nlo_t) if (allocated (pcm%region_data%i_phs_to_i_con)) & term%k_term%i_con = pcm%region_data%i_phs_to_i_con (i_phs) end select end if end select end select end subroutine term_instance_set_emitter @ %def term_instance_set_emitter @ <>= procedure :: set_threshold => term_instance_set_threshold <>= subroutine term_instance_set_threshold (term, pcm) class(term_instance_t), intent(inout) :: term class(pcm_t), intent(in) :: pcm select type (pcm) type is (pcm_nlo_t) term%k_term%threshold = pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD class default term%k_term%threshold = .false. end select end subroutine term_instance_set_threshold @ %def term_instance_set_threshold @ For initializing the expressions, we need the local variable list and the parse trees. <>= procedure :: setup_expressions => term_instance_setup_expressions <>= subroutine term_instance_setup_expressions (term, meta, config) class(term_instance_t), intent(inout), target :: term type(process_metadata_t), intent(in), target :: meta type(process_config_data_t), intent(in) :: config if (allocated (config%ef_cuts)) & call term%connected%setup_cuts (config%ef_cuts) if (allocated (config%ef_scale)) & call term%connected%setup_scale (config%ef_scale) if (allocated (config%ef_fac_scale)) & call term%connected%setup_fac_scale (config%ef_fac_scale) if (allocated (config%ef_ren_scale)) & call term%connected%setup_ren_scale (config%ef_ren_scale) if (allocated (config%ef_weight)) & call term%connected%setup_weight (config%ef_weight) end subroutine term_instance_setup_expressions @ %def term_instance_setup_expressions @ Prepare the extra evaluators that we need for processing events. The quantum numbers mask of the incoming particle <>= procedure :: setup_event_data => term_instance_setup_event_data <>= subroutine term_instance_setup_event_data (term, core, model) class(term_instance_t), intent(inout), target :: term class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model integer :: n_in type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in n_in = term%int_hard%get_n_in () allocate (mask_in (n_in)) mask_in = term%k_term%sf_chain%get_out_mask () call setup_isolated (term%isolated, core, model, mask_in, term%config%col) call setup_connected (term%connected, term%isolated, term%nlo_type) contains subroutine setup_isolated (isolated, core, model, mask, color) type(isolated_state_t), intent(inout), target :: isolated class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model type(quantum_numbers_mask_t), intent(in), dimension(:) :: mask integer, intent(in), dimension(:) :: color call isolated%setup_square_matrix (core, model, mask, color) call isolated%setup_square_flows (core, model, mask) end subroutine setup_isolated subroutine setup_connected (connected, isolated, nlo_type) type(connected_state_t), intent(inout), target :: connected type(isolated_state_t), intent(in), target :: isolated integer :: nlo_type type(quantum_numbers_mask_t), dimension(:), allocatable :: mask call connected%setup_connected_matrix (isolated) if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL & .and. term%config%i_term_global == term%config%i_sub) & .or. term%nlo_type == NLO_DGLAP) then !!! We don't care about the subtraction matrix elements in !!! connected%matrix, because all entries there are supposed !!! to be squared. To be able to match with flavor quantum numbers, !!! we remove the subtraction quantum entries from the state matrix. allocate (mask (connected%matrix%get_n_tot())) call mask%set_sub (1) call connected%matrix%reduce_state_matrix (mask, keep_order = .true.) end if call connected%setup_connected_flows (isolated) call connected%setup_state_flv (isolated%get_n_out ()) end subroutine setup_connected end subroutine term_instance_setup_event_data @ %def term_instance_setup_event_data @ Color-correlated matrix elements should be obtained from the external BLHA provider. According to the standard, the matrix elements output is a one-dimensional array. For FKS subtraction, we require the matrix $B_{ij}$. BLHA prescribes a mapping $(i, j) \to k$, where $k$ is the index of the matrix element in the output array. It focusses on the off-diagonal entries, i.e. $i \neq j$. The subroutine [[blha_color_c_fill_offdiag]] realizes this mapping. The diagonal entries can simply be obtained as the product of the Born matrix element and either $C_A$ or $C_F$, which is achieved by [[blha_color_c_fill_diag]]. For simple processes, i.e. those with only one color line, it is $B_{ij} = C_F \cdot B$. For those, we keep the possibility of computing color correlations by a multiplication of the Born matrix element with $C_F$. It is triggered by the [[use_internal_color_correlations]] flag and should be used only for testing purposes. However, it is also used for the threshold computation where the process is well-defined and fixed. <>= procedure :: evaluate_color_correlations => & term_instance_evaluate_color_correlations <>= subroutine term_instance_evaluate_color_correlations (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core integer :: i_flv_born select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) select type (config => pcm_instance%config) type is (pcm_nlo_t) call msg_debug2 (D_SUBTRACTION, & "term_instance_evaluate_color_correlations: " // & "use_internal_color_correlations:", & config%settings%use_internal_color_correlations) call msg_debug2 (D_SUBTRACTION, "fac_scale", term%fac_scale) do i_flv_born = 1, config%region_data%n_flv_born select case (term%nlo_type) case (NLO_REAL) call transfer_me_array_to_bij (config, i_flv_born, & pcm_instance%real_sub%sqme_born (i_flv_born), & pcm_instance%real_sub%sqme_born_color_c (:, :, i_flv_born)) case (NLO_MISMATCH) call transfer_me_array_to_bij (config, i_flv_born, & pcm_instance%soft_mismatch%sqme_born (i_flv_born), & pcm_instance%soft_mismatch%sqme_born_color_c (:, :, i_flv_born)) case (NLO_VIRTUAL) !!! This is just a copy of the above with a different offset and can for sure be unified call transfer_me_array_to_bij (config, i_flv_born, & -one, pcm_instance%virtual%sqme_color_c (:, :, i_flv_born)) end select end do end select end select contains function get_trivial_cf_factors (n_tot, flv, factorization_mode) result (beta_ij) integer, intent(in) :: n_tot, factorization_mode integer, intent(in), dimension(:) :: flv real(default), dimension(n_tot, n_tot) :: beta_ij if (factorization_mode == NO_FACTORIZATION) then beta_ij = get_trivial_cf_factors_default (n_tot, flv) else beta_ij = get_trivial_cf_factors_threshold (n_tot, flv) end if end function get_trivial_cf_factors function get_trivial_cf_factors_default (n_tot, flv) result (beta_ij) integer, intent(in) :: n_tot integer, intent(in), dimension(:) :: flv real(default), dimension(n_tot, n_tot) :: beta_ij integer :: i, j beta_ij = zero if (count (is_quark (flv)) == 2) then do i = 1, n_tot do j = 1, n_tot if (is_quark(flv(i)) .and. is_quark(flv(j))) then if (i == j) then beta_ij(i,j)= -cf else beta_ij(i,j) = cf end if end if end do end do end if end function get_trivial_cf_factors_default function get_trivial_cf_factors_threshold (n_tot, flv) result (beta_ij) integer, intent(in) :: n_tot integer, intent(in), dimension(:) :: flv real(default), dimension(n_tot, n_tot) :: beta_ij integer :: i beta_ij = zero do i = 1, 4 beta_ij(i,i) = -cf end do beta_ij(1,2) = cf; beta_ij(2,1) = cf beta_ij(3,4) = cf; beta_ij(4,3) = cf end function get_trivial_cf_factors_threshold subroutine transfer_me_array_to_bij (pcm, i_flv, & sqme_born, sqme_color_c) type(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_flv real(default), intent(in) :: sqme_born real(default), dimension(:,:), intent(inout) :: sqme_color_c integer :: i_color_c, i_sub, n_pdf_off, virt_off, n_offset real(default), dimension(:), allocatable :: sqme call msg_debug2 (D_PROCESS_INTEGRATION, "transfer_me_array_to_bij") if (pcm%settings%use_internal_color_correlations) then !!! A negative value for sqme_born indicates that the Born matrix !!! element is multiplied at a different place, e.g. in the case !!! of the virtual component sqme_color_c = get_trivial_cf_factors & (pcm%region_data%get_n_legs_born (), & pcm%region_data%get_flv_states_born (i_flv), & pcm%settings%factorization_mode) if (sqme_born > zero) then sqme_color_c = sqme_born * sqme_color_c else if (sqme_born == zero) then sqme_color_c = zero end if else n_offset = 0 if (term%nlo_type == NLO_VIRTUAL) then n_offset = 1 else if (pcm%has_pdfs .and. term%is_subtraction ()) then n_offset = n_beam_structure_int end if allocate (sqme (term%get_n_sub_color ()), source = zero) do i_sub = 1, term%get_n_sub_color () sqme(i_sub) = real(term%connected%trace%get_matrix_element ( & term%connected_qn_index%get_index (i_flv, i_sub = i_sub + n_offset)), default) end do call blha_color_c_fill_offdiag (pcm%region_data%n_legs_born, & sqme, sqme_color_c) call blha_color_c_fill_diag (real(term%connected%trace%get_matrix_element ( & term%connected_qn_index%get_index (i_flv, i_sub = 0)), default), & pcm%region_data%get_flv_states_born (i_flv), & sqme_color_c) end if end subroutine transfer_me_array_to_bij end subroutine term_instance_evaluate_color_correlations @ %def term_instance_evaluate_color_correlations @ <>= procedure :: evaluate_charge_correlations => & term_instance_evaluate_charge_correlations <>= subroutine term_instance_evaluate_charge_correlations (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core integer :: i_flv_born select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) select type (config => pcm_instance%config) type is (pcm_nlo_t) do i_flv_born = 1, config%region_data%n_flv_born select case (term%nlo_type) case (NLO_REAL) call transfer_me_array_to_bij (config, i_flv_born, & pcm_instance%real_sub%sqme_born (i_flv_born), & pcm_instance%real_sub%sqme_born_charge_c (:, :, i_flv_born)) case (NLO_MISMATCH) call transfer_me_array_to_bij (config, i_flv_born, & pcm_instance%soft_mismatch%sqme_born (i_flv_born), & pcm_instance%soft_mismatch%sqme_born_charge_c (:, :, i_flv_born)) case (NLO_VIRTUAL) call transfer_me_array_to_bij (config, i_flv_born, & -one, pcm_instance%virtual%sqme_charge_c (:, :, i_flv_born)) end select end do end select end select contains subroutine transfer_me_array_to_bij (pcm, i_flv, sqme_born, sqme_charge_c) type(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_flv real(default), intent(in) :: sqme_born real(default), dimension(:,:), intent(inout) :: sqme_charge_c integer :: n_legs_born, i, j integer, dimension(:), allocatable :: sigma real(default), dimension(:), allocatable :: Q n_legs_born = pcm%region_data%n_legs_born associate (flv_born => pcm%region_data%flv_born(i_flv)) allocate (sigma (n_legs_born), Q (size (flv_born%charge))) Q = flv_born%charge sigma(1:flv_born%n_in) = sign (1, flv_born%flst(1:flv_born%n_in)) sigma(flv_born%n_in + 1: ) = -sign (1, flv_born%flst(flv_born%n_in + 1: )) end associate do i = 1, n_legs_born do j = 1, n_legs_born sqme_charge_c(i, j) = sigma(i) * sigma(j) * Q(i) * Q(j) * (-one) end do end do sqme_charge_c = sqme_charge_c * sqme_born end subroutine transfer_me_array_to_bij end subroutine term_instance_evaluate_charge_correlations @ %def term_instance_evaluate_charge_correlations @ The information about spin correlations is not stored in the [[nlo_settings]] because it is only available after the [[fks_regions]] have been created. <>= procedure :: evaluate_spin_correlations => term_instance_evaluate_spin_correlations <>= subroutine term_instance_evaluate_spin_correlations (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core integer :: i_flv, i_hel, i_sub, i_emitter, emitter integer :: n_flv, n_sub_color, n_sub_spin, n_offset real(default), dimension(0:3, 0:3) :: sqme_spin_c real(default), dimension(:), allocatable :: sqme_spin_c_all real(default), dimension(:), allocatable :: sqme_spin_c_arr call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_spin_correlations") select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) if (pcm_instance%real_sub%requires_spin_correlations () & .and. term%nlo_type == NLO_REAL) then select type (core) type is (prc_openloops_t) select type (config => pcm_instance%config) type is (pcm_nlo_t) n_flv = term%connected_qn_index%get_n_flv () n_sub_color = term%get_n_sub_color () n_sub_spin = term%get_n_sub_spin () n_offset = 0; if(config%has_pdfs) n_offset = n_beam_structure_int allocate (sqme_spin_c_arr(16)) do i_flv = 1, n_flv allocate (sqme_spin_c_all(n_sub_spin)) do i_sub = 1, n_sub_spin sqme_spin_c_all(i_sub) = real(term%connected%trace%get_matrix_element & (term%connected_qn_index%get_index (i_flv, & i_sub = i_sub + n_offset + n_sub_color)), default) end do do i_emitter = 1, config%region_data%n_emitters emitter = config%region_data%emitters(i_emitter) if (emitter > 0) then call split_array (sqme_spin_c_all, sqme_spin_c_arr) sqme_spin_c = reshape (sqme_spin_c_arr, (/4,4/)) pcm_instance%real_sub%sqme_born_spin_c(:,:,emitter,i_flv) = sqme_spin_c end if end do deallocate (sqme_spin_c_all) end do end select class default call msg_fatal ("Spin correlations so far only supported by OpenLoops.") end select end if end select end subroutine term_instance_evaluate_spin_correlations @ %def term_instance_evaluate_spin_correlations @ Compute collinear ISR from interactions, real component and DLGAP remnant are handled accordingly. <>= procedure :: compute_sqme_coll_isr => term_instance_compute_sqme_coll_isr <>= subroutine term_instance_compute_sqme_coll_isr (term) class(term_instance_t), intent(in) :: term integer :: i_flv integer, parameter :: BEAM_PLUS = 1, BEAM_MINUS = 2, & PDF = 1, PDF_SINGLET = 2 select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) select type (pcm => term%pcm_instance%config) type is (pcm_nlo_t) associate (me => term%connected%trace%get_matrix_element ()) do i_flv = 1, pcm%region_data%n_flv_born call set_sqme_coll_isr (BEAM_PLUS, PDF, i_flv, & real(me(term%connected_qn_index%get_index (i_flv, i_sub = 1)))) call set_sqme_coll_isr (BEAM_MINUS, PDF, i_flv, & real(me(term%connected_qn_index%get_index (i_flv, i_sub = 2)))) if (pcm%settings%nlo_correction_type == "QCD" .or. & pcm%settings%nlo_correction_type == "Full") then call set_sqme_coll_isr (BEAM_PLUS, PDF_SINGLET, i_flv, & real(me(term%connected_qn_index%get_index (i_flv, i_sub = 3)))) call set_sqme_coll_isr (BEAM_MINUS, PDF_SINGLET, i_flv, & real(me(term%connected_qn_index%get_index (i_flv, i_sub = 4)))) end if end do end associate if (debug2_active (D_BEAMS)) then call msg_debug2 (D_BEAMS, "term_instance_compute_sqme_coll_isr") if (term%nlo_type == NLO_REAL) then print *, "nlo_type: REAL" print *, "n_flv: ", pcm%region_data%n_flv_born print *, "i_flv: ", i_flv print *, "Beam 1: " print *, " quarks: ", pcm_instance%real_sub%sqme_coll_isr (BEAM_PLUS, PDF, :) print *, " gluon: ", pcm_instance%real_sub%sqme_coll_isr (BEAM_PLUS, PDF_SINGLET, :) print *, "Beam 2: " print *, " quarks: ", pcm_instance%real_sub%sqme_coll_isr (BEAM_MINUS, PDF, :) print *, " gluon: ", pcm_instance%real_sub%sqme_coll_isr (BEAM_MINUS, PDF_SINGLET, :) else if (term%nlo_type == NLO_DGLAP) then print *, "nlo_type: DGLAP" print *, "n_flv: ", pcm%region_data%n_flv_born print *, "i_flv: ", i_flv print *, "Beam 1: " print *, " quarks: ", pcm_instance%dglap_remnant%sqme_coll_isr (BEAM_PLUS, PDF, :) print *, " gluon: ", pcm_instance%dglap_remnant%sqme_coll_isr (BEAM_PLUS, PDF_SINGLET, :) print *, "Beam 2: " print *, " quarks: ", pcm_instance%dglap_remnant%sqme_coll_isr (BEAM_MINUS, PDF, :) print *, " gluon: ", pcm_instance%dglap_remnant%sqme_coll_isr (BEAM_MINUS, PDF_SINGLET, :) end if end if end select end select contains subroutine set_sqme_coll_isr (i_beam, i_type, i_flv, me) integer, intent(in) :: i_beam, i_type, i_flv real(default), intent(in) :: me select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) select case (term%nlo_type) case (NLO_REAL) pcm_instance%real_sub%sqme_coll_isr (i_beam, i_type, i_flv) = me case (NLO_DGLAP) pcm_instance%dglap_remnant%sqme_coll_isr (i_beam, i_type, i_flv) = me end select end select end subroutine set_sqme_coll_isr end subroutine term_instance_compute_sqme_coll_isr @ %def term_instance_compute_sqme_coll_isr @ <>= procedure :: apply_fks => term_instance_apply_fks <>= subroutine term_instance_apply_fks (term, alpha_s_sub, alpha_qed_sub) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_s_sub, alpha_qed_sub real(default), dimension(:), allocatable :: sqme integer :: i, i_phs, emitter logical :: is_subtraction select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) select type (config => pcm_instance%config) type is (pcm_nlo_t) if (term%connected%has_matrix) then allocate (sqme (config%get_n_alr ())) else allocate (sqme (1)) end if sqme = zero select type (phs => term%k_term%phs) type is (phs_fks_t) call pcm_instance%set_real_and_isr_kinematics & (phs%phs_identifiers, term%k_term%phs%get_sqrts ()) if (term%k_term%emitter < 0) then call pcm_instance%set_subtraction_event () do i_phs = 1, config%region_data%n_phs emitter = phs%phs_identifiers(i_phs)%emitter call pcm_instance%real_sub%compute (emitter, & i_phs, alpha_s_sub, alpha_qed_sub, term%connected%has_matrix, sqme) end do else call pcm_instance%set_radiation_event () emitter = term%k_term%emitter; i_phs = term%k_term%i_phs do i = 1, term%connected_qn_index%get_n_flv () pcm_instance%real_sub%sqme_real_non_sub (i, i_phs) = & real (term%connected%trace%get_matrix_element ( & term%connected_qn_index%get_index (i))) end do call pcm_instance%real_sub%compute (emitter, i_phs, alpha_s_sub, & alpha_qed_sub, term%connected%has_matrix, sqme) end if end select end select end select if (term%connected%has_trace) & call term%connected%trace%set_only_matrix_element & (1, cmplx (sum(sqme), 0, default)) select type (config => term%pcm_instance%config) type is (pcm_nlo_t) is_subtraction = term%k_term%emitter < 0 if (term%connected%has_matrix) & call refill_evaluator (cmplx (sqme, 0, default), & config%get_qn (is_subtraction), & config%region_data%get_flavor_indices (is_subtraction), & term%connected%matrix) if (term%connected%has_flows) & call refill_evaluator (cmplx (sqme, 0, default), & config%get_qn (is_subtraction), & config%region_data%get_flavor_indices (is_subtraction), & term%connected%flows) end select end subroutine term_instance_apply_fks @ %def term_instance_apply_fks @ <>= procedure :: evaluate_sqme_virt => term_instance_evaluate_sqme_virt <>= subroutine term_instance_evaluate_sqme_virt (term, alpha_s, alpha_qed) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_s, alpha_qed real(default) :: alpha_coupling type(vector4_t), dimension(:), allocatable :: p_born real(default), dimension(:), allocatable :: sqme_virt integer :: i_flv if (term%nlo_type /= NLO_VIRTUAL) call msg_fatal & ("Trying to evaluate virtual matrix element with unsuited term_instance.") if (debug2_active (D_VIRTUAL)) then call msg_debug2 (D_VIRTUAL, "Evaluating virtual-subtracted matrix elements") print *, 'ren_scale: ', term%ren_scale print *, 'fac_scale: ', term%fac_scale end if select type (config => term%pcm_instance%config) type is (pcm_nlo_t) select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) associate (nlo_corr_type => config%region_data%regions(1)%nlo_correction_type) if (nlo_corr_type == "QCD") then alpha_coupling = alpha_s if (debug2_active (D_VIRTUAL)) print *, 'alpha_s: ', alpha_coupling else if (nlo_corr_type == "QED") then alpha_coupling = alpha_qed if (debug2_active (D_VIRTUAL)) print *, 'alpha_qed: ', alpha_coupling end if end associate allocate (p_born (config%region_data%n_legs_born)) if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) then p_born = pcm_instance%real_kinematics%p_born_onshell%get_momenta(1) else p_born = term%int_hard%get_momenta () end if call pcm_instance%set_momenta_and_scales_virtual & (p_born, term%ren_scale, term%fac_scale) select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) associate (virtual => pcm_instance%virtual) do i_flv = 1, term%connected_qn_index%get_n_flv () virtual%sqme_born(i_flv) = & real (term%connected%trace%get_matrix_element ( & term%connected_qn_index%get_index (i_flv, i_sub = 0))) virtual%sqme_virt_fin(i_flv) = & real (term%connected%trace%get_matrix_element ( & term%connected_qn_index%get_index (i_flv, i_sub = 1))) end do end associate end select call pcm_instance%compute_sqme_virt (term%p_hard, alpha_coupling, & term%connected%has_matrix, sqme_virt) call term%connected%trace%set_only_matrix_element & (1, cmplx (sum(sqme_virt) * term%weight, 0, default)) if (term%connected%has_matrix) then call refill_evaluator (cmplx (sqme_virt * term%weight, 0, default), & config%get_qn (.true.), & config%region_data%get_flavor_indices (.true.), & term%connected%matrix) end if end select end select end subroutine term_instance_evaluate_sqme_virt @ %def term_instance_evaluate_sqme_virt @ <>= procedure :: evaluate_sqme_mismatch => term_instance_evaluate_sqme_mismatch <>= subroutine term_instance_evaluate_sqme_mismatch (term, alpha_s) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_s real(default), dimension(:), allocatable :: sqme_mism if (term%nlo_type /= NLO_MISMATCH) call msg_fatal & ("Trying to evaluate soft mismatch with unsuited term_instance.") select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) call pcm_instance%compute_sqme_mismatch & (alpha_s, term%connected%has_matrix, sqme_mism) end select call term%connected%trace%set_only_matrix_element & (1, cmplx (sum (sqme_mism) * term%weight, 0, default)) if (term%connected%has_matrix) then select type (config => term%pcm_instance%config) type is (pcm_nlo_t) call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), & config%get_qn (.true.), config%region_data%get_flavor_indices (.true.), & term%connected%matrix) end select end if end subroutine term_instance_evaluate_sqme_mismatch @ %def term_instance_evaluate_sqme_mismatch @ <>= procedure :: evaluate_sqme_dglap => term_instance_evaluate_sqme_dglap <>= subroutine term_instance_evaluate_sqme_dglap (term, alpha_s) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_s real(default), dimension(:), allocatable :: sqme_dglap integer :: i_flv if (term%nlo_type /= NLO_DGLAP) call msg_fatal & ("Trying to evaluate DGLAP remnant with unsuited term_instance.") call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_evaluate_sqme_dglap") select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) if (debug2_active (D_PROCESS_INTEGRATION)) then associate (n_flv => pcm_instance%dglap_remnant%n_flv) print *, "size(sqme_born) = ", size (pcm_instance%dglap_remnant%sqme_born) call term%connected%trace%write () do i_flv = 1, n_flv print *, "i_flv = ", i_flv, ", n_flv = ", n_flv print *, "sqme_born(i_flv) = ", pcm_instance%dglap_remnant%sqme_born(i_flv) end do end associate end if call pcm_instance%compute_sqme_dglap_remnant (alpha_s, & term%connected%has_matrix, sqme_dglap) end select call term%connected%trace%set_only_matrix_element & (1, cmplx (sum (sqme_dglap) * term%weight, 0, default)) if (term%connected%has_matrix) then select type (config => term%pcm_instance%config) type is (pcm_nlo_t) call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), & config%get_qn (.true.), & config%region_data%get_flavor_indices (.true.), & term%connected%matrix) end select end if end subroutine term_instance_evaluate_sqme_dglap @ %def term_instance_evaluate_sqme_dglap @ Reset the term instance: clear the parton-state expressions and deactivate. <>= procedure :: reset => term_instance_reset <>= subroutine term_instance_reset (term) class(term_instance_t), intent(inout) :: term call term%connected%reset_expressions () if (allocated (term%alpha_qcd_forced)) deallocate (term%alpha_qcd_forced) term%active = .false. end subroutine term_instance_reset @ %def term_instance_reset @ Force an $\alpha_s$ value that should be used in the matrix-element calculation. <>= procedure :: set_alpha_qcd_forced => term_instance_set_alpha_qcd_forced <>= subroutine term_instance_set_alpha_qcd_forced (term, alpha_qcd) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_qcd if (allocated (term%alpha_qcd_forced)) then term%alpha_qcd_forced = alpha_qcd else allocate (term%alpha_qcd_forced, source = alpha_qcd) end if end subroutine term_instance_set_alpha_qcd_forced @ %def term_instance_set_alpha_qcd_forced @ Complete the kinematics computation for the effective parton states. We assume that the [[compute_hard_kinematics]] method of the process component instance has already been called, so the [[int_hard]] contains the correct hard kinematics. The duty of this procedure is first to compute the effective kinematics and store this in the [[int_eff]] effective interaction inside the [[isolated]] parton state. The effective kinematics may differ from the kinematics in the hard interaction. It may involve parton recombination or parton splitting. The [[rearrange_partons]] method is responsible for this part. We may also call a method to compute the effective structure-function chain at this point. This is not implemented yet. In the simple case that no rearrangement is necessary, as indicated by the [[rearrange]] flag, the effective interaction is a pointer to the hard interaction, and we can skip the rearrangement method. Similarly for the effective structure-function chain. (If we have an algorithm that uses rarrangement, it should evaluate [[k_term]] explicitly.) The final step of kinematics setup is to transfer the effective kinematics to the evaluators and to the [[subevt]]. <>= procedure :: compute_eff_kinematics => & term_instance_compute_eff_kinematics <>= subroutine term_instance_compute_eff_kinematics (term) class(term_instance_t), intent(inout) :: term term%checked = .false. term%passed = .false. call term%isolated%receive_kinematics () call term%connected%receive_kinematics () end subroutine term_instance_compute_eff_kinematics @ %def term_instance_compute_eff_kinematics @ Inverse. Reconstruct the connected state from the momenta in the trace evaluator (which we assume to be set), then reconstruct the isolated state as far as possible. The second part finalizes the momentum configuration, using the incoming seed momenta <>= procedure :: recover_hard_kinematics => & term_instance_recover_hard_kinematics <>= subroutine term_instance_recover_hard_kinematics (term) class(term_instance_t), intent(inout) :: term term%checked = .false. term%passed = .false. call term%connected%send_kinematics () call term%isolated%send_kinematics () end subroutine term_instance_recover_hard_kinematics @ %def term_instance_recover_hard_kinematics @ Check the term whether it passes cuts and, if successful, evaluate scales and weights. The factorization scale is also given to the term kinematics, enabling structure-function evaluation. <>= procedure :: evaluate_expressions => & term_instance_evaluate_expressions <>= subroutine term_instance_evaluate_expressions (term, scale_forced) class(term_instance_t), intent(inout) :: term real(default), intent(in), allocatable, optional :: scale_forced call term%connected%evaluate_expressions (term%passed, & term%scale, term%fac_scale, term%ren_scale, term%weight, & scale_forced, force_evaluation = .true.) term%checked = .true. end subroutine term_instance_evaluate_expressions @ %def term_instance_evaluate_expressions @ Evaluate the trace: first evaluate the hard interaction, then the trace evaluator. We use the [[evaluate_interaction]] method of the process component which generated this term. The [[subevt]] and cut expressions are not yet filled. The [[component]] argument is intent(inout) because the [[compute_amplitude]] method may modify the [[core_state]] workspace object. <>= procedure :: evaluate_interaction => term_instance_evaluate_interaction <>= subroutine term_instance_evaluate_interaction (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in), pointer :: core call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_interaction") term%p_hard = term%int_hard%get_momenta () select type (core) class is (prc_external_t) call term%evaluate_interaction_userdef (core) class default call term%evaluate_interaction_default (core) end select call term%int_hard%set_matrix_element (term%amp) end subroutine term_instance_evaluate_interaction @ %def term_instance_evaluate_interaction @ <>= procedure :: evaluate_interaction_default & => term_instance_evaluate_interaction_default <>= subroutine term_instance_evaluate_interaction_default (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in) :: core integer :: i do i = 1, term%config%n_allowed term%amp(i) = core%compute_amplitude (term%config%i_term, term%p_hard, & term%config%flv(i), term%config%hel(i), term%config%col(i), & term%fac_scale, term%ren_scale, term%alpha_qcd_forced, & term%core_state) end do select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) call pcm_instance%set_fac_scale (term%fac_scale) end select end subroutine term_instance_evaluate_interaction_default @ %def term_instance_evaluate_interaction_default @ <>= procedure :: evaluate_interaction_userdef & => term_instance_evaluate_interaction_userdef <>= subroutine term_instance_evaluate_interaction_userdef (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_interaction_userdef") select type (core_state => term%core_state) type is (openloops_state_t) select type (core) type is (prc_openloops_t) call core%compute_alpha_s (core_state, term%ren_scale) if (allocated (core_state%threshold_data)) & call evaluate_threshold_parameters (core_state, core, term%k_term%phs%get_sqrts ()) end select class is (prc_external_state_t) select type (core) class is (prc_external_t) call core%compute_alpha_s (core_state, term%ren_scale) end select end select call evaluate_threshold_interaction () if (term%nlo_type == NLO_VIRTUAL) then call term%evaluate_interaction_userdef_loop (core) else call term%evaluate_interaction_userdef_tree (core) end if select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) call pcm_instance%set_fac_scale (term%fac_scale) end select contains subroutine evaluate_threshold_parameters (core_state, core, sqrts) type(openloops_state_t), intent(inout) :: core_state type(prc_openloops_t), intent(inout) :: core real(default), intent(in) :: sqrts real(default) :: mtop, wtop mtop = m1s_to_mpole (sqrts) wtop = core_state%threshold_data%compute_top_width & (mtop, core_state%alpha_qcd) call core%set_mass_and_width (6, mtop, wtop) end subroutine subroutine evaluate_threshold_interaction () integer :: leg select type (core) type is (prc_threshold_t) if (term%nlo_type > BORN) then select type (pcm => term%pcm_instance) type is (pcm_instance_nlo_t) if (term%k_term%emitter >= 0) then call core%set_offshell_momenta & (pcm%real_kinematics%p_real_cms%get_momenta(term%config%i_term)) leg = thr_leg (term%k_term%emitter) call core%set_leg (leg) call core%set_onshell_momenta & (pcm%real_kinematics%p_real_onshell(leg)%get_momenta(term%config%i_term)) else call core%set_leg (0) call core%set_offshell_momenta & (pcm%real_kinematics%p_born_cms%get_momenta(1)) end if end select else call core%set_leg (-1) call core%set_offshell_momenta (term%p_hard) end if end select end subroutine evaluate_threshold_interaction end subroutine term_instance_evaluate_interaction_userdef @ %def term_instance_evaluate_interaction_userdef @ Retrieve the matrix elements from a matrix element provider and place them into [[term%amp]]. For the handling of NLO calculations, FKS applies a book keeping handling flavor and/or particle type (e.g. for QCD: quark/gluon and quark flavor) in order to calculate the subtraction terms. Therefore, we have to insert the calculated matrix elements correctly into the state matrix where each entry corresponds to a set of quantum numbers. We apply a mapping [[hard_qn_ind]] from a list of quantum numbers provided by FKS to the hard process [[int_hard]]. The calculated matrix elements are insert into [[term%amp]] in the following way. The first [[n_born]] particles are the matrix element of the hard process. In non-trivial beams, we store another [[n_beam_structure_int]] copies of these matrix elements as the first [[n_beam_structure_int]] subtractions. The next $n_{\text{born}}\times n_{sub}$ are color-correlated born matrix elements. <>= procedure :: evaluate_interaction_userdef_tree & => term_instance_evaluate_interaction_userdef_tree <>= subroutine term_instance_evaluate_interaction_userdef_tree (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core real(default) :: sqme real(default), dimension(:), allocatable :: sqme_color_c real(default), dimension(:), allocatable :: sqme_spin_c real(default), dimension(16) :: sqme_spin_c_tmp integer :: n_flv, n_hel, n_sub_color, n_sub_spin, n_pdf_off integer :: i_flv, i_hel, i_sub, i_color_c, i_spin_c, i_emitter integer :: emitter logical :: bad_point, bp call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_interaction_userdef_tree") allocate (sqme_color_c (blha_result_array_size & (term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C))) n_flv = term%hard_qn_index%get_n_flv () n_hel = term%hard_qn_index%get_n_hel () n_sub_color = term%get_n_sub_color () n_sub_spin = term%get_n_sub_spin () do i_flv = 1, n_flv do i_hel = 1, n_hel select type (core) class is (prc_external_t) call core%update_alpha_s (term%core_state, term%ren_scale) call core%compute_sqme (i_flv, i_hel, term%p_hard, term%ren_scale, & sqme, bad_point) call term%pcm_instance%set_bad_point (bad_point) associate (i_int => term%hard_qn_index%get_index (i_flv = i_flv, i_hel = i_hel, i_sub = 0)) term%amp(i_int) = cmplx (sqme, 0, default) end associate end select n_pdf_off = 0 if (term%pcm_instance%config%has_pdfs .and. & (term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then n_pdf_off = n_pdf_off + n_beam_structure_int do i_sub = 1, n_pdf_off term%amp(term%hard_qn_index%get_index (i_flv, i_hel, i_sub)) = & term%amp(term%hard_qn_index%get_index (i_flv, i_hel, i_sub = 0)) end do end if if ((term%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. & term%nlo_type == NLO_MISMATCH) then sqme_color_c = zero select type (core) class is (prc_blha_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%ren_scale, sqme_color_c, bad_point) call term%pcm_instance%set_bad_point (bad_point) class is (prc_recola_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%ren_scale, sqme_color_c, bad_point) call term%pcm_instance%set_bad_point (bad_point) end select do i_sub = 1, n_sub_color i_color_c = term%hard_qn_index%get_index & (i_flv, i_hel, i_sub + n_pdf_off) term%amp(i_color_c) = cmplx (sqme_color_c(i_sub), 0, default) end do if (n_sub_spin > 0) then bad_point = .false. allocate (sqme_spin_c(0)) select type (core) type is (prc_openloops_t) select type (config => term%pcm_instance%config) type is (pcm_nlo_t) do i_emitter = 1, config%region_data%n_emitters emitter = config%region_data%emitters(i_emitter) if (emitter > 0) then call core%compute_sqme_spin_c & (i_flv, & i_hel, & emitter, & term%p_hard, & term%ren_scale, & sqme_spin_c_tmp, & bp) sqme_spin_c = [sqme_spin_c, sqme_spin_c_tmp] bad_point = bad_point .or. bp end if end do end select do i_sub = 1, n_sub_spin i_spin_c = term%hard_qn_index%get_index (i_flv, i_hel, & i_sub + n_pdf_off + n_sub_color) term%amp(i_spin_c) = cmplx & (sqme_spin_c(i_sub), 0, default) end do end select deallocate (sqme_spin_c) end if end if end do end do end subroutine term_instance_evaluate_interaction_userdef_tree @ %def term_instance_evaluate_interaction_userdef_tree @ <>= procedure :: evaluate_interaction_userdef_loop & => term_instance_evaluate_interaction_userdef_loop <>= subroutine term_instance_evaluate_interaction_userdef_loop (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in) :: core integer :: n_hel, n_sub, n_flv integer :: i, i_flv, i_hel, i_sub, i_virt, i_color_c real(default), dimension(4) :: sqme_virt real(default), dimension(:), allocatable :: sqme_color_c logical :: bad_point call msg_debug (D_PROCESS_INTEGRATION, & "term_instance_evaluate_interaction_userdef_loop") allocate (sqme_color_c (blha_result_array_size & (term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C))) n_flv = term%hard_qn_index%get_n_flv () n_hel = term%hard_qn_index%get_n_hel () n_sub = term%hard_qn_index%get_n_sub () i_virt = 1 do i_flv = 1, n_flv do i_hel = 1, n_hel select type (core) class is (prc_external_t) call core%compute_sqme_virt (i_flv, i_hel, term%p_hard, & term%ren_scale, sqme_virt, bad_point) call term%pcm_instance%set_bad_point (bad_point) end select associate (i_born => term%hard_qn_index%get_index (i_flv, i_hel = i_hel, i_sub = 0), & i_loop => term%hard_qn_index%get_index (i_flv, i_hel = i_hel, i_sub = i_virt)) term%amp(i_loop) = cmplx (sqme_virt(3), 0, default) term%amp(i_born) = cmplx (sqme_virt(4), 0, default) end associate select type (config => term%pcm_instance%config) type is (pcm_nlo_t) select type (core) class is (prc_blha_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%ren_scale, & sqme_color_c, bad_point) call term%pcm_instance%set_bad_point (bad_point) do i_sub = 1 + i_virt, n_sub i_color_c = term%hard_qn_index%get_index & (i_flv, i_hel = i_hel, i_sub = i_sub) ! Index shift: i_sub - i_virt term%amp(i_color_c) = & cmplx (sqme_color_c(i_sub - i_virt), 0, default) end do type is (prc_recola_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%ren_scale, sqme_color_c, bad_point) call term%pcm_instance%set_bad_point (bad_point) do i_sub = 1 + i_virt, n_sub i_color_c = term%hard_qn_index%get_index & (i_flv, i_hel = i_hel, i_sub = i_sub) ! Index shift: i_sub - i_virt term%amp(i_color_c) = & cmplx (sqme_color_c(i_sub - i_virt), 0, default) end do end select end select end do end do end subroutine term_instance_evaluate_interaction_userdef_loop @ %def term_instance_evaluate_interaction_userdef_loop @ Evaluate the trace. First evaluate the structure-function chain (i.e., the density matrix of the incoming partons). Do this twice, in case the sf-chain instances within [[k_term]] and [[isolated]] differ. Next, evaluate the hard interaction, then compute the convolution with the initial state. <>= procedure :: evaluate_trace => term_instance_evaluate_trace <>= subroutine term_instance_evaluate_trace (term) class(term_instance_t), intent(inout) :: term class(sf_rescale_t), allocatable :: func call term%k_term%evaluate_sf_chain (term%fac_scale) call term%evaluate_scaled_sf_chains () call term%isolated%evaluate_sf_chain (term%fac_scale) call term%isolated%evaluate_trace () call term%connected%evaluate_trace () end subroutine term_instance_evaluate_trace @ %def term_instance_evaluate_trace @ Include rescaled structure functions due to NLO calculation. We rescale the structure function for the real subtraction [[sf_rescale_collinear]], the collinear counter terms [[sf_rescale_dglap_t]] and for the case, we have an emitter in the initial state, rescale the kinematics for it using [[sf_rescale_real_t]]. References: arXiv:0709.2092, (2.35)-(2.42). +Obviously, it is completely irrelevant, which beam is treated. +It becomes problematic when handling [[e, p]]-beams. <>= procedure :: evaluate_scaled_sf_chains => term_instance_evaluate_scaled_sf_chains <>= subroutine term_instance_evaluate_scaled_sf_chains (term) class(term_instance_t), intent(inout) :: term class(sf_rescale_t), allocatable :: func integer :: i_sub if (.not. term%pcm_instance%config%has_pdfs) return if (term%nlo_type == NLO_REAL) then if (term%is_subtraction ()) then allocate (sf_rescale_collinear_t :: func) select type (pcm => term%pcm_instance) type is (pcm_instance_nlo_t) select type (func) type is (sf_rescale_collinear_t) call func%set (pcm%real_kinematics%xi_tilde) call func%set_gluons (.true.) end select end select call term%k_term%sf_chain%evaluate (term%fac_scale, func) deallocate (func) else if (term%k_term%emitter >= 0 .and. term%k_term%emitter <= term%k_term%n_in) then allocate (sf_rescale_real_t :: func) select type (pcm => term%pcm_instance) type is (pcm_instance_nlo_t) select type (func) type is (sf_rescale_real_t) call func%set (pcm%real_kinematics%xi_tilde * & pcm%real_kinematics%xi_max (term%k_term%i_phs), & pcm%real_kinematics%y (term%k_term%i_phs)) - ! TODO sbrass Obviously, it is completely irrelevant, - ! TODO sbrass which beam is treated for hadronic beams. It becomes - ! TODO sbrass problematic when handling "e, p"-beams. call func%restrict_to_beam (term%k_term%emitter) end select end select call term%k_term%sf_chain%evaluate (term%fac_scale, func) deallocate (func) else call term%k_term%sf_chain%evaluate (term%fac_scale) end if else if (term%nlo_type == NLO_DGLAP) then allocate (sf_rescale_dglap_t :: func) select type (pcm => term%pcm_instance) type is (pcm_instance_nlo_t) select type (func) type is (sf_rescale_dglap_t) call func%set (pcm%isr_kinematics%z) call func%set_gluons (.true.) end select end select call term%k_term%sf_chain%evaluate (term%fac_scale, func) deallocate (func) end if end subroutine term_instance_evaluate_scaled_sf_chains @ %def term_instance_evaluate_scaled_sf_chains @ Evaluate the extra data that we need for processing the object as a physical event. <>= procedure :: evaluate_event_data => term_instance_evaluate_event_data <>= subroutine term_instance_evaluate_event_data (term) class(term_instance_t), intent(inout) :: term logical :: only_momenta only_momenta = term%nlo_type > BORN call term%isolated%evaluate_event_data (only_momenta) call term%connected%evaluate_event_data (only_momenta) end subroutine term_instance_evaluate_event_data @ %def term_instance_evaluate_event_data @ <>= procedure :: set_fac_scale => term_instance_set_fac_scale <>= subroutine term_instance_set_fac_scale (term, fac_scale) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: fac_scale term%fac_scale = fac_scale end subroutine term_instance_set_fac_scale @ %def term_instance_set_fac_scale @ Return data that might be useful for external processing. The factorization scale: <>= procedure :: get_fac_scale => term_instance_get_fac_scale <>= function term_instance_get_fac_scale (term) result (fac_scale) class(term_instance_t), intent(in) :: term real(default) :: fac_scale fac_scale = term%fac_scale end function term_instance_get_fac_scale @ %def term_instance_get_fac_scale @ We take the strong coupling from the process core. The value is calculated when a new event is requested, so we should call it only after the event has been evaluated. If it is not available there (a negative number is returned), we take the value stored in the term configuration, which should be determined by the model. If the model does not provide a value, the result is zero. <>= procedure :: get_alpha_s => term_instance_get_alpha_s <>= function term_instance_get_alpha_s (term, core) result (alpha_s) class(term_instance_t), intent(in) :: term class(prc_core_t), intent(in) :: core real(default) :: alpha_s alpha_s = core%get_alpha_s (term%core_state) if (alpha_s < zero) alpha_s = term%config%alpha_s end function term_instance_get_alpha_s @ %def term_instance_get_alpha_s @ <>= procedure :: reset_phs_identifiers => term_instance_reset_phs_identifiers <>= subroutine term_instance_reset_phs_identifiers (term) class(term_instance_t), intent(inout) :: term select type (phs => term%k_term%phs) type is (phs_fks_t) phs%phs_identifiers%evaluated = .false. end select end subroutine term_instance_reset_phs_identifiers @ %def term_instance_reset_phs_identifiers @ The second helicity for [[helicities]] comes with a minus sign because OpenLoops inverts the helicity index of antiparticles. <>= procedure :: get_helicities_for_openloops => term_instance_get_helicities_for_openloops <>= subroutine term_instance_get_helicities_for_openloops (term, helicities) class(term_instance_t), intent(in) :: term integer, dimension(:,:), allocatable, intent(out) :: helicities type(helicity_t), dimension(:), allocatable :: hel type(quantum_numbers_t), dimension(:,:), allocatable :: qn type(quantum_numbers_mask_t) :: qn_mask integer :: h, i, j, n_in call qn_mask%set_sub (1) call term%isolated%trace%get_quantum_numbers_mask (qn_mask, qn) n_in = term%int_hard%get_n_in () allocate (helicities (size (qn, dim=1), n_in)) allocate (hel (n_in)) do i = 1, size (qn, dim=1) do j = 1, n_in hel(j) = qn(i, j)%get_helicity () call hel(j)%diagonalize () call hel(j)%get_indices (h, h) helicities (i, j) = h end do end do end subroutine term_instance_get_helicities_for_openloops @ %def term_instance_get_helicities_for_openloops @ <>= procedure :: get_boost_to_lab => term_instance_get_boost_to_lab <>= function term_instance_get_boost_to_lab (term) result (lt) type(lorentz_transformation_t) :: lt class(term_instance_t), intent(in) :: term lt = term%k_term%phs%get_lorentz_transformation () end function term_instance_get_boost_to_lab @ %def term_instance_get_boost_to_lab @ <>= procedure :: get_boost_to_cms => term_instance_get_boost_to_cms <>= function term_instance_get_boost_to_cms (term) result (lt) type(lorentz_transformation_t) :: lt class(term_instance_t), intent(in) :: term lt = inverse (term%k_term%phs%get_lorentz_transformation ()) end function term_instance_get_boost_to_cms @ %def term_instance_get_boost_to_cms @ <>= procedure :: get_i_term_global => term_instance_get_i_term_global <>= elemental function term_instance_get_i_term_global (term) result (i_term) integer :: i_term class(term_instance_t), intent(in) :: term i_term = term%config%i_term_global end function term_instance_get_i_term_global @ %def term_instance_get_i_term_global @ <>= procedure :: is_subtraction => term_instance_is_subtraction <>= elemental function term_instance_is_subtraction (term) result (sub) logical :: sub class(term_instance_t), intent(in) :: term sub = term%config%i_term_global == term%config%i_sub end function term_instance_is_subtraction @ %def term_instance_is_subtraction @ Retrieve [[n_sub]] which was calculated in [[process_term_setup_interaction]]. <>= procedure :: get_n_sub => term_instance_get_n_sub procedure :: get_n_sub_color => term_instance_get_n_sub_color procedure :: get_n_sub_spin => term_instance_get_n_sub_spin <>= function term_instance_get_n_sub (term) result (n_sub) integer :: n_sub class(term_instance_t), intent(in) :: term n_sub = term%config%n_sub end function term_instance_get_n_sub function term_instance_get_n_sub_color (term) result (n_sub_color) integer :: n_sub_color class(term_instance_t), intent(in) :: term n_sub_color = term%config%n_sub_color end function term_instance_get_n_sub_color function term_instance_get_n_sub_spin (term) result (n_sub_spin) integer :: n_sub_spin class(term_instance_t), intent(in) :: term n_sub_spin = term%config%n_sub_spin end function term_instance_get_n_sub_spin @ %def term_instance_get_n_sub @ %def term_instance_get_n_sub_color @ %def term_instance_get_n_sub_spin @ \subsection{The process instance} A process instance contains all process data that depend on the sampling point and thus change often. In essence, it is an event record at the elementary (parton) level. We do not call it such, to avoid confusion with the actual event records. If decays are involved, the latter are compositions of several elementary processes (i.e., their instances). We implement the process instance as an extension of the [[mci_sampler_t]] that we need for computing integrals and generate events. The base type contains: the [[integrand]], the [[selected_channel]], the two-dimensional array [[x]] of parameters, and the one-dimensional array [[f]] of Jacobians. These subobjects are public and used for communicating with the multi-channel integrator. The [[process]] pointer accesses the process of which this record is an instance. It is required whenever the calculation needs invariant configuration data, therefore the process should stay in memory for the whole lifetime of its instances. The [[evaluation_status]] code is used to check the current status. In particular, failure at various stages is recorded there. The [[count]] object records process evaluations, broken down according to status. The [[sqme]] value is the single real number that results from evaluating and tracing the kinematics and matrix elements. This is the number that is handed over to an integration routine. The [[weight]] value is the event weight. It is defined when an event has been generated from the process instance, either weighted or unweighted. The value is the [[sqme]] value times Jacobian weights from the integration, or unity, respectively. The [[i_mci]] index chooses a subset of components that are associated with a common parameter set and integrator, i.e., that are added coherently. The [[sf_chain]] subobject is a realization of the beam and structure-function configuration in the [[process]] object. It is not used for calculation directly but serves as the template for the sf-chain instances that are contained in the [[component]] objects. The [[component]] subobjects determine the state of each component. The [[term]] subobjects are workspace for evaluating kinematics, matrix elements, cuts etc. The [[mci_work]] subobject contains the array of real input parameters (random numbers) that generates the kinematical point. It also contains the workspace for the MC integrators. The active entry of the [[mci_work]] array is selected by the [[i_mci]] index above. The [[hook]] pointer accesses a list of after evaluate objects which are evalutated after the matrix element. <>= public :: process_instance_t <>= type, extends (mci_sampler_t) :: process_instance_t type(process_t), pointer :: process => null () integer :: evaluation_status = STAT_UNDEFINED real(default) :: sqme = 0 real(default) :: weight = 0 real(default) :: excess = 0 integer :: n_dropped = 0 integer :: i_mci = 0 integer :: selected_channel = 0 type(sf_chain_t) :: sf_chain type(term_instance_t), dimension(:), allocatable :: term type(mci_work_t), dimension(:), allocatable :: mci_work class(pcm_instance_t), allocatable :: pcm class(process_instance_hook_t), pointer :: hook => null () contains <> end type process_instance_t @ %def process_instance @ Wrapper type for storing pointers to process instance objects in arrays. <>= public :: process_instance_ptr_t <>= type :: process_instance_ptr_t type(process_instance_t), pointer :: p => null () end type process_instance_ptr_t @ %def process_instance_ptr_t @ The process hooks are first-in-last-out list of objects which are evaluated after the phase space and matrixelement are evaluated. It is possible to retrieve the sampler object and read the sampler information. The hook object are part of the [[process_instance]] and therefore, share a common lifetime. A data transfer, after the usual lifetime of the [[process_instance]], is not provided, as such the finalisation procedure has to take care of this! E.g. write the object to file from which later the collected information can then be retrieved. <>= public :: process_instance_hook_t <>= type, abstract :: process_instance_hook_t class(process_instance_hook_t), pointer :: next => null () contains procedure(process_instance_hook_init), deferred :: init procedure(process_instance_hook_final), deferred :: final procedure(process_instance_hook_evaluate), deferred :: evaluate end type process_instance_hook_t @ %def process_instance_hook_t @ We have to provide a [[init]], a [[final]] procedure and, for after evaluation, the [[evaluate]] procedure. The [[init]] procedures accesses [[var_list]] and current [[instance]] object. <>= public :: process_instance_hook_final, process_instance_hook_evaluate <>= abstract interface subroutine process_instance_hook_init (hook, var_list, instance) import :: process_instance_hook_t, var_list_t, process_instance_t class(process_instance_hook_t), intent(inout), target :: hook type(var_list_t), intent(in) :: var_list class(process_instance_t), intent(in), target :: instance end subroutine process_instance_hook_init subroutine process_instance_hook_final (hook) import :: process_instance_hook_t class(process_instance_hook_t), intent(inout) :: hook end subroutine process_instance_hook_final subroutine process_instance_hook_evaluate (hook, instance) import :: process_instance_hook_t, process_instance_t class(process_instance_hook_t), intent(inout) :: hook class(process_instance_t), intent(in), target :: instance end subroutine process_instance_hook_evaluate end interface @ %def process_instance_hook_final, process_instance_hook_evaluate @ The output routine contains a header with the most relevant information about the process, copied from [[process_metadata_write]]. We mark the active components by an asterisk. The next section is the MC parameter input. The following sections are written only if the evaluation status is beyond setting the parameters, or if the [[verbose]] option is set. <>= procedure :: write_header => process_instance_write_header procedure :: write => process_instance_write <>= subroutine process_instance_write_header (object, unit, testflag) class(process_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) if (associated (object%process)) then call object%process%write_meta (u, testflag) else write (u, "(1x,A)") "Process instance [undefined process]" return end if write (u, "(3x,A)", advance = "no") "status = " select case (object%evaluation_status) case (STAT_INITIAL); write (u, "(A)") "initialized" case (STAT_ACTIVATED); write (u, "(A)") "activated" case (STAT_BEAM_MOMENTA); write (u, "(A)") "beam momenta set" case (STAT_FAILED_KINEMATICS); write (u, "(A)") "failed kinematics" case (STAT_SEED_KINEMATICS); write (u, "(A)") "seed kinematics" case (STAT_HARD_KINEMATICS); write (u, "(A)") "hard kinematics" case (STAT_EFF_KINEMATICS); write (u, "(A)") "effective kinematics" case (STAT_FAILED_CUTS); write (u, "(A)") "failed cuts" case (STAT_PASSED_CUTS); write (u, "(A)") "passed cuts" case (STAT_EVALUATED_TRACE); write (u, "(A)") "evaluated trace" call write_separator (u) write (u, "(3x,A,ES19.12)") "sqme = ", object%sqme case (STAT_EVENT_COMPLETE); write (u, "(A)") "event complete" call write_separator (u) write (u, "(3x,A,ES19.12)") "sqme = ", object%sqme write (u, "(3x,A,ES19.12)") "weight = ", object%weight if (.not. vanishes (object%excess)) & write (u, "(3x,A,ES19.12)") "excess = ", object%excess case default; write (u, "(A)") "undefined" end select if (object%i_mci /= 0) then call write_separator (u) call object%mci_work(object%i_mci)%write (u, testflag) end if call write_separator (u, 2) end subroutine process_instance_write_header subroutine process_instance_write (object, unit, testflag) class(process_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u, i u = given_output_unit (unit) call object%write_header (u) if (object%evaluation_status >= STAT_BEAM_MOMENTA) then call object%sf_chain%write (u) call write_separator (u, 2) if (object%evaluation_status >= STAT_SEED_KINEMATICS) then if (object%evaluation_status >= STAT_HARD_KINEMATICS) then call write_separator (u, 2) write (u, "(1x,A)") "Active terms:" if (any (object%term%active)) then do i = 1, size (object%term) if (object%term(i)%active) then call write_separator (u) call object%term(i)%write (u, & show_eff_state = & object%evaluation_status >= STAT_EFF_KINEMATICS, & testflag = testflag) end if end do end if end if call write_separator (u, 2) end if end if end subroutine process_instance_write @ %def process_instance_write_header @ %def process_instance_write @ Initialization connects the instance with a process. All initial information is transferred from the process object. The process object contains templates for the interaction subobjects (beam and term), but no evaluators. The initialization routine creates evaluators for the matrix element trace, other evaluators are left untouched. Before we start generating, we double-check if the process library has been updated after the process was initializated ([[check_library_sanity]]). This may happen if between integration and event generation the library has been recompiled, so all links become broken. The [[instance]] object must have the [[target]] attribute (also in any caller) since the initialization routine assigns various pointers to subobject of [[instance]]. <>= procedure :: init => process_instance_init <>= subroutine process_instance_init (instance, process) class(process_instance_t), intent(out), target :: instance type(process_t), intent(inout), target :: process integer :: i class(pcm_t), pointer :: pcm type(process_term_t) :: term type(var_list_t), pointer :: var_list integer :: i_born, i_real, i_real_fin call msg_debug (D_PROCESS_INTEGRATION, "process_instance_init") instance%process => process call instance%process%check_library_sanity () call instance%setup_sf_chain (process%get_beam_config_ptr ()) allocate (instance%mci_work (process%get_n_mci ())) do i = 1, size (instance%mci_work) call instance%process%init_mci_work (instance%mci_work(i), i) end do call instance%process%reset_selected_cores () pcm => instance%process%get_pcm_ptr () call pcm%allocate_instance (instance%pcm) call instance%pcm%link_config (pcm) select type (pcm) type is (pcm_nlo_t) !!! The process is kept when the integration is finalized, but not the !!! process_instance. Thus, we check whether pcm has been initialized !!! but set up the pcm_instance each time. i_real_fin = process%get_associated_real_fin (1) if (.not. pcm%initialized) then ! i_born = pcm%get_i_core_nlo_type (BORN) i_born = pcm%get_i_core (pcm%i_born) ! i_real = pcm%get_i_core_nlo_type (NLO_REAL, include_sub = .false.) ! i_real = pcm%get_i_core_nlo_type (NLO_REAL) i_real = pcm%get_i_core (pcm%i_real) term = process%get_term_ptr (process%get_i_term (i_real)) call pcm%init_qn (process%get_model_ptr ()) if (i_real_fin > 0) call pcm%allocate_ps_matching () var_list => process%get_var_list_ptr () if (var_list%get_sval (var_str ("$dalitz_plot")) /= var_str ('')) & call pcm%activate_dalitz_plot (var_list%get_sval (var_str ("$dalitz_plot"))) end if pcm%initialized = .true. select type (pcm_instance => instance%pcm) type is (pcm_instance_nlo_t) call pcm_instance%init_config (process%component_can_be_integrated (), & process%get_nlo_type_component (), process%get_sqrts (), i_real_fin, & process%get_model_ptr ()) end select end select allocate (instance%term (process%get_n_terms ())) do i = 1, process%get_n_terms () call instance%term(i)%init_from_process (process, i, instance%pcm, & instance%sf_chain) end do call instance%set_i_mci_to_real_component () call instance%find_same_kinematics () instance%evaluation_status = STAT_INITIAL end subroutine process_instance_init @ %def process_instance_init @ @ Finalize all subobjects that may contain allocated pointers. <>= procedure :: final => process_instance_final <>= subroutine process_instance_final (instance) class(process_instance_t), intent(inout) :: instance class(process_instance_hook_t), pointer :: current integer :: i instance%process => null () if (allocated (instance%mci_work)) then do i = 1, size (instance%mci_work) call instance%mci_work(i)%final () end do deallocate (instance%mci_work) end if call instance%sf_chain%final () if (allocated (instance%term)) then do i = 1, size (instance%term) call instance%term(i)%final () end do deallocate (instance%term) end if call instance%pcm%final () instance%evaluation_status = STAT_UNDEFINED do while (associated (instance%hook)) current => instance%hook call current%final () instance%hook => current%next deallocate (current) end do instance%hook => null () end subroutine process_instance_final @ %def process_instance_final @ Revert the process instance to initial state. We do not deallocate anything, just reset the state index and deactivate all components and terms. We do not reset the choice of the MCI set [[i_mci]] unless this is required explicitly. <>= procedure :: reset => process_instance_reset <>= subroutine process_instance_reset (instance, reset_mci) class(process_instance_t), intent(inout) :: instance logical, intent(in), optional :: reset_mci integer :: i call instance%process%reset_selected_cores () do i = 1, size (instance%term) call instance%term(i)%reset () end do instance%term%checked = .false. instance%term%passed = .false. instance%term%k_term%new_seed = .true. if (present (reset_mci)) then if (reset_mci) instance%i_mci = 0 end if instance%selected_channel = 0 instance%evaluation_status = STAT_INITIAL end subroutine process_instance_reset @ %def process_instance_reset @ \subsubsection{Integration and event generation} The sampler test should just evaluate the squared matrix element [[n_calls]] times, discarding the results, and return. This can be done before integration, e.g., for timing estimates. <>= procedure :: sampler_test => process_instance_sampler_test <>= subroutine process_instance_sampler_test (instance, i_mci, n_calls) class(process_instance_t), intent(inout), target :: instance integer, intent(in) :: i_mci integer, intent(in) :: n_calls integer :: i_mci_work i_mci_work = instance%process%get_i_mci_work (i_mci) call instance%choose_mci (i_mci_work) call instance%reset_counter () call instance%process%sampler_test (instance, n_calls, i_mci_work) call instance%process%set_counter_mci_entry (i_mci_work, instance%get_counter ()) end subroutine process_instance_sampler_test @ %def process_instance_sampler_test @ Generate a weighted event. We select one of the available MCI integrators by its index [[i_mci]] and thus generate an event for the associated (group of) process component(s). The arguments exactly correspond to the initializer and finalizer above. The resulting event is stored in the [[process_instance]] object, which also holds the workspace of the integrator. Note: The [[process]] object contains the random-number state, which changes for each event. Otherwise, all volatile data are inside the [[instance]] object. <>= procedure :: generate_weighted_event => process_instance_generate_weighted_event <>= subroutine process_instance_generate_weighted_event (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci integer :: i_mci_work i_mci_work = instance%process%get_i_mci_work (i_mci) call instance%choose_mci (i_mci_work) associate (mci_work => instance%mci_work(i_mci_work)) call instance%process%generate_weighted_event & (i_mci_work, mci_work, instance, & instance%keep_failed_events ()) end associate end subroutine process_instance_generate_weighted_event @ %def process_instance_generate_weighted_event @ <>= procedure :: generate_unweighted_event => process_instance_generate_unweighted_event <>= subroutine process_instance_generate_unweighted_event (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci integer :: i_mci_work i_mci_work = instance%process%get_i_mci_work (i_mci) call instance%choose_mci (i_mci_work) associate (mci_work => instance%mci_work(i_mci_work)) call instance%process%generate_unweighted_event & (i_mci_work, mci_work, instance) end associate end subroutine process_instance_generate_unweighted_event @ %def process_instance_generate_unweighted_event @ This replaces the event generation methods for the situation that the process instance object has been filled by other means (i.e., reading and/or recalculating its contents). We just have to fill in missing MCI data, especially the event weight. <>= procedure :: recover_event => process_instance_recover_event <>= subroutine process_instance_recover_event (instance) class(process_instance_t), intent(inout) :: instance integer :: i_mci i_mci = instance%i_mci call instance%process%set_i_mci_work (i_mci) associate (mci_instance => instance%mci_work(i_mci)%mci) call mci_instance%fetch (instance, instance%selected_channel) end associate end subroutine process_instance_recover_event @ %def process_instance_recover_event @ @ Activate the components and terms that correspond to a currently selected MCI parameter set. <>= procedure :: activate => process_instance_activate <>= subroutine process_instance_activate (instance) class(process_instance_t), intent(inout) :: instance integer :: i, j integer, dimension(:), allocatable :: i_term associate (mci_work => instance%mci_work(instance%i_mci)) call instance%process%select_components (mci_work%get_active_components ()) end associate associate (process => instance%process) do i = 1, instance%process%get_n_components () if (instance%process%component_is_selected (i)) then allocate (i_term (size (process%get_component_i_terms (i)))) i_term = process%get_component_i_terms (i) do j = 1, size (i_term) instance%term(i_term(j))%active = .true. end do end if if (allocated (i_term)) deallocate (i_term) end do end associate instance%evaluation_status = STAT_ACTIVATED end subroutine process_instance_activate @ %def process_instance_activate @ <>= procedure :: find_same_kinematics => process_instance_find_same_kinematics <>= subroutine process_instance_find_same_kinematics (instance) class(process_instance_t), intent(inout) :: instance integer :: i_term1, i_term2, k, n_same do i_term1 = 1, size (instance%term) if (.not. allocated (instance%term(i_term1)%same_kinematics)) then n_same = 1 !!! Index group includes the index of its term_instance do i_term2 = 1, size (instance%term) if (i_term1 == i_term2) cycle if (compare_md5s (i_term1, i_term2)) n_same = n_same + 1 end do allocate (instance%term(i_term1)%same_kinematics (n_same)) associate (same_kinematics1 => instance%term(i_term1)%same_kinematics) same_kinematics1 = 0 k = 1 do i_term2 = 1, size (instance%term) if (compare_md5s (i_term1, i_term2)) then same_kinematics1(k) = i_term2 k = k + 1 end if end do do k = 1, size (same_kinematics1) if (same_kinematics1(k) == i_term1) cycle i_term2 = same_kinematics1(k) allocate (instance%term(i_term2)%same_kinematics (n_same)) instance%term(i_term2)%same_kinematics = same_kinematics1 end do end associate end if end do contains function compare_md5s (i, j) result (same) logical :: same integer, intent(in) :: i, j character(32) :: md5sum_1, md5sum_2 integer :: mode_1, mode_2 mode_1 = 0; mode_2 = 0 select type (phs => instance%term(i)%k_term%phs%config) type is (phs_fks_config_t) md5sum_1 = phs%md5sum_born_config mode_1 = phs%mode class default md5sum_1 = phs%md5sum_phs_config end select select type (phs => instance%term(j)%k_term%phs%config) type is (phs_fks_config_t) md5sum_2 = phs%md5sum_born_config mode_2 = phs%mode class default md5sum_2 = phs%md5sum_phs_config end select same = (md5sum_1 == md5sum_2) .and. (mode_1 == mode_2) end function compare_md5s end subroutine process_instance_find_same_kinematics @ %def process_instance_find_same_kinematics @ <>= procedure :: transfer_same_kinematics => process_instance_transfer_same_kinematics <>= subroutine process_instance_transfer_same_kinematics (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term integer :: i, i_term_same associate (same_kinematics => instance%term(i_term)%same_kinematics) do i = 1, size (same_kinematics) i_term_same = same_kinematics(i) if (i_term_same /= i_term) then instance%term(i_term_same)%p_seed = instance%term(i_term)%p_seed associate (phs => instance%term(i_term_same)%k_term%phs) call phs%set_lorentz_transformation & (instance%term(i_term)%k_term%phs%get_lorentz_transformation ()) select type (phs) type is (phs_fks_t) call phs%set_momenta (instance%term(i_term_same)%p_seed) call phs%set_reference_frames (.false.) end select end associate end if instance%term(i_term_same)%k_term%new_seed = .false. end do end associate end subroutine process_instance_transfer_same_kinematics @ %def process_instance_transfer_same_kinematics @ <>= procedure :: redo_sf_chains => process_instance_redo_sf_chains <>= subroutine process_instance_redo_sf_chains (instance, i_term, phs_channel) class(process_instance_t), intent(inout) :: instance integer, intent(in), dimension(:) :: i_term integer, intent(in) :: phs_channel integer :: i do i = 1, size (i_term) call instance%term(i_term(i))%redo_sf_chain & (instance%mci_work(instance%i_mci), phs_channel) end do end subroutine process_instance_redo_sf_chains @ %def process_instance_redo_sf_chains @ Integrate the process, using a previously initialized process instance. We select one of the available MCI integrators by its index [[i_mci]] and thus integrate over (structure functions and) phase space for the associated (group of) process component(s). <>= procedure :: integrate => process_instance_integrate <>= subroutine process_instance_integrate (instance, i_mci, n_it, n_calls, & adapt_grids, adapt_weights, final, pacify) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: adapt_grids logical, intent(in), optional :: adapt_weights logical, intent(in), optional :: final, pacify integer :: nlo_type, i_mci_work nlo_type = instance%process%get_component_nlo_type (i_mci) i_mci_work = instance%process%get_i_mci_work (i_mci) call instance%choose_mci (i_mci_work) call instance%reset_counter () associate (mci_work => instance%mci_work(i_mci_work), & process => instance%process) call process%integrate (i_mci_work, mci_work, & instance, n_it, n_calls, adapt_grids, adapt_weights, & final, pacify, nlo_type = nlo_type) call process%set_counter_mci_entry (i_mci_work, instance%get_counter ()) end associate end subroutine process_instance_integrate @ %def process_instance_integrate @ Subroutine of the initialization above: initialize the beam and structure-function chain template. We establish pointers to the configuration data, so [[beam_config]] must have a [[target]] attribute. The resulting chain is not used directly for calculation. It will acquire instances which are stored in the process-component instance objects. <>= procedure :: setup_sf_chain => process_instance_setup_sf_chain <>= subroutine process_instance_setup_sf_chain (instance, config) class(process_instance_t), intent(inout) :: instance type(process_beam_config_t), intent(in), target :: config integer :: n_strfun n_strfun = config%n_strfun if (n_strfun /= 0) then call instance%sf_chain%init (config%data, config%sf) else call instance%sf_chain%init (config%data) end if if (config%sf_trace) then call instance%sf_chain%setup_tracing (config%sf_trace_file) end if end subroutine process_instance_setup_sf_chain @ %def process_instance_setup_sf_chain @ This initialization routine should be called only for process instances which we intend as a source for physical events. It initializes the evaluators in the parton states of the terms. They describe the (semi-)exclusive transition matrix and the distribution of color flow for the partonic process, convoluted with the beam and structure-function chain. If the model is not provided explicitly, we may use the model instance that belongs to the process. However, an explicit model allows us to override particle settings. <>= procedure :: setup_event_data => process_instance_setup_event_data <>= subroutine process_instance_setup_event_data (instance, model, i_core) class(process_instance_t), intent(inout), target :: instance class(model_data_t), intent(in), optional, target :: model integer, intent(in), optional :: i_core class(model_data_t), pointer :: current_model integer :: i class(prc_core_t), pointer :: core => null () if (present (model)) then current_model => model else current_model => instance%process%get_model_ptr () end if do i = 1, size (instance%term) associate (term => instance%term(i)) if (associated (term%config)) then core => instance%process%get_core_term (i) call term%setup_event_data (core, current_model) end if end associate end do core => null () end subroutine process_instance_setup_event_data @ %def process_instance_setup_event_data @ Choose a MC parameter set and the corresponding integrator. The choice persists beyond calls of the [[reset]] method above. This method is automatically called here. <>= procedure :: choose_mci => process_instance_choose_mci <>= subroutine process_instance_choose_mci (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci instance%i_mci = i_mci call instance%reset () end subroutine process_instance_choose_mci @ %def process_instance_choose_mci @ Explicitly set a MC parameter set. Works only if we are in initial state. We assume that the length of the parameter set is correct. After setting the parameters, activate the components and terms that correspond to the chosen MC parameter set. The [[warmup_flag]] is used when a dummy phase-space point is computed for the warmup of e.g. OpenLoops helicities. The setting of the the [[evaluation_status]] has to be avoided then. <>= procedure :: set_mcpar => process_instance_set_mcpar <>= subroutine process_instance_set_mcpar (instance, x, warmup_flag) class(process_instance_t), intent(inout) :: instance real(default), dimension(:), intent(in) :: x logical, intent(in), optional :: warmup_flag logical :: activate activate = .true.; if (present (warmup_flag)) activate = .not. warmup_flag if (instance%evaluation_status == STAT_INITIAL) then associate (mci_work => instance%mci_work(instance%i_mci)) call mci_work%set (x) end associate if (activate) call instance%activate () end if end subroutine process_instance_set_mcpar @ %def process_instance_set_mcpar @ Receive the beam momentum/momenta from a source interaction. This applies to a cascade decay process instance, where the `beam' momentum varies event by event. The master beam momentum array is contained in the main structure function chain subobject [[sf_chain]]. The sf-chain instance that reside in the components will take their beam momenta from there. The procedure transforms the instance status into [[STAT_BEAM_MOMENTA]]. For process instance with fixed beam, this intermediate status is skipped. <>= procedure :: receive_beam_momenta => process_instance_receive_beam_momenta <>= subroutine process_instance_receive_beam_momenta (instance) class(process_instance_t), intent(inout) :: instance if (instance%evaluation_status >= STAT_INITIAL) then call instance%sf_chain%receive_beam_momenta () instance%evaluation_status = STAT_BEAM_MOMENTA end if end subroutine process_instance_receive_beam_momenta @ %def process_instance_receive_beam_momenta @ Set the beam momentum/momenta explicitly. Otherwise, analogous to the previous procedure. <>= procedure :: set_beam_momenta => process_instance_set_beam_momenta <>= subroutine process_instance_set_beam_momenta (instance, p) class(process_instance_t), intent(inout) :: instance type(vector4_t), dimension(:), intent(in) :: p if (instance%evaluation_status >= STAT_INITIAL) then call instance%sf_chain%set_beam_momenta (p) instance%evaluation_status = STAT_BEAM_MOMENTA end if end subroutine process_instance_set_beam_momenta @ %def process_instance_set_beam_momenta @ Recover the initial beam momenta (those in the [[sf_chain]] component), given a valid (recovered) [[sf_chain_instance]] in one of the active components. We need to do this only if the lab frame is not the c.m.\ frame, otherwise those beams would be fixed anyway. <>= procedure :: recover_beam_momenta => process_instance_recover_beam_momenta <>= subroutine process_instance_recover_beam_momenta (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term if (.not. instance%process%lab_is_cm_frame ()) then if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then call instance%term(i_term)%return_beam_momenta () end if end if end subroutine process_instance_recover_beam_momenta @ %def process_instance_recover_beam_momenta @ Explicitly choose MC integration channel. We assume here that the channel count is identical for all active components. <>= procedure :: select_channel => process_instance_select_channel <>= subroutine process_instance_select_channel (instance, channel) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel instance%selected_channel = channel end subroutine process_instance_select_channel @ %def process_instance_select_channel @ First step of process evaluation: set up seed kinematics. That is, for each active process component, compute a momentum array from the MC input parameters. If [[skip_term]] is set, we skip the component that accesses this term. We can assume that the associated data have already been recovered, and we are just computing the rest. <>= procedure :: compute_seed_kinematics => & process_instance_compute_seed_kinematics <>= subroutine process_instance_compute_seed_kinematics (instance, skip_term) class(process_instance_t), intent(inout) :: instance integer, intent(in), optional :: skip_term integer :: channel, skip_component, i, j logical :: success integer, dimension(:), allocatable :: i_term channel = instance%selected_channel if (channel == 0) then call msg_bug ("Compute seed kinematics: undefined integration channel") end if if (present (skip_term)) then skip_component = instance%term(skip_term)%config%i_component else skip_component = 0 end if if (instance%evaluation_status >= STAT_ACTIVATED) then success = .true. do i = 1, instance%process%get_n_components () if (i == skip_component) cycle if (instance%process%component_is_selected (i)) then allocate (i_term (size (instance%process%get_component_i_terms (i)))) i_term = instance%process%get_component_i_terms (i) do j = 1, size (i_term) if (instance%term(i_term(j))%k_term%new_seed) then call instance%term(i_term(j))%compute_seed_kinematics & (instance%mci_work(instance%i_mci), channel, success) call instance%transfer_same_kinematics (i_term(j)) end if if (.not. success) exit call instance%term(i_term(j))%evaluate_projections () call instance%term(i_term(j))%evaluate_radiation_kinematics & (instance%mci_work(instance%i_mci)%get_x_process ()) call instance%term(i_term(j))%generate_fsr_in () call instance%term(i_term(j))%compute_xi_ref_momenta () end do end if if (allocated (i_term)) deallocate (i_term) end do if (success) then instance%evaluation_status = STAT_SEED_KINEMATICS else instance%evaluation_status = STAT_FAILED_KINEMATICS end if end if associate (mci_work => instance%mci_work(instance%i_mci)) select type (pcm => instance%pcm) class is (pcm_instance_nlo_t) call pcm%set_x_rad (mci_work%get_x_process ()) end select end associate end subroutine process_instance_compute_seed_kinematics @ %def process_instance_compute_seed_kinematics @ <>= procedure :: get_x_process => process_instance_get_x_process <>= pure function process_instance_get_x_process (instance) result (x) real(default), dimension(:), allocatable :: x class(process_instance_t), intent(in) :: instance allocate (x(size (instance%mci_work(instance%i_mci)%get_x_process ()))) x = instance%mci_work(instance%i_mci)%get_x_process () end function process_instance_get_x_process @ %def process_instance_get_x_process @ <>= procedure :: get_active_component_type => process_instance_get_active_component_type <>= pure function process_instance_get_active_component_type (instance) & result (nlo_type) integer :: nlo_type class(process_instance_t), intent(in) :: instance nlo_type = instance%process%get_component_nlo_type (instance%i_mci) end function process_instance_get_active_component_type @ %def process_instance_get_active_component_type @ Inverse: recover missing parts of the kinematics from the momentum configuration, which we know for a single term and component. Given a channel, reconstruct the MC parameter set. <>= procedure :: recover_mcpar => process_instance_recover_mcpar <>= subroutine process_instance_recover_mcpar (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term integer :: channel if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then channel = instance%selected_channel if (channel == 0) then call msg_bug ("Recover MC parameters: undefined integration channel") end if call instance%term(i_term)%recover_mcpar & (instance%mci_work(instance%i_mci), channel) end if end subroutine process_instance_recover_mcpar @ %def process_instance_recover_mcpar @ This is part of [[recover_mcpar]], extracted for the case when there is no phase space and parameters to recover, but we still need the structure function kinematics for evaluation. <>= procedure :: recover_sfchain => process_instance_recover_sfchain <>= subroutine process_instance_recover_sfchain (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term integer :: channel if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then channel = instance%selected_channel if (channel == 0) then call msg_bug ("Recover sfchain: undefined integration channel") end if call instance%term(i_term)%recover_sfchain (channel) end if end subroutine process_instance_recover_sfchain @ %def process_instance_recover_sfchain @ Second step of process evaluation: compute all momenta, for all active components, from the seed kinematics. <>= procedure :: compute_hard_kinematics => & process_instance_compute_hard_kinematics <>= subroutine process_instance_compute_hard_kinematics (instance, skip_term) class(process_instance_t), intent(inout) :: instance integer, intent(in), optional :: skip_term integer :: i logical :: success success = .true. if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then do i = 1, size (instance%term) if (instance%term(i)%active) then call instance%term(i)%compute_hard_kinematics (skip_term, success) if (.not. success) exit !!! Ren scale is zero when this is commented out! Understand! if (instance%term(i)%nlo_type == NLO_REAL) & call instance%term(i)%redo_sf_chain (instance%mci_work(instance%i_mci), & instance%selected_channel) end if end do if (success) then instance%evaluation_status = STAT_HARD_KINEMATICS else instance%evaluation_status = STAT_FAILED_KINEMATICS end if end if end subroutine process_instance_compute_hard_kinematics @ %def process_instance_setup_compute_hard_kinematics @ Inverse: recover seed kinematics. We know the beam momentum configuration and the outgoing momenta of the effective interaction, for one specific term. <>= procedure :: recover_seed_kinematics => & process_instance_recover_seed_kinematics <>= subroutine process_instance_recover_seed_kinematics (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term if (instance%evaluation_status >= STAT_EFF_KINEMATICS) & call instance%term(i_term)%recover_seed_kinematics () end subroutine process_instance_recover_seed_kinematics @ %def process_instance_recover_seed_kinematics @ Third step of process evaluation: compute the effective momentum configurations, for all active terms, from the hard kinematics. <>= procedure :: compute_eff_kinematics => & process_instance_compute_eff_kinematics <>= subroutine process_instance_compute_eff_kinematics (instance, skip_term) class(process_instance_t), intent(inout) :: instance integer, intent(in), optional :: skip_term integer :: i if (instance%evaluation_status >= STAT_HARD_KINEMATICS) then do i = 1, size (instance%term) if (present (skip_term)) then if (i == skip_term) cycle end if if (instance%term(i)%active) then call instance%term(i)%compute_eff_kinematics () end if end do instance%evaluation_status = STAT_EFF_KINEMATICS end if end subroutine process_instance_compute_eff_kinematics @ %def process_instance_setup_compute_eff_kinematics @ Inverse: recover the hard kinematics from effective kinematics for one term, then compute effective kinematics for the other terms. <>= procedure :: recover_hard_kinematics => & process_instance_recover_hard_kinematics <>= subroutine process_instance_recover_hard_kinematics (instance, i_term) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term integer :: i if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then call instance%term(i_term)%recover_hard_kinematics () do i = 1, size (instance%term) if (i /= i_term) then if (instance%term(i)%active) then call instance%term(i)%compute_eff_kinematics () end if end if end do instance%evaluation_status = STAT_EFF_KINEMATICS end if end subroutine process_instance_recover_hard_kinematics @ %def recover_hard_kinematics @ Fourth step of process evaluation: check cuts for all terms. Where sucessful, compute any scales and weights. Otherwise, deactive the term. If any of the terms has passed, set the state to [[STAT_PASSED_CUTS]]. The argument [[scale_forced]], if present, will override the scale calculation in the term expressions. <>= procedure :: evaluate_expressions => & process_instance_evaluate_expressions <>= subroutine process_instance_evaluate_expressions (instance, scale_forced) class(process_instance_t), intent(inout) :: instance real(default), intent(in), allocatable, optional :: scale_forced integer :: i logical :: passed_real if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then do i = 1, size (instance%term) if (instance%term(i)%active) then call instance%term(i)%evaluate_expressions (scale_forced) end if end do call evaluate_real_scales_and_cuts () if (.not. passed_real) then instance%evaluation_status = STAT_FAILED_CUTS else if (any (instance%term%passed)) then instance%evaluation_status = STAT_PASSED_CUTS else instance%evaluation_status = STAT_FAILED_CUTS end if end if end if contains subroutine evaluate_real_scales_and_cuts () integer :: i passed_real = .true. select type (config => instance%pcm%config) type is (pcm_nlo_t) do i = 1, size (instance%term) if (instance%term(i)%active .and. instance%term(i)%nlo_type == NLO_REAL) then if (config%settings%cut_all_sqmes) & passed_real = passed_real .and. instance%term(i)%passed if (config%settings%use_born_scale) & call replace_scales (instance%term(i)) end if end do end select end subroutine evaluate_real_scales_and_cuts subroutine replace_scales (this_term) type(term_instance_t), intent(inout) :: this_term integer :: i_sub i_sub = this_term%config%i_sub if (this_term%config%i_term_global /= i_sub .and. i_sub > 0) then this_term%ren_scale = instance%term(i_sub)%ren_scale this_term%fac_scale = instance%term(i_sub)%fac_scale end if end subroutine replace_scales end subroutine process_instance_evaluate_expressions @ %def process_instance_evaluate_expressions @ Fifth step of process evaluation: fill the parameters for the non-selected ,channels, that have not been used for seeding. We should do this after evaluating cuts, since we may save some expensive calculations if the phase space point fails the cuts. If [[skip_term]] is set, we skip the component that accesses this term. We can assume that the associated data have already been recovered, and we are just computing the rest. <>= procedure :: compute_other_channels => & process_instance_compute_other_channels <>= subroutine process_instance_compute_other_channels (instance, skip_term) class(process_instance_t), intent(inout) :: instance integer, intent(in), optional :: skip_term integer :: channel, skip_component, i, j integer, dimension(:), allocatable :: i_term channel = instance%selected_channel if (channel == 0) then call msg_bug ("Compute other channels: undefined integration channel") end if if (present (skip_term)) then skip_component = instance%term(skip_term)%config%i_component else skip_component = 0 end if if (instance%evaluation_status >= STAT_PASSED_CUTS) then do i = 1, instance%process%get_n_components () if (i == skip_component) cycle if (instance%process%component_is_selected (i)) then allocate (i_term (size (instance%process%get_component_i_terms (i)))) i_term = instance%process%get_component_i_terms (i) do j = 1, size (i_term) call instance%term(i_term(j))%compute_other_channels & (instance%mci_work(instance%i_mci), channel) end do end if if (allocated (i_term)) deallocate (i_term) end do end if end subroutine process_instance_compute_other_channels @ %def process_instance_compute_other_channels @ If not done otherwise, we an flag the kinematics as new for the core state, such that the routine below will actually compute the matrix element and not just look it up. <>= procedure :: reset_core_kinematics => process_instance_reset_core_kinematics <>= subroutine process_instance_reset_core_kinematics (instance) class(process_instance_t), intent(inout) :: instance integer :: i if (instance%evaluation_status >= STAT_PASSED_CUTS) then do i = 1, size (instance%term) associate (term => instance%term(i)) if (term%active .and. term%passed) then if (allocated (term%core_state)) & call term%core_state%reset_new_kinematics () end if end associate end do end if end subroutine process_instance_reset_core_kinematics @ %def process_instance_reset_core_kinematics @ Sixth step of process evaluation: evaluate the matrix elements, and compute the trace (summed over quantum numbers) for all terms. Finally, sum up the terms, iterating over all active process components. <>= procedure :: evaluate_trace => process_instance_evaluate_trace <>= subroutine process_instance_evaluate_trace (instance) class(process_instance_t), intent(inout) :: instance class(prc_core_t), pointer :: core => null () integer :: i, i_real_fin, i_core real(default) :: alpha_s, alpha_qed class(prc_core_t), pointer :: core_sub => null () class(model_data_t), pointer :: model => null () call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_evaluate_trace") instance%sqme = zero call instance%reset_matrix_elements () if (instance%evaluation_status >= STAT_PASSED_CUTS) then do i = 1, size (instance%term) associate (term => instance%term(i)) if (term%active .and. term%passed) then core => instance%process%get_core_term (i) select type (pcm => instance%process%get_pcm_ptr ()) class is (pcm_nlo_t) i_core = pcm%get_i_core (pcm%i_sub) core_sub => instance%process%get_core_ptr (i_core) end select ! if (instance%pcm%config%is_nlo ()) & ! core_sub => instance%process%get_subtraction_core () call term%evaluate_interaction (core) call term%evaluate_trace () i_real_fin = instance%process%get_associated_real_fin (1) if (instance%process%uses_real_partition ()) & call term%apply_real_partition (instance%process) if (term%config%i_component /= i_real_fin) then if ((term%nlo_type == NLO_REAL .and. term%k_term%emitter < 0) & .or. term%nlo_type == NLO_MISMATCH & .or. term%nlo_type == NLO_DGLAP) & call term%set_born_sqmes (core) if (term%nlo_type > BORN) then if (.not. (term%nlo_type == NLO_REAL .and. term%k_term%emitter >= 0)) then select type (config => term%pcm_instance%config) type is (pcm_nlo_t) if (char (config%settings%nlo_correction_type) == "QCD" .or. & char (config%settings%nlo_correction_type) == "Full") & call term%evaluate_color_correlations (core_sub) if (char (config%settings%nlo_correction_type) == "QED" .or. & char (config%settings%nlo_correction_type) == "Full") & call term%evaluate_charge_correlations (core_sub) end select end if if (term%is_subtraction ()) then call term%evaluate_spin_correlations (core_sub) end if if ((term%is_subtraction () .or. term%nlo_type == NLO_DGLAP) & .and. term%pcm_instance%config%has_pdfs) & call term%compute_sqme_coll_isr () end if alpha_s = core%get_alpha_s (term%core_state) if (associated (instance%process%get_model_ptr ())) then model => instance%process%get_model_ptr () if (associated (model%get_par_data_ptr (var_str ('alpha_em_i')))) & alpha_qed = one / model%get_real (var_str ('alpha_em_i')) model => null () end if select case (term%nlo_type) case (NLO_REAL) call term%apply_fks (alpha_s, alpha_qed) case (NLO_VIRTUAL) call term%evaluate_sqme_virt (alpha_s, alpha_qed) case (NLO_MISMATCH) call term%evaluate_sqme_mismatch (alpha_s) case (NLO_DGLAP) call term%evaluate_sqme_dglap (alpha_s) end select end if end if core_sub => null () instance%sqme = instance%sqme + real (sum (& term%connected%trace%get_matrix_element () * & term%weight)) end associate end do core => null () if (instance%pcm%is_valid ()) then instance%evaluation_status = STAT_EVALUATED_TRACE else instance%evaluation_status = STAT_FAILED_KINEMATICS end if else !!! Failed kinematics or failed cuts: set sqme to zero instance%sqme = zero end if end subroutine process_instance_evaluate_trace @ %def process_instance_evaluate_trace <>= procedure :: set_born_sqmes => term_instance_set_born_sqmes <>= subroutine term_instance_set_born_sqmes (term, core) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in) :: core integer :: i_flv, ii_flv real(default) :: sqme select type (pcm_instance => term%pcm_instance) type is (pcm_instance_nlo_t) do i_flv = 1, term%connected_qn_index%get_n_flv () ii_flv = term%connected_qn_index%get_index (i_flv, i_sub = 0) sqme = real (term%connected%trace%get_matrix_element (ii_flv)) select case (term%nlo_type) case (NLO_REAL) pcm_instance%real_sub%sqme_born(i_flv) = sqme case (NLO_MISMATCH) pcm_instance%soft_mismatch%sqme_born(i_flv) = sqme case (NLO_DGLAP) pcm_instance%dglap_remnant%sqme_born(i_flv) = sqme end select end do end select end subroutine term_instance_set_born_sqmes @ <>= procedure :: apply_real_partition => process_instance_apply_real_partition <>= subroutine process_instance_apply_real_partition (instance) class(process_instance_t), intent(inout) :: instance integer :: i_component, i_term integer, dimension(:), allocatable :: i_terms associate (process => instance%process) i_component = process%get_first_real_component () if (process%component_is_selected (i_component) .and. & process%get_component_nlo_type (i_component) == NLO_REAL) then allocate (i_terms (size (process%get_component_i_terms (i_component)))) i_terms = process%get_component_i_terms (i_component) do i_term = 1, size (i_terms) call instance%term(i_terms(i_term))%apply_real_partition (process) end do end if if (allocated (i_terms)) deallocate (i_terms) end associate end subroutine process_instance_apply_real_partition @ %def process_instance_apply_real_partition @ <>= procedure :: set_i_mci_to_real_component => process_instance_set_i_mci_to_real_component <>= subroutine process_instance_set_i_mci_to_real_component (instance) class(process_instance_t), intent(inout) :: instance integer :: i_mci, i_component type(process_component_t), pointer :: component => null () select type (pcm_instance => instance%pcm) type is (pcm_instance_nlo_t) if (allocated (pcm_instance%i_mci_to_real_component)) then call msg_warning ("i_mci_to_real_component already allocated - replace it") deallocate (pcm_instance%i_mci_to_real_component) end if allocate (pcm_instance%i_mci_to_real_component (size (instance%mci_work))) do i_mci = 1, size (instance%mci_work) do i_component = 1, instance%process%get_n_components () component => instance%process%get_component_ptr (i_component) if (component%i_mci /= i_mci) cycle select case (component%component_type) case (COMP_MASTER, COMP_REAL) pcm_instance%i_mci_to_real_component (i_mci) = & component%config%get_associated_real () case (COMP_REAL_FIN) pcm_instance%i_mci_to_real_component (i_mci) = & component%config%get_associated_real_fin () case (COMP_REAL_SING) pcm_instance%i_mci_to_real_component (i_mci) = & component%config%get_associated_real_sing () end select end do end do component => null () end select end subroutine process_instance_set_i_mci_to_real_component @ %def process_instance_set_i_mci_to_real_component @ Final step of process evaluation: evaluate the matrix elements, and compute the trace (summed over quantum numbers) for all terms. Finally, sum up the terms, iterating over all active process components. If [[weight]] is provided, we already know the kinematical event weight (the MCI weight which depends on the kinematics sampling algorithm, but not on the matrix element), so we do not need to take it from the MCI record. <>= procedure :: evaluate_event_data => process_instance_evaluate_event_data <>= subroutine process_instance_evaluate_event_data (instance, weight) class(process_instance_t), intent(inout) :: instance real(default), intent(in), optional :: weight integer :: i if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then do i = 1, size (instance%term) associate (term => instance%term(i)) if (term%active .and. term%passed) then call term%evaluate_event_data () end if end associate end do if (present (weight)) then instance%weight = weight else instance%weight = & instance%mci_work(instance%i_mci)%mci%get_event_weight () instance%excess = & instance%mci_work(instance%i_mci)%mci%get_event_excess () end if instance%n_dropped = & instance%mci_work(instance%i_mci)%mci%get_n_event_dropped () instance%evaluation_status = STAT_EVENT_COMPLETE else !!! failed kinematics etc.: set weight to zero instance%weight = zero !!! Maybe we want to keep the event nevertheless if (instance%keep_failed_events ()) then !!! Force factorization scale, otherwise writing to event output fails do i = 1, size (instance%term) instance%term(i)%fac_scale = zero end do instance%evaluation_status = STAT_EVENT_COMPLETE end if end if end subroutine process_instance_evaluate_event_data @ %def process_instance_evaluate_event_data @ Computes the real-emission matrix element for externally supplied momenta. Also, e.g. for Powheg, there is the possibility to supply an external $\alpha_s$ <>= procedure :: compute_sqme_rad => process_instance_compute_sqme_rad <>= subroutine process_instance_compute_sqme_rad & (instance, i_term, i_phs, is_subtraction, alpha_s_external) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term, i_phs logical, intent(in) :: is_subtraction real(default), intent(in), optional :: alpha_s_external class(prc_core_t), pointer :: core integer :: i_real_fin call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_compute_sqme_rad") select type (pcm => instance%pcm) type is (pcm_instance_nlo_t) associate (term => instance%term(i_term)) core => instance%process%get_core_term (i_term) if (is_subtraction) then call pcm%set_subtraction_event () else call pcm%set_radiation_event () end if call term%int_hard%set_momenta (pcm%get_momenta & (i_phs = i_phs, born_phsp = is_subtraction)) if (allocated (term%core_state)) & call term%core_state%reset_new_kinematics () if (present (alpha_s_external)) & call term%set_alpha_qcd_forced (alpha_s_external) call term%compute_eff_kinematics () call term%evaluate_expressions () call term%evaluate_interaction (core) call term%evaluate_trace () pcm%real_sub%sqme_born (1) = & real (term%connected%trace%get_matrix_element (1)) if (term%is_subtraction ()) then select type (config => term%pcm_instance%config) type is (pcm_nlo_t) if (char (config%settings%nlo_correction_type) == "QCD" .or. & char (config%settings%nlo_correction_type) == "Full") & call term%evaluate_color_correlations (core) if (char (config%settings%nlo_correction_type) == "QED" .or. & char (config%settings%nlo_correction_type) == "Full") & call term%evaluate_charge_correlations (core) end select call term%evaluate_spin_correlations (core) if (term%pcm_instance%config%has_pdfs) & call term%compute_sqme_coll_isr () else if (term%nlo_type == NLO_DGLAP) then call term%compute_sqme_coll_isr () end if i_real_fin = instance%process%get_associated_real_fin (1) if (term%config%i_component /= i_real_fin) & call term%apply_fks (core%get_alpha_s (term%core_state), 0._default) if (instance%process%uses_real_partition ()) & call instance%apply_real_partition () end associate end select core => null () end subroutine process_instance_compute_sqme_rad @ %def process_instance_compute_sqme_rad @ For unweighted event generation, we should reset the reported event weight to unity (signed) or zero. The latter case is appropriate for an event which failed for whatever reason. <>= procedure :: normalize_weight => process_instance_normalize_weight <>= subroutine process_instance_normalize_weight (instance) class(process_instance_t), intent(inout) :: instance if (.not. vanishes (instance%weight)) then instance%weight = sign (1._default, instance%weight) end if end subroutine process_instance_normalize_weight @ %def process_instance_normalize_weight @ This is a convenience routine that performs the computations of the steps 1 to 5 in a single step. The arguments are the input for [[set_mcpar]]. After this, the evaluation status should be either [[STAT_FAILED_KINEMATICS]], [[STAT_FAILED_CUTS]] or [[STAT_EVALUATED_TRACE]]. Before calling this, we should call [[choose_mci]]. <>= procedure :: evaluate_sqme => process_instance_evaluate_sqme <>= subroutine process_instance_evaluate_sqme (instance, channel, x) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel real(default), dimension(:), intent(in) :: x call instance%reset () call instance%set_mcpar (x) call instance%select_channel (channel) call instance%compute_seed_kinematics () call instance%compute_hard_kinematics () call instance%compute_eff_kinematics () call instance%evaluate_expressions () call instance%compute_other_channels () call instance%evaluate_trace () end subroutine process_instance_evaluate_sqme @ %def process_instance_evaluate_sqme @ This is the inverse. Assuming that the final trace evaluator contains a valid momentum configuration, recover kinematics and recalculate the matrix elements and their trace. To be precise, we first recover kinematics for the given term and associated component, then recalculate from that all other terms and active components. The [[channel]] is not really required to obtain the matrix element, but it allows us to reconstruct the exact MC parameter set that corresponds to the given phase space point. Before calling this, we should call [[choose_mci]]. <>= procedure :: recover => process_instance_recover <>= subroutine process_instance_recover & (instance, channel, i_term, update_sqme, recover_phs, scale_forced) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel integer, intent(in) :: i_term logical, intent(in) :: update_sqme logical, intent(in) :: recover_phs real(default), intent(in), allocatable, optional :: scale_forced logical :: skip_phs call instance%activate () instance%evaluation_status = STAT_EFF_KINEMATICS call instance%recover_hard_kinematics (i_term) call instance%recover_seed_kinematics (i_term) call instance%select_channel (channel) if (recover_phs) then call instance%recover_mcpar (i_term) call instance%recover_beam_momenta (i_term) call instance%compute_seed_kinematics (i_term) call instance%compute_hard_kinematics (i_term) call instance%compute_eff_kinematics (i_term) call instance%compute_other_channels (i_term) else call instance%recover_sfchain (i_term) end if call instance%evaluate_expressions (scale_forced) if (update_sqme) then call instance%reset_core_kinematics () call instance%evaluate_trace () end if end subroutine process_instance_recover @ %def process_instance_recover @ The [[evaluate]] method is required by the [[sampler_t]] base type of which the process instance is an extension. The requirement is that after the process instance is evaluated, the integrand, the selected channel, the $x$ array, and the $f$ Jacobian array are exposed by the [[sampler_t]] object. We allow for the additional [[hook]] to be called, if associated, for outlying object to access information from the current state of the [[sampler]]. <>= procedure :: evaluate => process_instance_evaluate <>= subroutine process_instance_evaluate (sampler, c, x_in, val, x, f) class(process_instance_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%evaluate_sqme (c, x_in) if (sampler%is_valid ()) then call sampler%fetch (val, x, f) end if call sampler%record_call () call sampler%evaluate_after_hook () end subroutine process_instance_evaluate @ %def process_instance_evaluate @ The phase-space point is valid if the event has valid kinematics and has passed the cuts. <>= procedure :: is_valid => process_instance_is_valid <>= function process_instance_is_valid (sampler) result (valid) class(process_instance_t), intent(in) :: sampler logical :: valid valid = sampler%evaluation_status >= STAT_PASSED_CUTS end function process_instance_is_valid @ %def process_instance_is_valid @ Add a [[process_instance_hook]] object.. <>= procedure :: append_after_hook => process_instance_append_after_hook <>= subroutine process_instance_append_after_hook (sampler, new_hook) class(process_instance_t), intent(inout), target :: sampler class(process_instance_hook_t), intent(inout), target :: new_hook class(process_instance_hook_t), pointer :: last if (associated (new_hook%next)) then call msg_bug ("process_instance_append_after_hook: reuse of SAME hook object is forbidden.") end if if (associated (sampler%hook)) then last => sampler%hook do while (associated (last%next)) last => last%next end do last%next => new_hook else sampler%hook => new_hook end if end subroutine process_instance_append_after_hook @ %def process_instance_append_after_evaluate_hook @ Evaluate the after hook as first in, last out. <>= procedure :: evaluate_after_hook => process_instance_evaluate_after_hook <>= subroutine process_instance_evaluate_after_hook (sampler) class(process_instance_t), intent(in) :: sampler class(process_instance_hook_t), pointer :: current current => sampler%hook do while (associated(current)) call current%evaluate (sampler) current => current%next end do end subroutine process_instance_evaluate_after_hook @ %def process_instance_evaluate_after_hook @ The [[rebuild]] method should rebuild the kinematics section out of the [[x_in]] parameter set. The integrand value [[val]] should not be computed, but is provided as input. <>= procedure :: rebuild => process_instance_rebuild <>= subroutine process_instance_rebuild (sampler, c, x_in, val, x, f) class(process_instance_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call msg_bug ("process_instance_rebuild not implemented yet") x = 0 f = 0 end subroutine process_instance_rebuild @ %def process_instance_rebuild @ This is another method required by the [[sampler_t]] base type: fetch the data that are relevant for the MCI record. <>= procedure :: fetch => process_instance_fetch <>= subroutine process_instance_fetch (sampler, val, x, f) class(process_instance_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f integer, dimension(:), allocatable :: i_terms integer :: i, i_term_base, cc integer :: n_channel val = 0 associate (process => sampler%process) FIND_COMPONENT: do i = 1, process%get_n_components () if (sampler%process%component_is_selected (i)) then allocate (i_terms (size (process%get_component_i_terms (i)))) i_terms = process%get_component_i_terms (i) i_term_base = i_terms(1) associate (k => sampler%term(i_term_base)%k_term) n_channel = k%n_channel do cc = 1, n_channel call k%get_mcpar (cc, x(:,cc)) end do f = k%f val = sampler%sqme * k%phs_factor end associate if (allocated (i_terms)) deallocate (i_terms) exit FIND_COMPONENT end if end do FIND_COMPONENT end associate end subroutine process_instance_fetch @ %def process_instance_fetch @ Initialize and finalize event generation for the specified MCI entry. <>= procedure :: init_simulation => process_instance_init_simulation procedure :: final_simulation => process_instance_final_simulation <>= subroutine process_instance_init_simulation (instance, i_mci, & safety_factor, keep_failed_events) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci real(default), intent(in), optional :: safety_factor logical, intent(in), optional :: keep_failed_events call instance%mci_work(i_mci)%init_simulation (safety_factor, keep_failed_events) end subroutine process_instance_init_simulation subroutine process_instance_final_simulation (instance, i_mci) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_mci call instance%mci_work(i_mci)%final_simulation () end subroutine process_instance_final_simulation @ %def process_instance_init_simulation @ %def process_instance_final_simulation @ \subsubsection{Accessing the process instance} Once the seed kinematics is complete, we can retrieve the MC input parameters for all channels, not just the seed channel. Note: We choose the first active component. This makes sense only if the seed kinematics is identical for all active components. <>= procedure :: get_mcpar => process_instance_get_mcpar <>= subroutine process_instance_get_mcpar (instance, channel, x) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: channel real(default), dimension(:), intent(out) :: x integer :: i if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then do i = 1, size (instance%term) if (instance%term(i)%active) then call instance%term(i)%k_term%get_mcpar (channel, x) return end if end do call msg_bug ("Process instance: get_mcpar: no active channels") else call msg_bug ("Process instance: get_mcpar: no seed kinematics") end if end subroutine process_instance_get_mcpar @ %def process_instance_get_mcpar @ Return true if the [[sqme]] value is known. This also implies that the event is kinematically valid and has passed all cuts. <>= procedure :: has_evaluated_trace => process_instance_has_evaluated_trace <>= function process_instance_has_evaluated_trace (instance) result (flag) class(process_instance_t), intent(in) :: instance logical :: flag flag = instance%evaluation_status >= STAT_EVALUATED_TRACE end function process_instance_has_evaluated_trace @ %def process_instance_has_evaluated_trace @ Return true if the event is complete. In particular, the event must be kinematically valid, passed all cuts, and the event data have been computed. <>= procedure :: is_complete_event => process_instance_is_complete_event <>= function process_instance_is_complete_event (instance) result (flag) class(process_instance_t), intent(in) :: instance logical :: flag flag = instance%evaluation_status >= STAT_EVENT_COMPLETE end function process_instance_is_complete_event @ %def process_instance_is_complete_event @ Select the term for the process instance that will provide the basic event record (used in [[evt_trivial_make_particle_set]]). It might be necessary to write out additional events corresponding to other terms (done in [[evt_nlo]]). <>= procedure :: select_i_term => process_instance_select_i_term <>= function process_instance_select_i_term (instance) result (i_term) integer :: i_term class(process_instance_t), intent(in) :: instance integer :: i_mci i_mci = instance%i_mci i_term = instance%process%select_i_term (i_mci) end function process_instance_select_i_term @ %def process_instance_select_i_term @ Return pointer to the master beam interaction. <>= procedure :: get_beam_int_ptr => process_instance_get_beam_int_ptr <>= function process_instance_get_beam_int_ptr (instance) result (ptr) class(process_instance_t), intent(in), target :: instance type(interaction_t), pointer :: ptr ptr => instance%sf_chain%get_beam_int_ptr () end function process_instance_get_beam_int_ptr @ %def process_instance_get_beam_int_ptr @ Return pointers to the matrix and flows interactions, given a term index. <>= procedure :: get_trace_int_ptr => process_instance_get_trace_int_ptr procedure :: get_matrix_int_ptr => process_instance_get_matrix_int_ptr procedure :: get_flows_int_ptr => process_instance_get_flows_int_ptr <>= function process_instance_get_trace_int_ptr (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(interaction_t), pointer :: ptr ptr => instance%term(i_term)%connected%get_trace_int_ptr () end function process_instance_get_trace_int_ptr function process_instance_get_matrix_int_ptr (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(interaction_t), pointer :: ptr ptr => instance%term(i_term)%connected%get_matrix_int_ptr () end function process_instance_get_matrix_int_ptr function process_instance_get_flows_int_ptr (instance, i_term) result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(interaction_t), pointer :: ptr ptr => instance%term(i_term)%connected%get_flows_int_ptr () end function process_instance_get_flows_int_ptr @ %def process_instance_get_trace_int_ptr @ %def process_instance_get_matrix_int_ptr @ %def process_instance_get_flows_int_ptr @ Return the complete account of flavor combinations in the underlying interaction object, including beams, radiation, and hard interaction. <>= procedure :: get_state_flv => process_instance_get_state_flv <>= function process_instance_get_state_flv (instance, i_term) result (state_flv) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term type(state_flv_content_t) :: state_flv state_flv = instance%term(i_term)%connected%get_state_flv () end function process_instance_get_state_flv @ %def process_instance_get_state_flv @ Return pointers to the parton states of a selected term. <>= procedure :: get_isolated_state_ptr => & process_instance_get_isolated_state_ptr procedure :: get_connected_state_ptr => & process_instance_get_connected_state_ptr <>= function process_instance_get_isolated_state_ptr (instance, i_term) & result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(isolated_state_t), pointer :: ptr ptr => instance%term(i_term)%isolated end function process_instance_get_isolated_state_ptr function process_instance_get_connected_state_ptr (instance, i_term) & result (ptr) class(process_instance_t), intent(in), target :: instance integer, intent(in) :: i_term type(connected_state_t), pointer :: ptr ptr => instance%term(i_term)%connected end function process_instance_get_connected_state_ptr @ %def process_instance_get_isolated_state_ptr @ %def process_instance_get_connected_state_ptr @ Return the indices of the beam particles and incoming partons within the currently active state matrix, respectively. <>= procedure :: get_beam_index => process_instance_get_beam_index procedure :: get_in_index => process_instance_get_in_index <>= subroutine process_instance_get_beam_index (instance, i_term, i_beam) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term integer, dimension(:), intent(out) :: i_beam call instance%term(i_term)%connected%get_beam_index (i_beam) end subroutine process_instance_get_beam_index subroutine process_instance_get_in_index (instance, i_term, i_in) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term integer, dimension(:), intent(out) :: i_in call instance%term(i_term)%connected%get_in_index (i_in) end subroutine process_instance_get_in_index @ %def process_instance_get_beam_index @ %def process_instance_get_in_index @ Return squared matrix element and event weight, and event weight excess where applicable. [[n_dropped]] is a number that can be nonzero when a weighted event has been generated, dropping events with zero weight (failed cuts) on the fly. <>= procedure :: get_sqme => process_instance_get_sqme procedure :: get_weight => process_instance_get_weight procedure :: get_excess => process_instance_get_excess procedure :: get_n_dropped => process_instance_get_n_dropped <>= function process_instance_get_sqme (instance, i_term) result (sqme) real(default) :: sqme class(process_instance_t), intent(in) :: instance integer, intent(in), optional :: i_term if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then if (present (i_term)) then sqme = instance%term(i_term)%connected%trace%get_matrix_element (1) else sqme = instance%sqme end if else sqme = 0 end if end function process_instance_get_sqme function process_instance_get_weight (instance) result (weight) real(default) :: weight class(process_instance_t), intent(in) :: instance if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then weight = instance%weight else weight = 0 end if end function process_instance_get_weight function process_instance_get_excess (instance) result (excess) real(default) :: excess class(process_instance_t), intent(in) :: instance if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then excess = instance%excess else excess = 0 end if end function process_instance_get_excess function process_instance_get_n_dropped (instance) result (n_dropped) integer :: n_dropped class(process_instance_t), intent(in) :: instance if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then n_dropped = instance%n_dropped else n_dropped = 0 end if end function process_instance_get_n_dropped @ %def process_instance_get_sqme @ %def process_instance_get_weight @ %def process_instance_get_excess @ %def process_instance_get_n_dropped @ Return the currently selected MCI channel. <>= procedure :: get_channel => process_instance_get_channel <>= function process_instance_get_channel (instance) result (channel) integer :: channel class(process_instance_t), intent(in) :: instance channel = instance%selected_channel end function process_instance_get_channel @ %def process_instance_get_channel @ <>= procedure :: set_fac_scale => process_instance_set_fac_scale <>= subroutine process_instance_set_fac_scale (instance, fac_scale) class(process_instance_t), intent(inout) :: instance real(default), intent(in) :: fac_scale integer :: i_term i_term = 1 call instance%term(i_term)%set_fac_scale (fac_scale) end subroutine process_instance_set_fac_scale @ %def process_instance_set_fac_scale @ Return factorization scale and strong coupling. We have to select a term instance. <>= procedure :: get_fac_scale => process_instance_get_fac_scale procedure :: get_alpha_s => process_instance_get_alpha_s <>= function process_instance_get_fac_scale (instance, i_term) result (fac_scale) class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term real(default) :: fac_scale fac_scale = instance%term(i_term)%get_fac_scale () end function process_instance_get_fac_scale function process_instance_get_alpha_s (instance, i_term) result (alpha_s) real(default) :: alpha_s class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term class(prc_core_t), pointer :: core => null () core => instance%process%get_core_term (i_term) alpha_s = instance%term(i_term)%get_alpha_s (core) core => null () end function process_instance_get_alpha_s @ %def process_instance_get_fac_scale @ %def process_instance_get_alpha_s @ <>= procedure :: get_qcd => process_instance_get_qcd <>= function process_instance_get_qcd (process_instance) result (qcd) type(qcd_t) :: qcd class(process_instance_t), intent(in) :: process_instance qcd = process_instance%process%get_qcd () end function process_instance_get_qcd @ %def process_instance_get_qcd @ Counter. <>= procedure :: reset_counter => process_instance_reset_counter procedure :: record_call => process_instance_record_call procedure :: get_counter => process_instance_get_counter <>= subroutine process_instance_reset_counter (process_instance) class(process_instance_t), intent(inout) :: process_instance call process_instance%mci_work(process_instance%i_mci)%reset_counter () end subroutine process_instance_reset_counter subroutine process_instance_record_call (process_instance) class(process_instance_t), intent(inout) :: process_instance call process_instance%mci_work(process_instance%i_mci)%record_call & (process_instance%evaluation_status) end subroutine process_instance_record_call pure function process_instance_get_counter (process_instance) result (counter) class(process_instance_t), intent(in) :: process_instance type(process_counter_t) :: counter counter = process_instance%mci_work(process_instance%i_mci)%get_counter () end function process_instance_get_counter @ %def process_instance_reset_counter @ %def process_instance_record_call @ %def process_instance_get_counter @ Sum up the total number of calls for all MCI records. <>= procedure :: get_actual_calls_total => process_instance_get_actual_calls_total <>= pure function process_instance_get_actual_calls_total (process_instance) & result (n) class(process_instance_t), intent(in) :: process_instance integer :: n integer :: i type(process_counter_t) :: counter n = 0 do i = 1, size (process_instance%mci_work) counter = process_instance%mci_work(i)%get_counter () n = n + counter%total end do end function process_instance_get_actual_calls_total @ %def process_instance_get_actual_calls_total @ <>= procedure :: reset_matrix_elements => process_instance_reset_matrix_elements <>= subroutine process_instance_reset_matrix_elements (instance) class(process_instance_t), intent(inout) :: instance integer :: i_term do i_term = 1, size (instance%term) call instance%term(i_term)%connected%trace%set_matrix_element (cmplx (0, 0, default)) call instance%term(i_term)%connected%matrix%set_matrix_element (cmplx (0, 0, default)) end do end subroutine process_instance_reset_matrix_elements @ %def process_instance_reset_matrix_elements @ <>= procedure :: get_test_phase_space_point & => process_instance_get_test_phase_space_point <>= subroutine process_instance_get_test_phase_space_point (instance, & i_component, i_core, p) type(vector4_t), dimension(:), allocatable, intent(out) :: p class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_component, i_core real(default), dimension(:), allocatable :: x logical :: success integer :: i_term instance%i_mci = i_component i_term = instance%process%get_i_term (i_core) associate (term => instance%term(i_term)) allocate (x (instance%mci_work(i_component)%config%n_par)) x = 0.5_default call instance%set_mcpar (x, .true.) call instance%select_channel (1) call term%compute_seed_kinematics & (instance%mci_work(i_component), 1, success) call instance%term(i_term)%evaluate_radiation_kinematics & (instance%mci_work(instance%i_mci)%get_x_process ()) call instance%term(i_term)%compute_hard_kinematics (success = success) allocate (p (size (term%p_hard))) p = term%int_hard%get_momenta () end associate end subroutine process_instance_get_test_phase_space_point @ %def process_instance_get_test_phase_space_point @ <>= procedure :: get_p_hard => process_instance_get_p_hard <>= pure function process_instance_get_p_hard (process_instance, i_term) & result (p_hard) type(vector4_t), dimension(:), allocatable :: p_hard class(process_instance_t), intent(in) :: process_instance integer, intent(in) :: i_term allocate (p_hard (size (process_instance%term(i_term)%get_p_hard ()))) p_hard = process_instance%term(i_term)%get_p_hard () end function process_instance_get_p_hard @ %def process_instance_get_p_hard @ <>= procedure :: get_first_active_i_term => process_instance_get_first_active_i_term <>= function process_instance_get_first_active_i_term (instance) result (i_term) integer :: i_term class(process_instance_t), intent(in) :: instance integer :: i i_term = 0 do i = 1, size (instance%term) if (instance%term(i)%active) then i_term = i exit end if end do end function process_instance_get_first_active_i_term @ %def process_instance_get_first_active_i_term @ <>= procedure :: get_real_of_mci => process_instance_get_real_of_mci <>= function process_instance_get_real_of_mci (instance) result (i_real) integer :: i_real class(process_instance_t), intent(in) :: instance select type (pcm => instance%pcm) type is (pcm_instance_nlo_t) i_real = pcm%i_mci_to_real_component (instance%i_mci) end select end function process_instance_get_real_of_mci @ %def process_instance_get_real_of_mci @ <>= procedure :: get_connected_states => process_instance_get_connected_states <>= function process_instance_get_connected_states (instance, i_component) result (connected) type(connected_state_t), dimension(:), allocatable :: connected class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_component connected = instance%process%get_connected_states (i_component, & instance%term(:)%connected) end function process_instance_get_connected_states @ %def process_instance_get_connected_states @ Get the hadronic center-of-mass energy <>= procedure :: get_sqrts => process_instance_get_sqrts <>= function process_instance_get_sqrts (instance) result (sqrts) class(process_instance_t), intent(in) :: instance real(default) :: sqrts sqrts = instance%process%get_sqrts () end function process_instance_get_sqrts @ %def process_instance_get_sqrts @ Get the polarizations <>= procedure :: get_polarization => process_instance_get_polarization <>= function process_instance_get_polarization (instance) result (pol) class(process_instance_t), intent(in) :: instance real(default), dimension(2) :: pol pol = instance%process%get_polarization () end function process_instance_get_polarization @ %def process_instance_get_polarization @ Get the beam spectrum <>= procedure :: get_beam_file => process_instance_get_beam_file <>= function process_instance_get_beam_file (instance) result (file) class(process_instance_t), intent(in) :: instance type(string_t) :: file file = instance%process%get_beam_file () end function process_instance_get_beam_file @ %def process_instance_get_beam_file @ Get the process name <>= procedure :: get_process_name => process_instance_get_process_name <>= function process_instance_get_process_name (instance) result (name) class(process_instance_t), intent(in) :: instance type(string_t) :: name name = instance%process%get_id () end function process_instance_get_process_name @ %def process_instance_get_process_name @ \subsubsection{Particle sets} Here we provide two procedures that convert the process instance from/to a particle set. The conversion applies to the trace evaluator which has no quantum-number information, thus it involves only the momenta and the parent-child relations. We keep virtual particles. If [[n_incoming]] is provided, the status code of the first [[n_incoming]] particles will be reset to incoming. Otherwise, they would be classified as virtual. Nevertheless, it is possible to reconstruct the complete structure from a particle set. The reconstruction implies a re-evaluation of the structure function and matrix-element codes. The [[i_term]] index is needed for both input and output, to select among different active trace evaluators. In both cases, the [[instance]] object must be properly initialized. NB: The [[recover_beams]] option should be used only when the particle set originates from an external event file, and the user has asked for it. It should be switched off when reading from raw event file. <>= procedure :: get_trace => process_instance_get_trace procedure :: set_trace => process_instance_set_trace <>= subroutine process_instance_get_trace (instance, pset, i_term, n_incoming) class(process_instance_t), intent(in), target :: instance type(particle_set_t), intent(out) :: pset integer, intent(in) :: i_term integer, intent(in), optional :: n_incoming type(interaction_t), pointer :: int logical :: ok int => instance%get_trace_int_ptr (i_term) call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true., n_incoming) end subroutine process_instance_get_trace subroutine process_instance_set_trace & (instance, pset, i_term, recover_beams, check_match) class(process_instance_t), intent(inout), target :: instance type(particle_set_t), intent(in) :: pset integer, intent(in) :: i_term logical, intent(in), optional :: recover_beams, check_match type(interaction_t), pointer :: int integer :: n_in int => instance%get_trace_int_ptr (i_term) n_in = instance%process%get_n_in () call pset%fill_interaction (int, n_in, & recover_beams = recover_beams, & check_match = check_match, & state_flv = instance%get_state_flv (i_term)) end subroutine process_instance_set_trace @ %def process_instance_get_trace @ %def process_instance_set_trace @ This procedure allows us to override any QCD setting of the WHIZARD process and directly set the coupling value that comes together with a particle set. <>= procedure :: set_alpha_qcd_forced => process_instance_set_alpha_qcd_forced <>= subroutine process_instance_set_alpha_qcd_forced (instance, i_term, alpha_qcd) class(process_instance_t), intent(inout) :: instance integer, intent(in) :: i_term real(default), intent(in) :: alpha_qcd call instance%term(i_term)%set_alpha_qcd_forced (alpha_qcd) end subroutine process_instance_set_alpha_qcd_forced @ %def process_instance_set_alpha_qcd_forced @ <>= procedure :: has_nlo_component => process_instance_has_nlo_component <>= function process_instance_has_nlo_component (instance) result (nlo) class(process_instance_t), intent(in) :: instance logical :: nlo nlo = instance%process%is_nlo_calculation () end function process_instance_has_nlo_component @ %def process_instance_has_nlo_component @ <>= procedure :: keep_failed_events => process_instance_keep_failed_events <>= function process_instance_keep_failed_events (instance) result (keep) logical :: keep class(process_instance_t), intent(in) :: instance keep = instance%mci_work(instance%i_mci)%keep_failed_events end function process_instance_keep_failed_events @ %def process_instance_keep_failed_events @ <>= procedure :: get_term_indices => process_instance_get_term_indices <>= function process_instance_get_term_indices (instance, nlo_type) result (i_term) integer, dimension(:), allocatable :: i_term class(process_instance_t), intent(in) :: instance integer :: nlo_type allocate (i_term (count (instance%term%nlo_type == nlo_type))) i_term = pack (instance%term%get_i_term_global (), instance%term%nlo_type == nlo_type) end function process_instance_get_term_indices @ %def process_instance_get_term_indices @ <>= procedure :: get_boost_to_lab => process_instance_get_boost_to_lab <>= function process_instance_get_boost_to_lab (instance, i_term) result (lt) type(lorentz_transformation_t) :: lt class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term lt = instance%term(i_term)%get_boost_to_lab () end function process_instance_get_boost_to_lab @ %def process_instance_get_boost_to_lab @ <>= procedure :: get_boost_to_cms => process_instance_get_boost_to_cms <>= function process_instance_get_boost_to_cms (instance, i_term) result (lt) type(lorentz_transformation_t) :: lt class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term lt = instance%term(i_term)%get_boost_to_cms () end function process_instance_get_boost_to_cms @ %def process_instance_get_boost_to_cms @ <>= procedure :: is_cm_frame => process_instance_is_cm_frame <>= function process_instance_is_cm_frame (instance, i_term) result (cm_frame) logical :: cm_frame class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term cm_frame = instance%term(i_term)%k_term%phs%is_cm_frame () end function process_instance_is_cm_frame @ %def protcess_instance_is_cm_frame @ The [[pacify]] subroutine has the purpose of setting numbers to zero which are (by comparing with a [[tolerance]] parameter) considered equivalent with zero. We do this in some unit tests. Here, we a apply this to the phase space subobject of the process instance. <>= public :: pacify <>= interface pacify module procedure pacify_process_instance end interface pacify <>= subroutine pacify_process_instance (instance) type(process_instance_t), intent(inout) :: instance integer :: i do i = 1, size (instance%term) call pacify (instance%term(i)%k_term%phs) end do end subroutine pacify_process_instance @ %def pacify @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Unit tests} Test module, followed by the corresponding implementation module. <<[[processes_ut.f90]]>>= <> module processes_ut use unit_tests use processes_uti <> <> <> contains <> end module processes_ut @ %def processes_ut @ <<[[processes_uti.f90]]>>= <> module processes_uti <> <> use format_utils, only: write_separator use constants, only: TWOPI4 use physics_defs, only: CONV use os_interface use sm_qcd use lorentz use pdg_arrays use model_data use models use var_base, only: vars_t use variables, only: var_list_t use model_testbed, only: prepare_model use particle_specifiers, only: new_prt_spec use flavors use interactions, only: reset_interaction_counter use particles use rng_base use mci_base use mci_none, only: mci_none_t use mci_midpoint use sf_mappings use sf_base use phs_base use phs_single use phs_forests, only: syntax_phs_forest_init, syntax_phs_forest_final use phs_wood, only: phs_wood_config_t use resonances, only: resonance_history_set_t use process_constants use prc_core_def, only: prc_core_def_t use prc_core use prc_test, only: prc_test_create_library use prc_template_me, only: template_me_def_t use process_libraries use prc_test_core use process_counter use process_config, only: process_term_t use process, only: process_t use instances, only: process_instance_t, process_instance_hook_t use rng_base_ut, only: rng_test_factory_t use sf_base_ut, only: sf_test_data_t use mci_base_ut, only: mci_test_t use phs_base_ut, only: phs_test_config_t <> <> <> <> contains <> <> end module processes_uti @ %def processes_uti @ API: driver for the unit tests below. <>= public :: processes_test <>= subroutine processes_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine processes_test @ %def processes_test \subsubsection{Write an empty process object} The most trivial test is to write an uninitialized process object. <>= call test (processes_1, "processes_1", & "write an empty process object", & u, results) <>= public :: processes_1 <>= subroutine processes_1 (u) integer, intent(in) :: u type(process_t) :: process write (u, "(A)") "* Test output: processes_1" write (u, "(A)") "* Purpose: display an empty process object" write (u, "(A)") call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Test output end: processes_1" end subroutine processes_1 @ %def processes_1 @ \subsubsection{Initialize a process object} Initialize a process and display it. <>= call test (processes_2, "processes_2", & "initialize a simple process object", & u, results) <>= public :: processes_2 <>= subroutine processes_2 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable :: process class(mci_t), allocatable :: mci_template class(phs_config_t), allocatable :: phs_config_template write (u, "(A)") "* Test output: processes_2" write (u, "(A)") "* Purpose: initialize a simple process object" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes2" procname = libname call os_data%init () call prc_test_create_library (libname, lib) write (u, "(A)") "* Initialize a process object" write (u, "(A)") call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%set_run_id (var_str ("run_2")) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) call process%setup_mci (dispatch_mci_empty) call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_2" end subroutine processes_2 @ %def processes_2 @ Trivial for testing: do not allocate the MCI record. <>= subroutine dispatch_mci_empty (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo end subroutine dispatch_mci_empty @ %def dispatch_mci_empty @ \subsubsection{Compute a trivial matrix element} Initialize a process, retrieve some information and compute a matrix element. We use the same trivial process as for the previous test. All momentum and state dependence is trivial, so we just test basic functionality. <>= call test (processes_3, "processes_3", & "retrieve a trivial matrix element", & u, results) <>= public :: processes_3 <>= subroutine processes_3 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable :: process class(phs_config_t), allocatable :: phs_config_template type(process_constants_t) :: data type(vector4_t), dimension(:), allocatable :: p write (u, "(A)") "* Test output: processes_3" write (u, "(A)") "* Purpose: create a process & &and compute a matrix element" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes3" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) call process%setup_mci (dispatch_mci_test3) write (u, "(A)") "* Return the number of process components" write (u, "(A)") write (u, "(A,I0)") "n_components = ", process%get_n_components () write (u, "(A)") write (u, "(A)") "* Return the number of flavor states" write (u, "(A)") data = process%get_constants (1) write (u, "(A,I0)") "n_flv(1) = ", data%n_flv write (u, "(A)") write (u, "(A)") "* Return the first flavor state" write (u, "(A)") write (u, "(A,4(1x,I0))") "flv_state(1) =", data%flv_state (:,1) write (u, "(A)") write (u, "(A)") "* Set up kinematics & &[arbitrary, the matrix element is constant]" allocate (p (4)) write (u, "(A)") write (u, "(A)") "* Retrieve the matrix element" write (u, "(A)") write (u, "(A,F5.3,' + ',F5.3,' I')") "me (1, p, 1, 1, 1) = ", & process%compute_amplitude (1, 1, 1, p, 1, 1, 1) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_3" end subroutine processes_3 @ %def processes_3 @ MCI record with some contents. <>= subroutine dispatch_mci_test3 (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_test_t :: mci) select type (mci) type is (mci_test_t) call mci%set_dimensions (2, 2) call mci%set_divisions (100) end select end subroutine dispatch_mci_test3 @ %def dispatch_mci_test3 @ \subsubsection{Generate a process instance} Initialize a process and process instance, choose a sampling point and fill the process instance. We use the same trivial process as for the previous test. All momentum and state dependence is trivial, so we just test basic functionality. <>= call test (processes_4, "processes_4", & "create and fill a process instance (partonic event)", & u, results) <>= public :: processes_4 <>= subroutine processes_4 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_4" write (u, "(A)") "* Purpose: create a process & &and fill a process instance" write (u, "(A)") write (u, "(A)") "* Build and initialize a test process" write (u, "(A)") libname = "processes4" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_empty) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Inject a set of random numbers" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%set_mcpar ([0._default, 0._default]) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Set up hard kinematics" write (u, "(A)") call process_instance%select_channel (1) call process_instance%compute_seed_kinematics () call process_instance%compute_hard_kinematics () call process_instance%compute_eff_kinematics () call process_instance%evaluate_expressions () call process_instance%compute_other_channels () write (u, "(A)") "* Evaluate matrix element and square" write (u, "(A)") call process_instance%evaluate_trace () call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%activate () process_instance%evaluation_status = STAT_EFF_KINEMATICS call process_instance%recover_hard_kinematics (i_term = 1) call process_instance%recover_seed_kinematics (i_term = 1) call process_instance%select_channel (1) call process_instance%recover_mcpar (i_term = 1) call process_instance%compute_seed_kinematics (skip_term = 1) call process_instance%compute_hard_kinematics (skip_term = 1) call process_instance%compute_eff_kinematics (skip_term = 1) call process_instance%evaluate_expressions () call process_instance%compute_other_channels (skip_term = 1) call process_instance%evaluate_trace () call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_4" end subroutine processes_4 @ %def processes_4 @ \subsubsection{Structure function configuration} Configure structure functions (multi-channel) in a process object. <>= call test (processes_7, "processes_7", & "process configuration with structure functions", & u, results) <>= public :: processes_7 <>= subroutine processes_7 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_channel_t), dimension(2) :: sf_channel write (u, "(A)") "* Test output: processes_7" write (u, "(A)") "* Purpose: initialize a process with & &structure functions" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes7" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Set beam, structure functions, and mappings" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (process%get_model_ptr (), pdg_in) end select allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call process%init_sf_chain (sf_config) deallocate (sf_config) call process%test_allocate_sf_channels (3) call sf_channel(1)%init (2) call sf_channel(1)%activate_mapping ([1,2]) call process%set_sf_channel (2, sf_channel(1)) call sf_channel(2)%init (2) call sf_channel(2)%set_s_mapping ([1,2]) call process%set_sf_channel (3, sf_channel(2)) call process%setup_mci (dispatch_mci_empty) call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_7" end subroutine processes_7 @ %def processes_7 @ \subsubsection{Evaluating a process with structure function} Configure structure functions (single-channel) in a process object, create an instance, compute kinematics and evaluate. Note the order of operations when setting up structure functions and phase space. The beams are first, they determine the [[sqrts]] value. We can also set up the chain of structure functions. We then configure the phase space. From this, we can obtain information about special configurations (resonances, etc.), which we need for allocating the possible structure-function channels (parameterizations and mappings). Finally, we match phase-space channels onto structure-function channels. In the current example, this matching is trivial; we only have one structure-function channel. <>= call test (processes_8, "processes_8", & "process evaluation with structure functions", & u, results) <>= public :: processes_8 <>= subroutine processes_8 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_channel_t) :: sf_channel type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_8" write (u, "(A)") "* Purpose: evaluate a process with & &structure functions" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes8" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Set beam, structure functions, and mappings" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (process%get_model_ptr (), pdg_in) end select allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call process%init_sf_chain (sf_config) deallocate (sf_config) call process%configure_phs () call process%test_allocate_sf_channels (1) call sf_channel%init (2) call sf_channel%activate_mapping ([1,2]) call process%set_sf_channel (1, sf_channel) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_mci (dispatch_mci_empty) call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") "* Set up kinematics and evaluate" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%evaluate_sqme (1, & [0.8_default, 0.8_default, 0.1_default, 0.2_default]) call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover process instance" write (u, "(A)") call reset_interaction_counter (2) allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover & (channel = 1, i_term = 1, update_sqme = .true., recover_phs = .true.) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_8" end subroutine processes_8 @ %def processes_8 @ \subsubsection{Multi-channel phase space and structure function} This is an extension of the previous example. This time, we have two distinct structure-function channels which are matched to the two distinct phase-space channels. <>= call test (processes_9, "processes_9", & "multichannel kinematics and structure functions", & u, results) <>= public :: processes_9 <>= subroutine processes_9 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_channel_t) :: sf_channel real(default), dimension(4) :: x_saved type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_9" write (u, "(A)") "* Purpose: evaluate a process with & &structure functions" write (u, "(A)") "* in a multi-channel configuration" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes9" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Set beam, structure functions, and mappings" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (process%get_model_ptr (), pdg_in) end select allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call process%init_sf_chain (sf_config) deallocate (sf_config) call process%configure_phs () call process%test_allocate_sf_channels (2) call sf_channel%init (2) call process%set_sf_channel (1, sf_channel) call sf_channel%init (2) call sf_channel%activate_mapping ([1,2]) call process%set_sf_channel (2, sf_channel) call process%test_set_component_sf_channel ([1, 2]) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_mci (dispatch_mci_empty) call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") "* Set up kinematics in channel 1 and evaluate" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%evaluate_sqme (1, & [0.8_default, 0.8_default, 0.1_default, 0.2_default]) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Extract MC input parameters" write (u, "(A)") write (u, "(A)") "Channel 1:" call process_instance%get_mcpar (1, x_saved) write (u, "(2x,9(1x,F7.5))") x_saved write (u, "(A)") "Channel 2:" call process_instance%get_mcpar (2, x_saved) write (u, "(2x,9(1x,F7.5))") x_saved write (u, "(A)") write (u, "(A)") "* Set up kinematics in channel 2 and evaluate" write (u, "(A)") call process_instance%evaluate_sqme (2, x_saved) call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Recover process instance for channel 2" write (u, "(A)") call reset_interaction_counter (2) allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover & (channel = 2, i_term = 1, update_sqme = .true., recover_phs = .true.) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_9" end subroutine processes_9 @ %def processes_9 @ \subsubsection{Event generation} Activate the MC integrator for the process object and use it to generate a single event. Note that the test integrator does not require integration in preparation for generating events. <>= call test (processes_10, "processes_10", & "event generation", & u, results) <>= public :: processes_10 <>= subroutine processes_10 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(mci_t), pointer :: mci class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: processes_10" write (u, "(A)") "* Purpose: generate events for a process without & &structure functions" write (u, "(A)") "* in a multi-channel configuration" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes10" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test10) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") "* Generate weighted event" write (u, "(A)") call process%test_get_mci_ptr (mci) select type (mci) type is (mci_test_t) ! This ensures that the next 'random' numbers are 0.3, 0.5, 0.7 call mci%rng%init (3) ! Include the constant PHS factor in the stored maximum of the integrand call mci%set_max_factor (conv * twopi4 & / (2 * sqrt (lambda (sqrts **2, 125._default**2, 125._default**2)))) end select call process_instance%generate_weighted_event (1) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Generate unweighted event" write (u, "(A)") call process_instance%generate_unweighted_event (1) call process%test_get_mci_ptr (mci) select type (mci) type is (mci_test_t) write (u, "(A,I0)") " Success in try ", mci%tries write (u, "(A)") end select call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_10" end subroutine processes_10 @ %def processes_10 @ MCI record with some contents. <>= subroutine dispatch_mci_test10 (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_test_t :: mci) select type (mci) type is (mci_test_t); call mci%set_divisions (100) end select end subroutine dispatch_mci_test10 @ %def dispatch_mci_test10 @ \subsubsection{Integration} Activate the MC integrator for the process object and use it to integrate over phase space. <>= call test (processes_11, "processes_11", & "integration", & u, results) <>= public :: processes_11 <>= subroutine processes_11 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(mci_t), allocatable :: mci_template class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: processes_11" write (u, "(A)") "* Purpose: integrate a process without & &structure functions" write (u, "(A)") "* in a multi-channel configuration" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes11" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test10) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") "* Integrate with default test parameters" write (u, "(A)") call process_instance%integrate (1, n_it=1, n_calls=10000) call process%final_integration (1) call process%write (.false., u) write (u, "(A)") write (u, "(A,ES13.7)") " Integral divided by phs factor = ", & process%get_integral (1) & / process_instance%term(1)%k_term%phs_factor write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_11" end subroutine processes_11 @ %def processes_11 @ \subsubsection{Complete events} For the purpose of simplifying further tests, we implement a convenience routine that initializes a process and prepares a single event. This is a wrapup of the test [[processes_10]]. The procedure is re-exported by the [[processes_ut]] module. <>= public :: prepare_test_process <>= subroutine prepare_test_process & (process, process_instance, model, var_list, run_id) type(process_t), intent(out), target :: process type(process_instance_t), intent(out), target :: process_instance class(model_data_t), intent(in), target :: model type(var_list_t), intent(inout), optional :: var_list type(string_t), intent(in), optional :: run_id type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), allocatable, target :: process_model class(mci_t), pointer :: mci class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts libname = "processes_test" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call reset_interaction_counter () allocate (process_model) call process_model%init (model%get_name (), & model%get_n_real (), & model%get_n_complex (), & model%get_n_field (), & model%get_n_vtx ()) call process_model%copy_from (model) call process%init (procname, lib, os_data, process_model, var_list) if (present (run_id)) call process%set_run_id (run_id) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test10) call process%setup_terms () call process_instance%init (process) call process%test_get_mci_ptr (mci) select type (mci) type is (mci_test_t) ! This ensures that the next 'random' numbers are 0.3, 0.5, 0.7 call mci%rng%init (3) ! Include the constant PHS factor in the stored maximum of the integrand call mci%set_max_factor (conv * twopi4 & / (2 * sqrt (lambda (sqrts **2, 125._default**2, 125._default**2)))) end select call process%reset_library_ptr () ! avoid dangling pointer call process_model%final () end subroutine prepare_test_process @ %def prepare_test_process @ Here we do the cleanup of the process and process instance emitted by the previous routine. <>= public :: cleanup_test_process <>= subroutine cleanup_test_process (process, process_instance) type(process_t), intent(inout) :: process type(process_instance_t), intent(inout) :: process_instance call process_instance%final () call process%final () end subroutine cleanup_test_process @ %def cleanup_test_process @ This is the actual test. Prepare the test process and event, fill all evaluators, and display the results. Use a particle set as temporary storage, read kinematics and recalculate the event. <>= call test (processes_12, "processes_12", & "event post-processing", & u, results) <>= public :: processes_12 <>= subroutine processes_12 (u) integer, intent(in) :: u type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(particle_set_t) :: pset type(model_data_t), target :: model write (u, "(A)") "* Test output: processes_12" write (u, "(A)") "* Purpose: generate a complete partonic event" write (u, "(A)") call model%init_test () write (u, "(A)") "* Build and initialize process and process instance & &and generate event" write (u, "(A)") allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model, & run_id = var_str ("run_12")) call process_instance%setup_event_data (i_core = 1) call process%prepare_simulation (1) call process_instance%init_simulation (1) call process_instance%generate_weighted_event (1) call process_instance%evaluate_event_data () call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final_simulation (1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Recover kinematics and recalculate" write (u, "(A)") call reset_interaction_counter (2) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover & (channel = 1, i_term = 1, update_sqme = .true., recover_phs = .true.) call process_instance%recover_event () call process_instance%evaluate_event_data () call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_12" end subroutine processes_12 @ %def processes_12 @ \subsubsection{Colored interaction} This test specifically checks the transformation of process data (flavor, helicity, and color) into an interaction in a process term. We use the [[test_t]] process core (which has no nontrivial particles), but call only the [[is_allowed]] method, which always returns true. <>= call test (processes_13, "processes_13", & "colored interaction", & u, results) <>= public :: processes_13 <>= subroutine processes_13 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(process_term_t) :: term class(prc_core_t), allocatable :: core write (u, "(A)") "* Test output: processes_13" write (u, "(A)") "* Purpose: initialized a colored interaction" write (u, "(A)") write (u, "(A)") "* Set up a process constants block" write (u, "(A)") call os_data%init () call model%init_sm_test () allocate (test_t :: core) associate (data => term%data) data%n_in = 2 data%n_out = 3 data%n_flv = 2 data%n_hel = 2 data%n_col = 2 data%n_cin = 2 allocate (data%flv_state (5, 2)) data%flv_state (:,1) = [ 1, 21, 1, 21, 21] data%flv_state (:,2) = [ 2, 21, 2, 21, 21] allocate (data%hel_state (5, 2)) data%hel_state (:,1) = [1, 1, 1, 1, 0] data%hel_state (:,2) = [1,-1, 1,-1, 0] allocate (data%col_state (2, 5, 2)) data%col_state (:,:,1) = & reshape ([[1, 0], [2,-1], [3, 0], [2,-3], [0,0]], [2,5]) data%col_state (:,:,2) = & reshape ([[1, 0], [2,-3], [3, 0], [2,-1], [0,0]], [2,5]) allocate (data%ghost_flag (5, 2)) data%ghost_flag(1:4,:) = .false. data%ghost_flag(5,:) = .true. end associate write (u, "(A)") "* Set up the interaction" write (u, "(A)") call reset_interaction_counter () call term%setup_interaction (core, model) call term%int%basic_write (u) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_13" end subroutine processes_13 @ %def processes_13 @ \subsubsection{MD5 sums} Configure a process with structure functions (multi-channel) and compute MD5 sums <>= call test (processes_14, "processes_14", & "process configuration and MD5 sum", & u, results) <>= public :: processes_14 <>= subroutine processes_14 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_channel_t), dimension(3) :: sf_channel write (u, "(A)") "* Test output: processes_14" write (u, "(A)") "* Purpose: initialize a process with & &structure functions" write (u, "(A)") "* and compute MD5 sum" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes7" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call lib%compute_md5sum () call model%init_test () allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_test_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Set beam, structure functions, and mappings" write (u, "(A)") sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (process%get_model_ptr (), pdg_in) end select call process%test_allocate_sf_channels (3) allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call process%init_sf_chain (sf_config) deallocate (sf_config) call sf_channel(1)%init (2) call process%set_sf_channel (1, sf_channel(1)) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([1,2]) call process%set_sf_channel (2, sf_channel(2)) call sf_channel(3)%init (2) call sf_channel(3)%set_s_mapping ([1,2]) call process%set_sf_channel (3, sf_channel(3)) call process%setup_mci (dispatch_mci_empty) call process%compute_md5sum () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_14" end subroutine processes_14 @ %def processes_14 @ \subsubsection{Decay Process Evaluation} Initialize an evaluate a decay process. <>= call test (processes_15, "processes_15", & "decay process", & u, results) <>= public :: processes_15 <>= subroutine processes_15 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template type(process_instance_t), allocatable, target :: process_instance type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_15" write (u, "(A)") "* Purpose: initialize a decay process object" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes15" procname = libname call os_data%init () call prc_test_create_library (libname, lib, scattering = .false., & decay = .true.) call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) write (u, "(A)") "* Initialize a process object" write (u, "(A)") allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_single_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") call process%setup_beams_decay (i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_empty) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") call reset_interaction_counter (3) allocate (process_instance) call process_instance%init (process) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Inject a set of random numbers" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%set_mcpar ([0._default, 0._default]) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Set up hard kinematics" write (u, "(A)") call process_instance%select_channel (1) call process_instance%compute_seed_kinematics () call process_instance%compute_hard_kinematics () write (u, "(A)") "* Evaluate matrix element and square" write (u, "(A)") call process_instance%compute_eff_kinematics () call process_instance%evaluate_expressions () call process_instance%compute_other_channels () call process_instance%evaluate_trace () call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover process instance" write (u, "(A)") call reset_interaction_counter (3) allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover (1, 1, .true., .true.) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_15" end subroutine processes_15 @ %def processes_15 @ \subsubsection{Integration: decay} Activate the MC integrator for the decay object and use it to integrate over phase space. <>= call test (processes_16, "processes_16", & "decay integration", & u, results) <>= public :: processes_16 <>= subroutine processes_16 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: processes_16" write (u, "(A)") "* Purpose: integrate a process without & &structure functions" write (u, "(A)") "* in a multi-channel configuration" write (u, "(A)") write (u, "(A)") "* Build and initialize a process object" write (u, "(A)") libname = "processes16" procname = libname call os_data%init () call prc_test_create_library (libname, lib, scattering = .false., & decay = .true.) call reset_interaction_counter () call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_single_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") call process%setup_beams_decay (i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test_midpoint) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") allocate (process_instance) call process_instance%init (process) write (u, "(A)") "* Integrate with default test parameters" write (u, "(A)") call process_instance%integrate (1, n_it=1, n_calls=10000) call process%final_integration (1) call process%write (.false., u) write (u, "(A)") write (u, "(A,ES13.7)") " Integral divided by phs factor = ", & process%get_integral (1) & / process_instance%term(1)%k_term%phs_factor write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_16" end subroutine processes_16 @ %def processes_16 @ MCI record prepared for midpoint integrator. <>= subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_midpoint_t :: mci) end subroutine dispatch_mci_test_midpoint @ %def dispatch_mci_test_midpoint @ \subsubsection{Decay Process Evaluation} Initialize an evaluate a decay process for a moving particle. <>= call test (processes_17, "processes_17", & "decay of moving particle", & u, results) <>= public :: processes_17 <>= subroutine processes_17 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template type(process_instance_t), allocatable, target :: process_instance type(particle_set_t) :: pset type(flavor_t) :: flv_beam real(default) :: m, p, E write (u, "(A)") "* Test output: processes_17" write (u, "(A)") "* Purpose: initialize a decay process object" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes17" procname = libname call os_data%init () call prc_test_create_library (libname, lib, scattering = .false., & decay = .true.) write (u, "(A)") "* Initialize a process object" write (u, "(A)") call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) allocate (process) call process%init (procname, lib, os_data, model) call process%setup_test_cores () allocate (phs_single_config_t :: phs_config_template) call process%init_components (phs_config_template) write (u, "(A)") "* Prepare a trivial beam setup" write (u, "(A)") call process%setup_beams_decay (rest_frame = .false., i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_empty) write (u, "(A)") "* Complete process initialization" write (u, "(A)") call process%setup_terms () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Create a process instance" write (u, "(A)") call reset_interaction_counter (3) allocate (process_instance) call process_instance%init (process) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Set parent momentum and random numbers" write (u, "(A)") call process_instance%choose_mci (1) call process_instance%set_mcpar ([0._default, 0._default]) call flv_beam%init (25, process%get_model_ptr ()) m = flv_beam%get_mass () p = 3 * m / 4 E = sqrt (m**2 + p**2) call process_instance%set_beam_momenta ([vector4_moving (E, p, 3)]) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Set up hard kinematics" write (u, "(A)") call process_instance%select_channel (1) call process_instance%compute_seed_kinematics () call process_instance%compute_hard_kinematics () write (u, "(A)") "* Evaluate matrix element and square" write (u, "(A)") call process_instance%compute_eff_kinematics () call process_instance%evaluate_expressions () call process_instance%compute_other_channels () call process_instance%evaluate_trace () call process_instance%write (u) call process_instance%get_trace (pset, 1) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover process instance" write (u, "(A)") call reset_interaction_counter (3) allocate (process_instance) call process_instance%init (process) call process_instance%choose_mci (1) call process_instance%set_trace (pset, 1, check_match = .false.) call process_instance%recover (1, 1, .true., .true.) call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call pset%final () call process_instance%final () deallocate (process_instance) call process%final () deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_17" end subroutine processes_17 @ %def processes_17 @ \subsubsection{Resonances in Phase Space} This test demonstrates the extraction of the resonance-history set from the generated phase space. We need a nontrivial process, but no matrix element. This is provided by the [[prc_template]] method, using the [[SM]] model. We also need the [[phs_wood]] method, otherwise we would not have resonances in the phase space configuration. <>= call test (processes_18, "processes_18", & "extract resonance history set", & u, results) <>= public :: processes_18 <>= subroutine processes_18 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(string_t) :: model_name type(os_data_t) :: os_data class(model_data_t), pointer :: model class(vars_t), pointer :: vars type(process_t), pointer :: process type(resonance_history_set_t) :: res_set integer :: i write (u, "(A)") "* Test output: processes_18" write (u, "(A)") "* Purpose: extra resonance histories" write (u, "(A)") write (u, "(A)") "* Build and load a test library with one process" write (u, "(A)") libname = "processes_18_lib" procname = "processes_18_p" call os_data%init () call syntax_phs_forest_init () model_name = "SM" model => null () call prepare_model (model, model_name, vars) write (u, "(A)") "* Initialize a process library with one process" write (u, "(A)") select type (model) class is (model_t) call prepare_resonance_test_library (lib, libname, procname, model, os_data, u) end select write (u, "(A)") write (u, "(A)") "* Initialize a process object with phase space" allocate (process) select type (model) class is (model_t) call prepare_resonance_test_process (process, lib, procname, model, os_data) end select write (u, "(A)") write (u, "(A)") "* Extract resonance history set" write (u, "(A)") call process%extract_resonance_history_set (res_set) call res_set%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call process%final () deallocate (process) call model%final () deallocate (model) call syntax_phs_forest_final () write (u, "(A)") write (u, "(A)") "* Test output end: processes_18" end subroutine processes_18 @ %def processes_18 @ Auxiliary subroutine that constructs the process library for the above test. <>= subroutine prepare_resonance_test_library & (lib, libname, procname, model, os_data, u) type(process_library_t), target, intent(out) :: lib type(string_t), intent(in) :: libname type(string_t), intent(in) :: procname type(model_t), intent(in), target :: model type(os_data_t), intent(in) :: os_data integer, intent(in) :: u type(string_t), dimension(:), allocatable :: prt_in, prt_out class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry call lib%init (libname) allocate (prt_in (2), prt_out (3)) prt_in = [var_str ("e+"), var_str ("e-")] prt_out = [var_str ("d"), var_str ("ubar"), var_str ("W+")] allocate (template_me_def_t :: def) select type (def) type is (template_me_def_t) call def%init (model, prt_in, prt_out, unity = .false.) end select allocate (entry) call entry%init (procname, & model_name = model%get_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 ("template"), & variant = def) call entry%write (u) call lib%append (entry) call lib%configure (os_data) call lib%write_makefile (os_data, force = .true., verbose = .false.) call lib%clean (os_data, distclean = .false.) call lib%write_driver (force = .true.) call lib%load (os_data) end subroutine prepare_resonance_test_library @ %def prepare_resonance_test_library @ We want a test process which has been initialized up to the point where we can evaluate the matrix element. This is in fact rather complicated. We copy the steps from [[integration_setup_process]] in the [[integrate]] module, which is not available at this point. <>= subroutine prepare_resonance_test_process & (process, lib, procname, model, os_data) class(process_t), intent(out), target :: process type(process_library_t), intent(in), target :: lib type(string_t), intent(in) :: procname type(model_t), intent(in), target :: model type(os_data_t), intent(in) :: os_data class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts call process%init (procname, lib, os_data, model) allocate (phs_wood_config_t :: phs_config_template) call process%init_components (phs_config_template) call process%setup_test_cores (type_string = var_str ("template")) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_none) call process%setup_terms () end subroutine prepare_resonance_test_process @ %def prepare_resonance_test_process @ MCI record prepared for the none (dummy) integrator. <>= subroutine dispatch_mci_none (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_none_t :: mci) end subroutine dispatch_mci_none @ %def dispatch_mci_none @ \subsubsection{Add after evaluate hook(s)} Initialize a process and process instance, add a trivial process hook, choose a sampling point and fill the process instance. We use the same trivial process as for the previous test. All momentum and state dependence is trivial, so we just test basic functionality. <>= type, extends(process_instance_hook_t) :: process_instance_hook_test_t integer :: unit character(len=15) :: name contains procedure :: init => process_instance_hook_test_init procedure :: final => process_instance_hook_test_final procedure :: evaluate => process_instance_hook_test_evaluate end type process_instance_hook_test_t @ <>= subroutine process_instance_hook_test_init (hook, var_list, instance) class(process_instance_hook_test_t), intent(inout), target :: hook type(var_list_t), intent(in) :: var_list class(process_instance_t), intent(in), target :: instance end subroutine process_instance_hook_test_init subroutine process_instance_hook_test_final (hook) class(process_instance_hook_test_t), intent(inout) :: hook end subroutine process_instance_hook_test_final subroutine process_instance_hook_test_evaluate (hook, instance) class(process_instance_hook_test_t), intent(inout) :: hook class(process_instance_t), intent(in), target :: instance write (hook%unit, "(A)") "Execute hook:" write (hook%unit, "(2X,A,1X,A,I0,A)") hook%name, "(", len (trim (hook%name)), ")" end subroutine process_instance_hook_test_evaluate @ <>= call test (processes_19, "processes_19", & "add trivial hooks to a process instance ", & u, results) <>= public :: processes_19 <>= subroutine processes_19 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_t), allocatable, target :: process class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_instance_t) :: process_instance class(process_instance_hook_t), allocatable, target :: process_instance_hook, process_instance_hook2 type(particle_set_t) :: pset write (u, "(A)") "* Test output: processes_19" write (u, "(A)") "* Purpose: allocate process instance & &and add an after evaluate hook" write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Allocate a process instance" write (u, "(A)") call process_instance%write (u) write (u, "(A)") write (u, "(A)") "* Allocate hook and add to process instance" write (u, "(A)") allocate (process_instance_hook_test_t :: process_instance_hook) call process_instance%append_after_hook (process_instance_hook) allocate (process_instance_hook_test_t :: process_instance_hook2) call process_instance%append_after_hook (process_instance_hook2) select type (process_instance_hook) type is (process_instance_hook_test_t) process_instance_hook%unit = u process_instance_hook%name = "Hook 1" end select select type (process_instance_hook2) type is (process_instance_hook_test_t) process_instance_hook2%unit = u process_instance_hook2%name = "Hook 2" end select write (u, "(A)") "* Evaluate matrix element and square" write (u, "(A)") call process_instance%evaluate_after_hook () write (u, "(A)") write (u, "(A)") "* Cleanup" call process_instance_hook%final () deallocate (process_instance_hook) write (u, "(A)") write (u, "(A)") "* Test output end: processes_19" end subroutine processes_19 @ %def processes_19 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process Stacks} For storing and handling multiple processes, we define process stacks. These are ordinary stacks where new process entries are pushed onto the top. We allow for multiple entries with identical process ID, but distinct run ID. The implementation is essentially identical to the [[prclib_stacks]] module above. Unfortunately, Fortran supports no generic programming, so we do not make use of this fact. When searching for a specific process ID, we will get (a pointer to) the topmost process entry with that ID on the stack, which was entered last. Usually, this is the best version of the process (in terms of integral, etc.) Thus the stack terminology makes sense. <<[[process_stacks.f90]]>>= <> module process_stacks <> <> use io_units use format_utils, only: write_separator use diagnostics use os_interface use sm_qcd use model_data use rng_base use variables use observables use process_libraries use process <> <> <> contains <> end module process_stacks @ %def process_stacks @ \subsection{The process entry type} A process entry is a process object, augmented by a pointer to the next entry. We do not need specific methods, all relevant methods are inherited. On higher level, processes should be prepared as process entry objects. <>= public :: process_entry_t <>= type, extends (process_t) :: process_entry_t type(process_entry_t), pointer :: next => null () end type process_entry_t @ %def process_entry_t @ \subsection{The process 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. The [[var_list]] component stores process-specific results, so they can be retrieved as (pseudo) variables. The process stack can be linked to another one. This allows us to work with stacks of local scope. <>= public :: process_stack_t <>= type :: process_stack_t integer :: n = 0 type(process_entry_t), pointer :: first => null () type(var_list_t), pointer :: var_list => null () type(process_stack_t), pointer :: next => null () contains <> end type process_stack_t @ %def process_stack_t @ Finalize partly: deallocate the process stack and variable list entries, but keep the variable list as an empty object. This way, the variable list links are kept. <>= procedure :: clear => process_stack_clear <>= subroutine process_stack_clear (stack) class(process_stack_t), intent(inout) :: stack type(process_entry_t), pointer :: process if (associated (stack%var_list)) then call stack%var_list%final () end if do while (associated (stack%first)) process => stack%first stack%first => process%next call process%final () deallocate (process) end do stack%n = 0 end subroutine process_stack_clear @ %def process_stack_clear @ Finalizer. Clear and deallocate the variable list. <>= procedure :: final => process_stack_final <>= subroutine process_stack_final (object) class(process_stack_t), intent(inout) :: object call object%clear () if (associated (object%var_list)) then deallocate (object%var_list) end if end subroutine process_stack_final @ %def process_stack_final @ Output. The processes on the stack will be ordered LIFO, i.e., backwards. <>= procedure :: write => process_stack_write <>= recursive subroutine process_stack_write (object, unit, pacify) class(process_stack_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify type(process_entry_t), pointer :: process integer :: u u = given_output_unit (unit) call write_separator (u, 2) select case (object%n) case (0) write (u, "(1x,A)") "Process stack: [empty]" call write_separator (u, 2) case default write (u, "(1x,A)") "Process stack:" process => object%first do while (associated (process)) call process%write (.false., u, pacify = pacify) process => process%next end do end select if (associated (object%next)) then write (u, "(1x,A)") "[Processes from context environment:]" call object%next%write (u, pacify) end if end subroutine process_stack_write @ %def process_stack_write @ The variable list is printed by a separate routine, since it should be linked to the global variable list, anyway. <>= procedure :: write_var_list => process_stack_write_var_list <>= subroutine process_stack_write_var_list (object, unit) class(process_stack_t), intent(in) :: object integer, intent(in), optional :: unit if (associated (object%var_list)) then call var_list_write (object%var_list, unit) end if end subroutine process_stack_write_var_list @ %def process_stack_write_var_list @ Short output. Since this is a stack, the default output ordering for each stack will be last-in, first-out. To enable first-in, first-out, which is more likely to be requested, there is an optional [[fifo]] argument. <>= procedure :: show => process_stack_show <>= recursive subroutine process_stack_show (object, unit, fifo) class(process_stack_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: fifo type(process_entry_t), pointer :: process logical :: reverse integer :: u, i, j u = given_output_unit (unit) reverse = .false.; if (present (fifo)) reverse = fifo select case (object%n) case (0) case default if (.not. reverse) then process => object%first do while (associated (process)) call process%show (u, verbose=.false.) process => process%next end do else do i = 1, object%n process => object%first do j = 1, object%n - i process => process%next end do call process%show (u, verbose=.false.) end do end if end select if (associated (object%next)) call object%next%show () end subroutine process_stack_show @ %def process_stack_show @ \subsection{Link} Link the current process stack to a global one. <>= procedure :: link => process_stack_link <>= subroutine process_stack_link (local_stack, global_stack) class(process_stack_t), intent(inout) :: local_stack type(process_stack_t), intent(in), target :: global_stack local_stack%next => global_stack end subroutine process_stack_link @ %def process_stack_link @ Initialize the process variable list and link the main variable list to it. <>= procedure :: init_var_list => process_stack_init_var_list <>= subroutine process_stack_init_var_list (stack, var_list) class(process_stack_t), intent(inout) :: stack type(var_list_t), intent(inout), optional :: var_list allocate (stack%var_list) if (present (var_list)) call var_list%link (stack%var_list) end subroutine process_stack_init_var_list @ %def process_stack_init_var_list @ Link the process variable list to a global variable list. <>= procedure :: link_var_list => process_stack_link_var_list <>= subroutine process_stack_link_var_list (stack, var_list) class(process_stack_t), intent(inout) :: stack type(var_list_t), intent(in), target :: var_list call stack%var_list%link (var_list) end subroutine process_stack_link_var_list @ %def process_stack_link_var_list @ \subsection{Push} We take a process pointer and push it onto the stack. The previous pointer is nullified. Subsequently, the process is `owned' by the stack and will be finalized when the stack is deleted. <>= procedure :: push => process_stack_push <>= subroutine process_stack_push (stack, process) class(process_stack_t), intent(inout) :: stack type(process_entry_t), intent(inout), pointer :: process process%next => stack%first stack%first => process process => null () stack%n = stack%n + 1 end subroutine process_stack_push @ %def process_stack_push @ Inverse: Remove the last process pointer in the list and return it. <>= procedure :: pop_last => process_stack_pop_last <>= subroutine process_stack_pop_last (stack, process) class(process_stack_t), intent(inout) :: stack type(process_entry_t), intent(inout), pointer :: process type(process_entry_t), pointer :: previous integer :: i select case (stack%n) case (:0) process => null () case (1) process => stack%first stack%first => null () stack%n = 0 case (2:) process => stack%first do i = 2, stack%n previous => process process => process%next end do previous%next => null () stack%n = stack%n - 1 end select end subroutine process_stack_pop_last @ %def process_stack_pop_last @ Initialize process variables for a given process ID, without setting values. <>= procedure :: init_result_vars => process_stack_init_result_vars <>= subroutine process_stack_init_result_vars (stack, id) class(process_stack_t), intent(inout) :: stack type(string_t), intent(in) :: id call var_list_init_num_id (stack%var_list, id) call var_list_init_process_results (stack%var_list, id) end subroutine process_stack_init_result_vars @ %def process_stack_init_result_vars @ Fill process variables with values. This is executed after the integration pass. Note: We set only integral and error. With multiple MCI records possible, the results for [[n_calls]], [[chi2]] etc. are not necessarily unique. (We might set the efficiency, though.) <>= procedure :: fill_result_vars => process_stack_fill_result_vars <>= subroutine process_stack_fill_result_vars (stack, id) class(process_stack_t), intent(inout) :: stack type(string_t), intent(in) :: id type(process_t), pointer :: process process => stack%get_process_ptr (id) if (associated (process)) then call var_list_init_num_id (stack%var_list, id, process%get_num_id ()) if (process%has_integral ()) then call var_list_init_process_results (stack%var_list, id, & integral = process%get_integral (), & error = process%get_error ()) end if else call msg_bug ("process_stack_fill_result_vars: unknown process ID") end if end subroutine process_stack_fill_result_vars @ %def process_stack_fill_result_vars @ If one of the result variables has a local image in [[var_list_local]], update the value there as well. <>= procedure :: update_result_vars => process_stack_update_result_vars <>= subroutine process_stack_update_result_vars (stack, id, var_list_local) class(process_stack_t), intent(inout) :: stack type(string_t), intent(in) :: id type(var_list_t), intent(inout) :: var_list_local call update ("integral(" // id // ")") call update ("error(" // id // ")") contains subroutine update (var_name) type(string_t), intent(in) :: var_name real(default) :: value if (var_list_local%contains (var_name, follow_link = .false.)) then value = stack%var_list%get_rval (var_name) call var_list_local%set_real (var_name, value, is_known = .true.) end if end subroutine update end subroutine process_stack_update_result_vars @ %def process_stack_update_result_vars @ \subsection{Data Access} Tell if a process exists. <>= procedure :: exists => process_stack_exists <>= function process_stack_exists (stack, id) result (flag) class(process_stack_t), intent(in) :: stack type(string_t), intent(in) :: id logical :: flag type(process_t), pointer :: process process => stack%get_process_ptr (id) flag = associated (process) end function process_stack_exists @ %def process_stack_exists @ Return a pointer to a process with specific ID. Look also at a linked stack, if necessary. <>= procedure :: get_process_ptr => process_stack_get_process_ptr <>= recursive function process_stack_get_process_ptr (stack, id) result (ptr) class(process_stack_t), intent(in) :: stack type(string_t), intent(in) :: id type(process_t), pointer :: ptr type(process_entry_t), pointer :: entry ptr => null () entry => stack%first do while (associated (entry)) if (entry%get_id () == id) then ptr => entry%process_t return end if entry => entry%next end do if (associated (stack%next)) ptr => stack%next%get_process_ptr (id) end function process_stack_get_process_ptr @ %def process_stack_get_process_ptr @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[process_stacks_ut.f90]]>>= <> module process_stacks_ut use unit_tests use process_stacks_uti <> <> contains <> end module process_stacks_ut @ %def process_stacks_ut @ <<[[process_stacks_uti.f90]]>>= <> module process_stacks_uti <> use os_interface use sm_qcd use models use model_data use variables, only: var_list_t use process_libraries use rng_base use prc_test, only: prc_test_create_library use process, only: process_t use instances, only: process_instance_t use processes_ut, only: prepare_test_process use process_stacks use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module process_stacks_uti @ %def process_stacks_uti @ API: driver for the unit tests below. <>= public :: process_stacks_test <>= subroutine process_stacks_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine process_stacks_test @ %def process_stacks_test @ \subsubsection{Write an empty process stack} The most trivial test is to write an uninitialized process stack. <>= call test (process_stacks_1, "process_stacks_1", & "write an empty process stack", & u, results) <>= public :: process_stacks_1 <>= subroutine process_stacks_1 (u) integer, intent(in) :: u type(process_stack_t) :: stack write (u, "(A)") "* Test output: process_stacks_1" write (u, "(A)") "* Purpose: display an empty process stack" write (u, "(A)") call stack%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_1" end subroutine process_stacks_1 @ %def process_stacks_1 @ \subsubsection{Fill a process stack} Fill a process stack with two (identical) processes. <>= call test (process_stacks_2, "process_stacks_2", & "fill a process stack", & u, results) <>= public :: process_stacks_2 <>= subroutine process_stacks_2 (u) integer, intent(in) :: u type(process_stack_t) :: stack type(process_library_t), target :: lib type(string_t) :: libname type(string_t) :: procname type(os_data_t) :: os_data type(model_t), target :: model type(var_list_t) :: var_list type(process_entry_t), pointer :: process => null () write (u, "(A)") "* Test output: process_stacks_2" write (u, "(A)") "* Purpose: fill a process stack" write (u, "(A)") write (u, "(A)") "* Build, initialize and store two test processes" write (u, "(A)") libname = "process_stacks2" procname = libname call os_data%init () call prc_test_create_library (libname, lib) call model%init_test () call var_list%append_string (var_str ("$run_id")) call var_list%append_log (var_str ("?alphas_is_fixed"), .true.) call var_list%append_int (var_str ("seed"), 0) allocate (process) call var_list%set_string & (var_str ("$run_id"), var_str ("run1"), is_known=.true.) call process%init (procname, lib, os_data, model, var_list) call stack%push (process) allocate (process) call var_list%set_string & (var_str ("$run_id"), var_str ("run2"), is_known=.true.) call process%init (procname, lib, os_data, model, var_list) call stack%push (process) call stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call stack%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_2" end subroutine process_stacks_2 @ %def process_stacks_2 @ \subsubsection{Fill a process stack} Fill a process stack with two (identical) processes. <>= call test (process_stacks_3, "process_stacks_3", & "process variables", & u, results) <>= public :: process_stacks_3 <>= subroutine process_stacks_3 (u) integer, intent(in) :: u type(process_stack_t) :: stack type(model_t), target :: model type(string_t) :: procname type(process_entry_t), pointer :: process => null () type(process_instance_t), target :: process_instance write (u, "(A)") "* Test output: process_stacks_3" write (u, "(A)") "* Purpose: setup process variables" write (u, "(A)") write (u, "(A)") "* Initialize process variables" write (u, "(A)") procname = "processes_test" call model%init_test () write (u, "(A)") "* Initialize process variables" write (u, "(A)") call stack%init_var_list () call stack%init_result_vars (procname) call stack%write_var_list (u) write (u, "(A)") write (u, "(A)") "* Build and integrate a test process" write (u, "(A)") allocate (process) call prepare_test_process (process%process_t, process_instance, model) call process_instance%integrate (1, 1, 1000) call process_instance%final () call process%final_integration (1) call stack%push (process) write (u, "(A)") "* Fill process variables" write (u, "(A)") call stack%fill_result_vars (procname) call stack%write_var_list (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call stack%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_3" end subroutine process_stacks_3 @ %def process_stacks_3 @ \subsubsection{Linked a process stack} Fill two process stack, linked to each other. <>= call test (process_stacks_4, "process_stacks_4", & "linked stacks", & u, results) <>= public :: process_stacks_4 <>= subroutine process_stacks_4 (u) integer, intent(in) :: u type(process_library_t), target :: lib type(process_stack_t), target :: stack1, stack2 type(model_t), target :: model type(string_t) :: libname type(string_t) :: procname1, procname2 type(os_data_t) :: os_data type(process_entry_t), pointer :: process => null () write (u, "(A)") "* Test output: process_stacks_4" write (u, "(A)") "* Purpose: link process stacks" write (u, "(A)") write (u, "(A)") "* Initialize process variables" write (u, "(A)") libname = "process_stacks_4_lib" procname1 = "process_stacks_4a" procname2 = "process_stacks_4b" call os_data%init () write (u, "(A)") "* Initialize first process" write (u, "(A)") call prc_test_create_library (procname1, lib) call model%init_test () allocate (process) call process%init (procname1, lib, os_data, model) call stack1%push (process) write (u, "(A)") "* Initialize second process" write (u, "(A)") call stack2%link (stack1) call prc_test_create_library (procname2, lib) allocate (process) call process%init (procname2, lib, os_data, model) call stack2%push (process) write (u, "(A)") "* Show linked stacks" write (u, "(A)") call stack2%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call stack2%final () call stack1%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_stacks_4" end subroutine process_stacks_4 @ %def process_stacks_4 @ Index: trunk/src/fks/fks.nw =================================================================== --- trunk/src/fks/fks.nw (revision 8234) +++ trunk/src/fks/fks.nw (revision 8235) @@ -1,9623 +1,9617 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: matrix elements and process libraries %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{FKS Subtraction Scheme} \includemodulegraph{fks} The code in this chapter implements the FKS subtraction scheme for use with \whizard. These are the modules: \begin{description} \item[fks\_regions] Given a process definition, identify singular regions in the associated phase space. \item[virtual] Handle the virtual correction matrix element. \item[real\_subtraction] Handle the real-subtraction matrix element. \item[nlo\_data] Manage the subtraction objects. \end{description} This chapter deals with next-to-leading order contributions to cross sections. Basically, there are three major issues to be adressed: The creation of the $N+1$-particle flavor structure, the construction of the $N+1$-particle phase space and the actual calculation of the real- and virtual-subtracted matrix elements. The first is dealt with using the [[auto_components]] class, and it will be shown that the second and third issue are connected in FKS subtraction. \section{Brief outline of FKS subtraction} {\em In the current state, this discussion is only concerned with lepton collisions. For hadron collisions, renormalization of parton distributions has to be taken into account. Further, for QCD corrections, initial-state radiation is necessarily present. However, most quantities have so far been only constructed for final-state emissions} The aim is to calculate the next-to-leading order cross section according to \begin{equation*} d\sigma_{\rm{NLO}} = \mathcal{B} + \mathcal{V} + \mathcal{R}d\Phi_{\rm{rad}}. \end{equation*} Analytically, the divergences, in terms of poles in the complex quantity $\varepsilon = 2-d/2$, cancel. However, this is in general only valid in an arbitrary, comlex number of dimensions. This is, roughly, the content of the KLN-theorem. \whizard, as any other numerical program, is confined to four dimensions. We will assume that the KLN-theorem is valid and that there exist subtraction terms $\mathcal{C}$ such that \begin{equation*} d\sigma_{\rm{NLO}} = \mathcal{B} + \underbrace{\mathcal{V} + \mathcal{C}}_{\text{finite}} + \underbrace{\mathcal{R} - \mathcal{C}}_{\text{finite}}, \end{equation*} i.e. the subtraction terms correspond to the divergent limits of the real and virtual matrix element. Because $\mathcal{C}$ subtracts the divergences of $\mathcal{R}$ as well as those of $\mathcal{V}$, it suffices to consider one of them, so we focus on $\mathcal{R}$. For this purpose, $\mathcal{R}$ is rewritten, \begin{equation*} \mathcal{R} = \frac{1}{\xi^2}\frac{1}{1-y} \left(\xi^2 (1-y)\mathcal{R}\right) = \frac{1}{\xi^2}\frac{1}{1-y}\tilde{\mathcal{R}}, \end{equation*} with $\xi = \left(2k_{\rm{rad}}^0\right)/\sqrt{s}$ and $y = \cos\theta$, where $k_{\rm{rad}}^0$ denotes the energy of the radiated parton and $\theta$ is the angle between emitter and radiated parton. $\tilde{\mathcal{R}}$ is finite, therefore the whole singularity structure is contained in the prefactor $\xi^{-2}(1-y)^{-1}$. Combined with the d-dimensional phase space element, \begin{equation*} \frac{d^{d-1}k}{2k^0(2\pi)^{d-1}} = \frac{s^{1-\varepsilon}}{(4\pi)^{d-1}}\xi^{1-2\varepsilon}\left(1-y^2\right)^{-\varepsilon} d\xi dy d\Omega^{d-2}, \end{equation*} this yields \begin{equation*} d\Phi_{\rm{rad}} \mathcal{R} = dy (1-y)^{-1-\varepsilon} d\xi \xi^{-1-2\varepsilon} \tilde{R}. \end{equation*} This can further be rewritten in terms of plus-distributions, \begin{align*} \xi^{-1-2\varepsilon} &= -\frac{1}{2\varepsilon}\delta(\xi) + \left(\frac{1}{\xi}\right)_+ - 2\varepsilon\left(\frac{\log\xi}{\xi}\right)_+ + \mathcal{O}(\varepsilon^2),\\ (1-y)^{-1-\varepsilon} &= -\frac{2^{-\varepsilon}}{\varepsilon} \delta(1-y) + \left(\frac{1}{1-y}\right)_+ - \varepsilon \left(\frac{1}{1-y}\right)_+\log(1-y) + \mathcal{O}(\varepsilon^2), \end{align*} (imagine that all this is written inside of integrals, which are spared for ease of notation) such that \begin{align*} d\Phi_{\rm{rad}} \mathcal{R} &= -\frac{1}{2\varepsilon} dy (1-y)^{-1-\varepsilon}\tilde{R} (0,y) - d\xi\left[\frac{2^{-\varepsilon}}{\varepsilon}\left(\frac{1}{\xi}\right)_+ - 2\left(\frac{\log\xi}{\xi}\right)_+\right] \tilde{R}(\xi,1) \\ &+ dy d\xi \left(\frac{1}{\xi}\right)_+ \left(\frac{1}{1-y}\right)_+ \tilde{R}(\xi, y) + \mathcal{O}(\varepsilon).\\ \end{align*} The summand in the second line is of order $\mathcal{O}(1)$ and is the only one to reproduce $\mathcal{R}(\xi,y)$. It thus constitutes the sum of the real matrix element and the corresponding counterterms. The first summand consequently consists of the subtraction terms to the virtual matrix elements. Above formula thus allows to calculate all quantities to render the matrix elements finite. \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Identifying singular regions} In the FKS subtraction scheme, the phase space is decomposed into disjoint singular regions, such that \begin{equation} \label{eq:S_complete} \sum_i \mathcal{S}_i + \sum_{ij}\mathcal{S}_{ij} = 1. \end{equation} The quantities $\mathcal{S}_i$ and $\mathcal{S}_{ij}$ are functions of phase space corresponding to a pair of particles indices which can make up a divergent phase space region. We call such an index pair a fundamental tuple. For example, the process $e^+ \, e^- \rightarrow u \, \bar{u} \, g$ has two singular regions, $(3,5)$ and $(4,5)$, indicating that the gluon can be soft or collinear with respect to either the quark or the anti-quark. Therefore, the functions $S_{ij}$ have to be chosen in such a way that their contribution makes up most of \eqref{eq:S_complete} in phase-space configurations where (final-state) particle $j$ is collinear to particle $i$ or/and particle $j$ is soft. The functions $S_i$ is the corresponding quantity for initial-state divergences. As a singular region we understand the collection of real flavor structures associated with an emitter and a list of all possible fundamental tuples. As an example, consider the process $e^+ \, e^- \rightarrow u \, \bar{u} \, g$. At next-to-leading order, processes with an additionally radiated particle have to be considered. In this case, these are $e^+ \, e^- \rightarrow u \, \bar{u}, \, g \, g$, and $e^+ \, e^- \rightarrow u \, \bar{u} \, u \, \bar{u}$ (or the same process with any other quark). Table \ref{table:singular regions} sums up all possible singular regions for this problem. \begin{table} \label{table:singular regions} \begin{tabular}{|c|c|c|c|} \hline \texttt{alr} & \texttt{flst\_alr} & \texttt{emi} & \texttt{ftuple\_list}\\ \hline 1 & [-11,11,2,-2,21,21] & 3 & {(3,5), (3,6), (4,5), (4,6), (5,6)} \\ \hline 2 & [-11,11,2,-2,21,21] & 4 & {(3,5), (3,6), (4,5), (4,6), (5,6)} \\ \hline 3 & [-11,11,2,-2,21,21] & 5 & {(3,5), (3,6), (4,5), (4,6), (5,6)} \\ \hline 4 & [-11,11,2,-2,2,-2] & 5 & {(5,6)} \\ \hline \end{tabular} \caption{List of singular regions. The particles are represented by their PDG codes. The third column contains the emitter for the specific singular region. For the process involving an additional gluon, the gluon can either be emitted from one of the quarks or from the first gluon. Each emitter yields the same list of fundamental tuples, five in total. The last singular region corresponds to the process where the gluon splits up into two quarks. Here, there is only one fundamental tuple, corresponding to a singular configuration of the momenta of the additional quarks.} \end{table} \\ \begin{table} \label{table:ftuples and flavors} \begin{tabular}{|c|c|c|c|} \hline \texttt{alr} & \texttt{ftuple} & \texttt{emitter} & \texttt{flst\_alr} \\ \hline 1 & $(3,5)$ & 5 & [-11,11,-2,21,2,21] \\ \hline 2 & $(4,5)$ & 5 & [-11,11,2,21,-2,21] \\ \hline 3 & $(3,6)$ & 5 & [-11,11,-2,21,2,21] \\ \hline 4 & $(4,6)$ & 5 & [-11,11,2,21,-2,21] \\ \hline 5 & $(5,6)$ & 5 & [-11,11,2,-2,21,21] \\ \hline 6 & $(5,6)$ & 5 & [-11,11,2,-2,2,-2] \\ \hline \end{tabular} \caption{Initial list of singular regions} \end{table} Thus, during the preparation of a NLO-calculation, the possible singular regions have to be identified. [[fks_regions.f90]] deals with this issue. \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{FKS Regions} <<[[fks_regions.f90]]>>= <> module fks_regions <> use format_utils, only: write_separator use numeric_utils, only: remove_duplicates_from_list, extend_integer_array use numeric_utils, only: remove_duplicates_from_list use string_utils, only: str use io_units use os_interface <> use constants use permutations use diagnostics use flavors use process_constants use lorentz use pdg_arrays use models use physics_defs use resonances, only: resonance_contributors_t, resonance_history_t use phs_fks, only: phs_identifier_t, check_for_phs_identifier use nlo_data <> <> <> <> <> contains <> end module fks_regions @ %def fks_regions @ There are three fundamental splitting types: $q \rightarrow qg$, $g \rightarrow gg$ and $g \rightarrow qq$. <>= integer, parameter :: UNDEFINED_SPLITTING = 0 integer, parameter :: F_TO_FV = 1 integer, parameter :: V_TO_VV = 2 integer, parameter :: V_TO_FF = 3 @ @ We group the indices of the emitting and the radiated particle in the [[ftuple]]-object. <>= public :: ftuple_t <>= type :: ftuple_t integer, dimension(2) :: ireg = [-1,-1] integer :: i_res = 0 integer :: splitting_type logical :: pseudo_isr = .false. contains <> end type ftuple_t @ %def ftuple_t @ <>= interface assignment(=) module procedure ftuple_assign end interface interface operator(==) module procedure ftuple_equal end interface <>= pure subroutine ftuple_assign (ftuple_out, ftuple_in) type(ftuple_t), intent(out) :: ftuple_out type(ftuple_t), intent(in) :: ftuple_in ftuple_out%ireg = ftuple_in%ireg ftuple_out%i_res = ftuple_in%i_res ftuple_out%splitting_type = ftuple_in%splitting_type ftuple_out%pseudo_isr = ftuple_in%pseudo_isr end subroutine ftuple_assign @ %def ftuple_assign @ <>= elemental function ftuple_equal (f1, f2) result (value) logical :: value type(ftuple_t), intent(in) :: f1, f2 value = all (f1%ireg == f2%ireg) .and. f1%i_res == f2%i_res & .and. f1%splitting_type == f2%splitting_type & .and. (f1%pseudo_isr .eqv. f2%pseudo_isr) end function ftuple_equal @ %def ftuple_equal @ <>= elemental function ftuple_compare (f1, f2) result (greater) logical :: greater type(ftuple_t), intent(in) :: f1, f2 if (f1%ireg(1) == f2%ireg(1)) then greater = f1%ireg(2) > f2%ireg(2) else greater = f1%ireg(1) > f2%ireg(2) end if end function ftuple_compare @ %def ftuple_compare @ <>= procedure :: write => ftuple_write <>= subroutine ftuple_write (ftuple, unit, newline) class(ftuple_t), intent(in) :: ftuple integer, intent(in), optional :: unit logical, intent(in), optional :: newline integer :: u logical :: nl u = given_output_unit (unit); if (u < 0) return nl = .true.; if (present(newline)) nl = newline if (all (ftuple%ireg > -1)) then if (ftuple%i_res > 0) then if (nl) then write (u, "(A1,I1,A1,I1,A1,I1,A1)") & '(', ftuple%ireg(1), ',', ftuple%ireg(2), ';', ftuple%i_res, ')' else write (u, "(A1,I1,A1,I1,A1,I1,A1)", advance = "no") & '(', ftuple%ireg(1), ',', ftuple%ireg(2), ';', ftuple%i_res, ')' end if else if (nl) then write (u, "(A1,I1,A1,I1,A1)") & '(', ftuple%ireg(1), ',', ftuple%ireg(2), ')' else write (u, "(A1,I1,A1,I1,A1)", advance = "no") & '(', ftuple%ireg(1), ',', ftuple%ireg(2), ')' end if end if else write (u, "(A)") "(Empty)" end if end subroutine ftuple_write @ %def ftuple_write @ <>= function ftuple_string (ftuples, latex) type(string_t) :: ftuple_string type(ftuple_t), intent(in), dimension(:) :: ftuples logical, intent(in) :: latex integer :: i, nreg if (latex) then ftuple_string = var_str ("$\left\{") else ftuple_string = var_str ("{") end if nreg = size(ftuples) do i = 1, nreg if (ftuples(i)%i_res == 0) then ftuple_string = ftuple_string // var_str ("(") // & str (ftuples(i)%ireg(1)) // var_str (",") // & str (ftuples(i)%ireg(2)) // var_str (")") else ftuple_string = ftuple_string // var_str ("(") // & str (ftuples(i)%ireg(1)) // var_str (",") // & str (ftuples(i)%ireg(2)) // var_str (";") // & str (ftuples(i)%i_res) // var_str (")") end if if (ftuples(i)%pseudo_isr) ftuple_string = ftuple_string // var_str ("*") if (i < nreg) ftuple_string = ftuple_string // var_str (",") end do if (latex) then ftuple_string = ftuple_string // var_str ("\right\}$") else ftuple_string = ftuple_string // var_str ("}") end if end function ftuple_string @ %def ftuple_string @ <>= procedure :: get => ftuple_get <>= subroutine ftuple_get (ftuple, pos1, pos2) class(ftuple_t), intent(in) :: ftuple integer, intent(out) :: pos1, pos2 pos1 = ftuple%ireg(1) pos2 = ftuple%ireg(2) end subroutine ftuple_get @ %def ftuple_get @ <>= procedure :: set => ftuple_set <>= subroutine ftuple_set (ftuple, pos1, pos2) class(ftuple_t), intent(inout) :: ftuple integer, intent(in) :: pos1, pos2 ftuple%ireg(1) = pos1 ftuple%ireg(2) = pos2 end subroutine ftuple_set @ %def ftuple_set @ <>= procedure :: determine_splitting_type_fsr => ftuple_determine_splitting_type_fsr <>= subroutine ftuple_determine_splitting_type_fsr (ftuple, flv, i, j) class(ftuple_t), intent(inout) :: ftuple type(flv_structure_t), intent(in) :: flv integer, intent(in) :: i, j associate (flst => flv%flst) if (is_vector (flst(i)) .and. is_vector (flst(j))) then ftuple%splitting_type = V_TO_VV else if (flst(i)+flst(j) == 0 & .and. is_fermion (abs(flst(i)))) then ftuple%splitting_type = V_TO_FF else if (is_fermion(abs(flst(i))) .and. is_massless_vector (flst(j)) & .or. is_fermion(abs(flst(j))) .and. is_massless_vector (flst(i))) then ftuple%splitting_type = F_TO_FV else ftuple%splitting_type = UNDEFINED_SPLITTING end if end associate end subroutine ftuple_determine_splitting_type_fsr @ %def ftuple_determine_splitting_type_fsr @ <>= procedure :: determine_splitting_type_isr => ftuple_determine_splitting_type_isr <>= subroutine ftuple_determine_splitting_type_isr (ftuple, flv, i, j) class(ftuple_t), intent(inout) :: ftuple type(flv_structure_t), intent(in) :: flv integer, intent(in) :: i, j integer :: em em = i; if (i == 0) em = 1 associate (flst => flv%flst) if (is_vector (flst(em)) .and. is_vector (flst(j))) then ftuple%splitting_type = V_TO_VV else if (is_massless_vector (flst(em)) .and. is_fermion(abs(flst(j)))) then ftuple%splitting_type = V_TO_FF else if (is_fermion(abs(flst(em))) .and. is_massless_vector (flst(j))) then ftuple%splitting_type = F_TO_FV else ftuple%splitting_type = UNDEFINED_SPLITTING end if end associate end subroutine ftuple_determine_splitting_type_isr @ %def ftuple_determine_splitting_type_isr @ Two debug functions to check the consistency of [[ftuples]] <>= procedure :: has_negative_elements => ftuple_has_negative_elements procedure :: has_identical_elements => ftuple_has_identical_elements <>= elemental function ftuple_has_negative_elements (ftuple) result (value) logical :: value class(ftuple_t), intent(in) :: ftuple value = any (ftuple%ireg < 0) end function ftuple_has_negative_elements elemental function ftuple_has_identical_elements (ftuple) result (value) logical :: value class(ftuple_t), intent(in) :: ftuple value = ftuple%ireg(1) == ftuple%ireg(2) end function ftuple_has_identical_elements @ %def ftuple_has_negative_elements, ftuple_has_identical_elements @ Each singular region can have a different number of emitter-radiation pairs. This is coped with using the linked list [[ftuple_list]]. <>= type :: ftuple_list_t integer :: index = 0 type(ftuple_t) :: ftuple type(ftuple_list_t), pointer :: next => null () type(ftuple_list_t), pointer :: prev => null () type(ftuple_list_t), pointer :: equiv => null () contains <> end type ftuple_list_t @ %def ftuple_list_t @ <>= procedure :: write => ftuple_list_write <>= subroutine ftuple_list_write (list, unit, verbose) class(ftuple_list_t), intent(in), target :: list integer, intent(in), optional :: unit logical, intent(in), optional :: verbose type(ftuple_list_t), pointer :: current logical :: verb integer :: u u = given_output_unit (unit); if (u < 0) return verb = .false.; if (present (verbose)) verb = verbose select type (list) type is (ftuple_list_t) current => list do call current%ftuple%write (unit = u, newline = .false.) if (verb .and. associated (current%equiv)) write (u, '(A)', advance = "no") "'" if (associated (current%next)) then current => current%next else exit end if end do write (u, *) "" end select end subroutine ftuple_list_write @ %def ftuple_list_write @ <>= procedure :: append => ftuple_list_append <>= subroutine ftuple_list_append (list, ftuple) class(ftuple_list_t), intent(inout), target :: list type(ftuple_t), intent(in) :: ftuple type(ftuple_list_t), pointer :: current select type (list) type is (ftuple_list_t) if (list%index == 0) then nullify (list%next) list%index = 1 list%ftuple = ftuple else current => list do if (associated (current%next)) then current => current%next else allocate (current%next) nullify (current%next%next) nullify (current%next%equiv) current%next%prev => current current%next%index = current%index + 1 current%next%ftuple = ftuple exit end if end do end if end select end subroutine ftuple_list_append @ %def ftuple_list_append @ <>= procedure :: compare => ftuple_list_compare <>= function ftuple_list_compare (ftuple_list, i1, i2) result (greater) logical :: greater class(ftuple_list_t), intent(in) :: ftuple_list integer, intent(in) :: i1, i2 greater = ftuple_compare (ftuple_list%get_ftuple (i1), ftuple_list%get_ftuple (i2)) end function ftuple_list_compare @ %def ftuple_list_compare @ <>= procedure :: get_n_tuples => ftuple_list_get_n_tuples <>= impure elemental function ftuple_list_get_n_tuples (list) result(n_tuples) integer :: n_tuples class(ftuple_list_t), intent(in), target :: list type(ftuple_list_t), pointer :: current n_tuples = 0 select type (list) type is (ftuple_list_t) current => list if (current%index > 0) then n_tuples = 1 do if (associated (current%next)) then current => current%next n_tuples = n_tuples + 1 else exit end if end do end if end select end function ftuple_list_get_n_tuples @ %def ftuple_list_get_n_tuples @ <>= procedure :: get_entry => ftuple_list_get_entry <>= function ftuple_list_get_entry (list, index) result (entry) type(ftuple_list_t), pointer :: entry class(ftuple_list_t), intent(in), target :: list integer, intent(in) :: index type(ftuple_list_t), pointer :: current integer :: i entry => null() select type (list) type is (ftuple_list_t) current => list if (index == 1) then entry => current else do i = 1, index - 1 current => current%next end do entry => current end if end select end function ftuple_list_get_entry @ %def ftuple_list_get_entry @ <>= procedure :: get_ftuple => ftuple_list_get_ftuple <>= function ftuple_list_get_ftuple (list, index) result (ftuple) type(ftuple_t) :: ftuple class(ftuple_list_t), intent(in), target :: list integer, intent(in) :: index type(ftuple_list_t), pointer :: entry entry => list%get_entry (index) ftuple = entry%ftuple end function ftuple_list_get_ftuple @ %def ftuple_list_get_ftuple @ <>= procedure :: set_equiv => ftuple_list_set_equiv <>= subroutine ftuple_list_set_equiv (list, i1, i2) class(ftuple_list_t), intent(in) :: list integer, intent(in) :: i1, i2 type(ftuple_list_t), pointer :: list1, list2 => null () select type (list) type is (ftuple_list_t) if (list%compare (i1, i2)) then list1 => list%get_entry (i2) list2 => list%get_entry (i1) else list1 => list%get_entry (i1) list2 => list%get_entry (i2) end if do if (associated (list1%equiv)) then list1 => list1%equiv else exit end if end do list1%equiv => list2 end select end subroutine ftuple_list_set_equiv @ %def ftuple_list_set_equiv @ <>= procedure :: check_equiv => ftuple_list_check_equiv <>= function ftuple_list_check_equiv(list, i1, i2) result(eq) class(ftuple_list_t), intent(in) :: list integer, intent(in) :: i1, i2 logical :: eq type(ftuple_list_t), pointer :: current eq = .false. select type (list) type is (ftuple_list_t) current => list%get_entry (i1) do if (associated (current%equiv)) then current => current%equiv if (current%index == i2) then eq = .true. exit end if else exit end if end do end select end function ftuple_list_check_equiv @ %def ftuple_list_sort @ <>= procedure :: to_array => ftuple_list_to_array <>= subroutine ftuple_list_to_array (ftuple_list, ftuple_array, equivalences, ordered) class(ftuple_list_t), intent(in), target :: ftuple_list type(ftuple_t), intent(out), dimension(:), allocatable :: ftuple_array logical, intent(out), dimension(:,:), allocatable :: equivalences logical, intent(in) :: ordered integer :: i_tuple, n type(ftuple_list_t), pointer :: current => null () integer :: i1, i2 type(ftuple_t) :: ftuple_tmp logical, dimension(:), allocatable :: eq_tmp n = ftuple_list%get_n_tuples () allocate (ftuple_array (n), equivalences (n, n)) equivalences = .false. select type (ftuple_list) type is (ftuple_list_t) current => ftuple_list i_tuple = 1 do ftuple_array(i_tuple) = current%ftuple if (associated (current%equiv)) then i1 = current%index i2 = current%equiv%index equivalences (i1, i2) = .true. end if if (associated (current%next)) then current => current%next i_tuple = i_tuple + 1 else exit end if end do end select if (ordered) then allocate (eq_tmp (n)) do i1 = 2, n i2 = i1 do while (i2 > 1 .and. ftuple_compare (ftuple_array(i2 - 1), ftuple_array(i2))) ftuple_tmp = ftuple_array(i2 - 1) eq_tmp = equivalences(i2, :) ftuple_array(i2 - 1) = ftuple_array(i2) ftuple_array(i2) = ftuple_tmp equivalences(i2 - 1, :) = equivalences(i2, :) equivalences(i2, :) = eq_tmp i2 = i2 - 1 end do end do deallocate (eq_tmp) end if end subroutine ftuple_list_to_array @ %def ftuple_list_to_array @ <>= subroutine print_equivalence_matrix (ftuple_array, equivalences) type(ftuple_t), intent(in), dimension(:) :: ftuple_array logical, intent(in), dimension(:,:) :: equivalences integer :: i, i1, i2 print *, 'Equivalence matrix: ' do i = 1, size (ftuple_array) call ftuple_array(i)%get(i1,i2) print *, 'i: ', i, '(', i1, i2, '): ', equivalences(i,:) end do end subroutine print_equivalence_matrix @ %def print_equivalence_matrix @ Class for working with the flavor specification arrays. <>= public :: flv_structure_t <>= type :: flv_structure_t integer, dimension(:), allocatable :: flst integer, dimension(:), allocatable :: tag integer :: nlegs = 0 integer :: n_in = 0 logical, dimension(:), allocatable :: massive logical, dimension(:), allocatable :: colored real(default), dimension(:), allocatable :: charge contains <> end type flv_structure_t @ %def flv_structure_t @ Returns \texttt{true} if the two particles at position \texttt{i} and \texttt{j} in the flavor array can originate from the same splitting. For this purpose, the function first checks whether the splitting is allowed at all. If this is the case, the emitter is removed from the flavor array. If the resulting array is equivalent to the Born flavor structure \texttt{flv\_born}, the pair is accepted as a valid splitting. We first check whether the splitting is possible. The array [[flv_orig]] contains all particles which share a vertex with the particles at position [[i]] and [[j]]. If its size is equal to zero, no splitting is possible and the subroutine is exited. Otherwise, we loop over all possible underlying Born flavor structures and check if any of them equals the actual underlying Born flavor structure. For a quark emitting a gluon, [[flv_orig]] contains the PDG code of the anti-quark. To be on the safe side, a second array is created, which contains both the positively and negatively signed PDG codes. Then, the origial tuple $(i,j)$ is removed from the real flavor structure and the particles in [[flv_orig2]] are inserted. If the resulting Born configuration is equal to the underlying Born configuration, up to a permutation of final-state particles, the tuple $(i,j)$ is accepted as valid. <>= procedure :: valid_pair => flv_structure_valid_pair <>= function flv_structure_valid_pair & (flv, i, j, flv_ref, model) result (valid) logical :: valid class(flv_structure_t), intent(in) :: flv integer, intent(in) :: i,j type(flv_structure_t), intent(in) :: flv_ref type(model_t), intent(in) :: model integer :: k, n_orig type(flv_structure_t) :: flv_test integer, dimension(:), allocatable :: flv_orig valid = .false. if (all ([i, j] <= flv%n_in)) return call model%match_vertex (flv%flst(i), flv%flst(j), flv_orig) n_orig = size (flv_orig) if (n_orig == 0) then return else do k = 1, n_orig if (any ([i, j] <= flv%n_in)) then flv_test = flv%insert_particle_isr (i, j, flv_orig(k)) else flv_test = flv%insert_particle_fsr (i, j, flv_orig(k)) end if valid = flv_ref .equiv. flv_test call flv_test%final () if (valid) return end do end if deallocate (flv_orig) end function flv_structure_valid_pair @ %def flv_structure_valid_pair @ This function checks whether two flavor arrays are the same up to a permutation of the final-state particles <>= function flv_structure_equivalent (flv1, flv2, with_tag) result(equiv) logical :: equiv type(flv_structure_t), intent(in) :: flv1, flv2 logical, intent(in) :: with_tag type(flavor_permutation_t) :: perm integer :: n n = size (flv1%flst) equiv = .true. if (n /= size (flv2%flst)) then call msg_fatal & ('flv_structure_equivalent: flavor arrays do not have equal lengths') else if (flv1%n_in /= flv2%n_in) then call msg_fatal & ('flv_structure_equivalent: flavor arrays do not have equal n_in') else call perm%init (flv1, flv2, flv1%n_in, flv1%nlegs, with_tag) equiv = perm%test (flv2, flv1, with_tag) call perm%final () end if end function flv_structure_equivalent @ %def flv_structure_equivalent @ <>= function flv_structure_equivalent_no_tag (flv1, flv2) result(equiv) logical :: equiv type(flv_structure_t), intent(in) :: flv1, flv2 equiv = flv_structure_equivalent (flv1, flv2, .false.) end function flv_structure_equivalent_no_tag function flv_structure_equivalent_with_tag (flv1, flv2) result(equiv) logical :: equiv type(flv_structure_t), intent(in) :: flv1, flv2 equiv = flv_structure_equivalent (flv1, flv2, .true.) end function flv_structure_equivalent_with_tag @ %def flv_structure_equivalent_no_tag, flv_structure_equivalent_with_tag @ <>= pure subroutine flv_structure_assign_flv (flv_out, flv_in) type(flv_structure_t), intent(out) :: flv_out type(flv_structure_t), intent(in) :: flv_in flv_out%nlegs = flv_in%nlegs flv_out%n_in = flv_in%n_in if (allocated (flv_in%flst)) then allocate (flv_out%flst (size (flv_in%flst))) flv_out%flst = flv_in%flst end if if (allocated (flv_in%tag)) then allocate (flv_out%tag (size (flv_in%tag))) flv_out%tag = flv_in%tag end if if (allocated (flv_in%massive)) then allocate (flv_out%massive (size (flv_in%massive))) flv_out%massive = flv_in%massive end if if (allocated (flv_in%colored)) then allocate (flv_out%colored (size (flv_in%colored))) flv_out%colored = flv_in%colored end if end subroutine flv_structure_assign_flv @ %def flv_structure_assign_flv @ <>= pure subroutine flv_structure_assign_integer (flv_out, iarray) type(flv_structure_t), intent(out) :: flv_out integer, intent(in), dimension(:) :: iarray integer :: i flv_out%nlegs = size (iarray) allocate (flv_out%flst (flv_out%nlegs)) allocate (flv_out%tag (flv_out%nlegs)) flv_out%flst = iarray flv_out%tag = [(i, i = 1, flv_out%nlegs)] end subroutine flv_structure_assign_integer @ %def flv_structure_assign_integer @ Returs a new flavor array with the particle at position \texttt{index} removed. <>= procedure :: remove_particle => flv_structure_remove_particle <>= function flv_structure_remove_particle (flv, index) result(flv_new) type(flv_structure_t) :: flv_new class(flv_structure_t), intent(in) :: flv integer, intent(in) :: index integer :: n1, n2 integer :: i, removed_tag n1 = size (flv%flst); n2 = n1 - 1 allocate (flv_new%flst (n2), flv_new%tag (n2)) flv_new%nlegs = n2 flv_new%n_in = flv%n_in removed_tag = flv%tag(index) if (index == 1) then flv_new%flst(1 : n2) = flv%flst(2 : n1) flv_new%tag(1 : n2) = flv%tag(2 : n1) else if (index == n1) then flv_new%flst(1 : n2) = flv%flst(1 : n2) flv_new%tag(1 : n2) = flv%tag(1 : n2) else flv_new%flst(1 : index - 1) = flv%flst(1 : index - 1) flv_new%flst(index : n2) = flv%flst(index + 1 : n1) flv_new%tag(1 : index - 1) = flv%tag(1 : index - 1) flv_new%tag(index : n2) = flv%tag(index + 1 : n1) end if do i = 1, n2 if (flv_new%tag(i) > removed_tag) & flv_new%tag(i) = flv_new%tag(i) - 1 end do end function flv_structure_remove_particle @ %def flv_structure_remove_particle @ <>= procedure :: insert_particle_fsr => flv_structure_insert_particle_fsr <>= function flv_structure_insert_particle_fsr (flv, i1, i2, flv_add) result (flv_new) type(flv_structure_t) :: flv_new class(flv_structure_t), intent(in) :: flv integer, intent(in) :: i1, i2, flv_add if (flv%flst(i1) + flv_add == 0 .or. flv%flst(i2) + flv_add == 0) then flv_new = flv%insert_particle (i1, i2, -flv_add) else flv_new = flv%insert_particle (i1, i2, flv_add) end if end function flv_structure_insert_particle_fsr @ %def flv_structure_insert_particle_fsr @ For ISR, the two particles are not exchangable. <>= procedure :: insert_particle_isr => flv_structure_insert_particle_isr <>= function flv_structure_insert_particle_isr (flv, i_in, i_out, flv_add) result (flv_new) type(flv_structure_t) :: flv_new class(flv_structure_t), intent(in) :: flv integer, intent(in) :: i_in, i_out, flv_add if (flv%flst(i_in) + flv_add == 0) then flv_new = flv%insert_particle (i_in, i_out, -flv_add) else flv_new = flv%insert_particle (i_in, i_out, flv_add) end if end function flv_structure_insert_particle_isr @ %def flv_structure_insert_particle_isr @ Removes the paritcles at position i1 and i2 and inserts a new particle at position i1. <>= procedure :: insert_particle => flv_structure_insert_particle <>= function flv_structure_insert_particle (flv, i1, i2, particle) result (flv_new) type(flv_structure_t) :: flv_new class(flv_structure_t), intent(in) :: flv integer, intent(in) :: i1, i2, particle type(flv_structure_t) :: flv_tmp integer :: n1, n2 integer :: new_tag n1 = size (flv%flst); n2 = n1 - 1 allocate (flv_new%flst (n2), flv_new%tag (n2)) flv_new%nlegs = n2 flv_new%n_in = flv%n_in new_tag = maxval(flv%tag) + 1 if (i1 < i2) then flv_tmp = flv%remove_particle (i1) flv_tmp = flv_tmp%remove_particle (i2 - 1) else if(i2 < i1) then flv_tmp = flv%remove_particle(i2) flv_tmp = flv_tmp%remove_particle(i1 - 1) else call msg_fatal ("flv_structure_insert_particle: Indices are identical!") end if if (i1 == 1) then flv_new%flst(1) = particle flv_new%flst(2 : n2) = flv_tmp%flst(1 : n2 - 1) flv_new%tag(1) = new_tag flv_new%tag(2 : n2) = flv_tmp%tag(1 : n2 - 1) else if (i1 == n1 .or. i1 == n2) then flv_new%flst(1 : n2 - 1) = flv_tmp%flst(1 : n2 - 1) flv_new%flst(n2) = particle flv_new%tag(1 : n2 - 1) = flv_tmp%tag(1 : n2 - 1) flv_new%tag(n2) = new_tag else flv_new%flst(1 : i1 - 1) = flv_tmp%flst(1 : i1 - 1) flv_new%flst(i1) = particle flv_new%flst(i1 + 1 : n2) = flv_tmp%flst(i1 : n2 - 1) flv_new%tag(1 : i1 - 1) = flv_tmp%tag(1 : i1 - 1) flv_new%tag(i1) = new_tag flv_new%tag(i1 + 1 : n2) = flv_tmp%tag(i1 : n2 - 1) end if end function flv_structure_insert_particle @ %def flv_structure_insert_particle @ Counts the number of occurances of a particle in a flavor array <>= procedure :: count_particle => flv_structure_count_particle <>= function flv_structure_count_particle (flv, part) result (n) class(flv_structure_t), intent(in) :: flv integer, intent(in) :: part integer :: n n = count (flv%flst == part) end function flv_structure_count_particle @ %def flv_structure_count_particle @ Initializer for flavor structures <>= procedure :: init => flv_structure_init <>= subroutine flv_structure_init (flv, aval, n_in, tags) class(flv_structure_t), intent(inout) :: flv integer, intent(in), dimension(:) :: aval integer, intent(in) :: n_in integer, intent(in), dimension(:), optional :: tags integer :: i, n n = size (aval) allocate (flv%flst (n), flv%tag (n)) flv%flst = aval if (present (tags)) then flv%tag = tags else do i = 1, n flv%tag(i) = i end do end if flv%nlegs = n flv%n_in = n_in end subroutine flv_structure_init @ %def flv_structure_init @ <>= procedure :: write => flv_structure_write <>= subroutine flv_structure_write (flv, unit) class(flv_structure_t), intent(in) :: flv integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, '(A)') char (flv%to_string ()) end subroutine flv_structure_write @ %def flv_structure_write @ <>= procedure :: to_string => flv_structure_to_string <>= function flv_structure_to_string (flv) result (flv_string) type(string_t) :: flv_string class(flv_structure_t), intent(in) :: flv integer :: i, n if (allocated (flv%flst)) then flv_string = var_str ("[") n = size (flv%flst) do i = 1, n - 1 flv_string = flv_string // str (flv%flst(i)) // var_str(",") end do flv_string = flv_string // str (flv%flst(n)) // var_str("]") else flv_string = var_str ("[not allocated]") end if end function flv_structure_to_string @ %def flv_structure_to_string @ Creates the underlying Born flavor structure for a given real flavor structure if the particle at position \texttt{emitter} is removed <>= procedure :: create_uborn => flv_structure_create_uborn <>= function flv_structure_create_uborn (flv, emitter, nlo_correction_type) result(flv_uborn) type(flv_structure_t) :: flv_uborn class(flv_structure_t), intent(in) :: flv type(string_t), intent(in) :: nlo_correction_type integer, intent(in) :: emitter integer n_legs integer :: f1, f2 integer :: gauge_boson n_legs = size(flv%flst) allocate (flv_uborn%flst (n_legs - 1), flv_uborn%tag (n_legs - 1)) gauge_boson = determine_gauge_boson_to_be_inserted () if (emitter > flv%n_in) then f1 = flv%flst(n_legs); f2 = flv%flst(n_legs - 1) if (is_massless_vector (f1)) then !!! Emitted particle is a gluon or photon => just remove it flv_uborn = flv%remove_particle(n_legs) else if (is_fermion (f1) .and. is_fermion (f2) .and. f1 + f2 == 0) then !!! Emission type is a gauge boson splitting into two fermions flv_uborn = flv%insert_particle(n_legs - 1, n_legs, gauge_boson) else call msg_error ("Create underlying Born: Unsupported splitting type.") call msg_error (char (str (flv%flst))) call msg_fatal ("FKS - FAIL") end if else if (emitter > 0) then f1 = flv%flst(n_legs); f2 = flv%flst(emitter) if (is_massless_vector (f1)) then flv_uborn = flv%remove_particle(n_legs) else if (is_fermion (f1) .and. is_massless_vector (f2)) then flv_uborn = flv%insert_particle (emitter, n_legs, -f1) else if (is_fermion (f1) .and. is_fermion (f2) .and. f1 == f2) then flv_uborn = flv%insert_particle(emitter, n_legs, gauge_boson) end if else flv_uborn = flv%remove_particle (n_legs) end if contains integer function determine_gauge_boson_to_be_inserted () select case (char (nlo_correction_type)) case ("QCD") determine_gauge_boson_to_be_inserted = GLUON case ("QED") determine_gauge_boson_to_be_inserted = PHOTON case ("Full") call msg_fatal ("NLO correction type 'Full' not yet implemented!") case default call msg_fatal ("Invalid NLO correction type! Valid inputs are: QCD, QED, Full (default: QCD)") end select end function determine_gauge_boson_to_be_inserted end function flv_structure_create_uborn @ %def flv_structure_create_uborn @ <>= procedure :: init_mass_color_and_charge => flv_structure_init_mass_color_and_charge <>= subroutine flv_structure_init_mass_color_and_charge (flv, model) class(flv_structure_t), intent(inout) :: flv type(model_t), intent(in) :: model integer :: i type(flavor_t) :: flavor allocate (flv%massive (flv%nlegs), flv%colored(flv%nlegs), flv%charge(flv%nlegs)) do i = 1, flv%nlegs call flavor%init (flv%flst(i), model) flv%massive(i) = flavor%get_mass () > 0 flv%colored(i) = & is_quark (flv%flst(i)) .or. is_gluon (flv%flst(i)) if (flavor%is_antiparticle ()) then flv%charge(i) = -flavor%get_charge () else flv%charge(i) = flavor%get_charge () end if end do end subroutine flv_structure_init_mass_color_and_charge @ %def flv_structure_init_mass_color_and_charge @ <>= procedure :: get_last_two => flv_structure_get_last_two <>= function flv_structure_get_last_two (flv, n) result (flst_last) integer, dimension(2) :: flst_last class(flv_structure_t), intent(in) :: flv integer, intent(in) :: n flst_last = [flv%flst(n - 1), flv%flst(n)] end function flv_structure_get_last_two @ %def flv_structure_get_last_two @ <>= procedure :: final => flv_structure_final <>= subroutine flv_structure_final (flv) class(flv_structure_t), intent(inout) :: flv if (allocated (flv%flst)) deallocate (flv%flst) if (allocated (flv%tag)) deallocate (flv%tag) if (allocated (flv%massive)) deallocate (flv%massive) if (allocated (flv%colored)) deallocate (flv%colored) if (allocated (flv%charge)) deallocate (flv%charge) end subroutine flv_structure_final @ %def flv_structure_final @ <>= public :: flavor_permutation_t <>= type :: flavor_permutation_t integer, dimension(:,:), allocatable :: perms contains <> end type flavor_permutation_t @ %def flavor_permutation_t @ <>= procedure :: init => flavor_permutation_init <>= subroutine flavor_permutation_init (perm, flv_in, flv_ref, n_first, n_last, with_tag) class(flavor_permutation_t), intent(out) :: perm type(flv_structure_t), intent(in) :: flv_in, flv_ref integer, intent(in) :: n_first, n_last logical, intent(in) :: with_tag integer :: flv1, flv2, tmp integer :: tag1, tag2 integer :: i, j, j_min, i_perm integer, dimension(:,:), allocatable :: perm_list_tmp type(flv_structure_t) :: flv_copy logical :: condition logical, dimension(:), allocatable :: already_correct flv_copy = flv_in allocate (perm_list_tmp (factorial (n_last - n_first - 1), 2)) allocate (already_correct (flv_in%nlegs)) already_correct = flv_in%flst == flv_ref%flst if (with_tag) & already_correct = already_correct .and. (flv_in%tag == flv_ref%tag) j_min = n_first + 1 i_perm = 0 do i = n_first + 1, n_last flv1 = flv_ref%flst(i) tag1 = flv_ref%tag(i) do j = j_min, n_last if (already_correct(i) .or. already_correct(j)) cycle flv2 = flv_copy%flst(j) tag2 = flv_copy%tag(j) condition = (flv1 == flv2) .and. i /= j if (with_tag) condition = condition .and. (tag1 == tag2) if (condition) then i_perm = i_perm + 1 tmp = flv_copy%flst(i) flv_copy%flst(i) = flv2 flv_copy%flst(j) = tmp tmp = flv_copy%tag(i) flv_copy%tag(i) = tag2 flv_copy%tag(j) = tmp perm_list_tmp (i_perm, 1) = i perm_list_tmp (i_perm, 2) = j exit end if end do j_min = j_min + 1 end do allocate (perm%perms (i_perm, 2)) perm%perms = perm_list_tmp (1 : i_perm, :) deallocate (perm_list_tmp) call flv_copy%final () end subroutine flavor_permutation_init @ %def flavor_permutation_init @ <>= procedure :: write => flavor_permutation_write <>= subroutine flavor_permutation_write (perm, unit) class(flavor_permutation_t), intent(in) :: perm integer, intent(in), optional :: unit integer :: i, n, u u = given_output_unit (unit); if (u < 0) return write (u, "(A)") "Flavor permutation list: " n = size (perm%perms, dim = 1) if (n > 0) then do i = 1, n write (u, "(A1,I1,1X,I1,A1)", advance = "no") "[", perm%perms(i,1), perm%perms(i,2), "]" if (i < n) write (u, "(A4)", advance = "no") " // " end do write (u, "(A)") "" else write (u, "(A)") "[Empty]" end if end subroutine flavor_permutation_write @ %def flavor_permutation_write @ <>= procedure :: reset => flavor_permutation_final procedure :: final => flavor_permutation_final <>= subroutine flavor_permutation_final (perm) class(flavor_permutation_t), intent(inout) :: perm if (allocated (perm%perms)) deallocate (perm%perms) end subroutine flavor_permutation_final @ %def flavor_permutation_final @ <>= generic :: apply => apply_permutation, & apply_flavor, apply_integer, apply_ftuple procedure :: apply_permutation => flavor_permutation_apply_permutation procedure :: apply_flavor => flavor_permutation_apply_flavor procedure :: apply_integer => flavor_permutation_apply_integer procedure :: apply_ftuple => flavor_permutation_apply_ftuple <>= elemental function flavor_permutation_apply_permutation (perm_1, perm_2) & result (perm_out) type(flavor_permutation_t) :: perm_out class(flavor_permutation_t), intent(in) :: perm_1 type(flavor_permutation_t), intent(in) :: perm_2 integer :: n1, n2 n1 = size (perm_1%perms, dim = 1) n2 = size (perm_2%perms, dim = 1) allocate (perm_out%perms (n1 + n2, 2)) perm_out%perms (1 : n1, :) = perm_1%perms perm_out%perms (n1 + 1: n1 + n2, :) = perm_2%perms end function flavor_permutation_apply_permutation @ %def flavor_permutation_apply_permutation @ <>= elemental function flavor_permutation_apply_flavor (perm, flv_in, invert) & result (flv_out) type(flv_structure_t) :: flv_out class(flavor_permutation_t), intent(in) :: perm type(flv_structure_t), intent(in) :: flv_in logical, intent(in), optional :: invert integer :: i, i1, i2 integer :: p1, p2, incr integer :: flv_tmp, tag_tmp logical :: inv inv = .false.; if (present(invert)) inv = invert flv_out = flv_in if (inv) then p1 = 1 p2 = size (perm%perms, dim = 1) incr = 1 else p1 = size (perm%perms, dim = 1) p2 = 1 incr = -1 end if do i = p1, p2, incr i1 = perm%perms(i,1) i2 = perm%perms(i,2) flv_tmp = flv_out%flst(i1) tag_tmp = flv_out%tag(i1) flv_out%flst(i1) = flv_out%flst(i2) flv_out%flst(i2) = flv_tmp flv_out%tag(i1) = flv_out%tag(i2) flv_out%tag(i2) = tag_tmp end do end function flavor_permutation_apply_flavor @ %def flavor_permutation_apply_flavor @ <>= elemental function flavor_permutation_apply_integer (perm, i_in) result (i_out) integer :: i_out class(flavor_permutation_t), intent(in) :: perm integer, intent(in) :: i_in integer :: i, i1, i2 i_out = i_in do i = size (perm%perms(:,1)), 1, -1 i1 = perm%perms(i,1) i2 = perm%perms(i,2) if (i_out == i1) then i_out = i2 else if (i_out == i2) then i_out = i1 end if end do end function flavor_permutation_apply_integer @ %def flavor_permutation_apply_integer @ <>= elemental function flavor_permutation_apply_ftuple (perm, f_in) result (f_out) type(ftuple_t) :: f_out class(flavor_permutation_t), intent(in) :: perm type(ftuple_t), intent(in) :: f_in integer :: i, i1, i2 f_out = f_in do i = size (perm%perms, dim = 1), 1, -1 i1 = perm%perms(i,1) i2 = perm%perms(i,2) if (f_out%ireg(1) == i1) then f_out%ireg(1) = i2 else if (f_out%ireg(1) == i2) then f_out%ireg(1) = i1 end if if (f_out%ireg(2) == i1) then f_out%ireg(2) = i2 else if (f_out%ireg(2) == i2) then f_out%ireg(2) = i1 end if end do if (f_out%ireg(1) > f_out%ireg(2)) f_out%ireg = f_out%ireg([2,1]) end function flavor_permutation_apply_ftuple @ %def flavor_permutation_apply_ftuple @ <>= procedure :: test => flavor_permutation_test <>= function flavor_permutation_test (perm, flv1, flv2, with_tag) result (valid) logical :: valid class(flavor_permutation_t), intent(in) :: perm type(flv_structure_t), intent(in) :: flv1, flv2 logical, intent(in) :: with_tag type(flv_structure_t) :: flv_test flv_test = perm%apply (flv2, invert = .true.) valid = all (flv_test%flst == flv1%flst) if (with_tag) valid = valid .and. all (flv_test%tag == flv1%tag) call flv_test%final () end function flavor_permutation_test @ %def flavor_permutation_test @ A singular region is a partition of phase space which is associated with an individual emitter and, if relevant, resonance. It is associated with an $\alpha_r$- and resonance-index, with a real flavor structure and its underlying Born flavor structure. To compute the FKS weights, it is relevant to know all the other particle indices which can result in a divergenent phase space configuration, which are collected in the [[ftuples]]-array. Some singular regions might behave physically identical. E.g. a real flavor structure associated with three-jet production is $[11,-11,0,2-2,0]$. Here, there are two possible [[ftuples]] which contribute to the same $u \rightarrow u g$ splitting, namely $(3,4)$ and $(4,6)$. The resulting singular regions will be identical. To avoid this, one singular region is associated with the multiplicity factor [[mult]]. When computing the subtraction terms for each singular region, the result is then simply multiplied by this factor.\\ The [[double_fsr]]-flag indicates whether the singular region should also be supplied by a symmetry factor, explained below. <>= public :: singular_region_t <>= type :: singular_region_t integer :: alr integer :: i_res type(flv_structure_t) :: flst_real type(flv_structure_t) :: flst_uborn integer :: mult integer :: emitter integer :: nregions integer :: real_index type(ftuple_t), dimension(:), allocatable :: ftuples integer :: uborn_index logical :: double_fsr = .false. logical :: soft_divergence = .false. logical :: coll_divergence = .false. type(string_t) :: nlo_correction_type integer, dimension(:), allocatable :: i_reg_to_i_con logical :: pseudo_isr = .false. logical :: sc_required = .false. contains <> end type singular_region_t @ %def singular_region_t @ <>= procedure :: init => singular_region_init <>= subroutine singular_region_init (sregion, alr, mult, i_res, & flst_real, flst_uborn, flv_born, emitter, ftuples, equivalences, & nlo_correction_type) class(singular_region_t), intent(out) :: sregion integer, intent(in) :: alr, mult, i_res type(flv_structure_t), intent(in) :: flst_real type(flv_structure_t), intent(in) :: flst_uborn type(flv_structure_t), dimension(:), intent(in) :: flv_born integer, intent(in) :: emitter type(ftuple_t), intent(inout), dimension(:) :: ftuples logical, intent(inout), dimension(:,:) :: equivalences type(string_t), intent(in) :: nlo_correction_type integer :: i call debug_input_values () sregion%alr = alr sregion%mult = mult sregion%i_res = i_res sregion%flst_real = flst_real sregion%flst_uborn = flst_uborn sregion%emitter = emitter sregion%nlo_correction_type = nlo_correction_type sregion%nregions = size (ftuples) allocate (sregion%ftuples (sregion%nregions)) sregion%ftuples = ftuples do i = 1, size(flv_born) if (flv_born (i) .equiv. sregion%flst_uborn) then sregion%uborn_index = i exit end if end do sregion%sc_required = any (sregion%flst_uborn%flst == GLUON) .or. & any (sregion%flst_uborn%flst == PHOTON) contains subroutine debug_input_values() call msg_debug2 (D_SUBTRACTION, "singular_region_init") if (debug2_active (D_SUBTRACTION)) then print *, 'alr = ', alr print *, 'mult = ', mult print *, 'i_res = ', i_res call flst_real%write () call flst_uborn%write () print *, 'emitter = ', emitter call print_equivalence_matrix (ftuples, equivalences) end if end subroutine debug_input_values end subroutine singular_region_init @ %def singular_region_init <>= procedure :: write => singular_region_write <>= subroutine singular_region_write (sregion, unit, maxnregions) class(singular_region_t), intent(in) :: sregion integer, intent(in), optional :: unit integer, intent(in), optional :: maxnregions character(len=7), parameter :: flst_format = "(I3,A1)" character(len=7), parameter :: ireg_space_format = "(7X,A1)" integer :: nreal, nborn, i, u, mr integer :: nleft, nright, nreg, nreg_diff u = given_output_unit (unit); if (u < 0) return mr = sregion%nregions; if (present (maxnregions)) mr = maxnregions nreal = size (sregion%flst_real%flst) nborn = size (sregion%flst_uborn%flst) call write_vline (u) write (u, '(A1)', advance = 'no') '[' do i = 1, nreal - 1 write (u, flst_format, advance = 'no') sregion%flst_real%flst(i), ',' end do write (u, flst_format, advance = 'no') sregion%flst_real%flst(nreal), ']' call write_vline (u) write (u, '(I6)', advance = 'no') sregion%real_index call write_vline (u) write (u, '(I3)', advance = 'no') sregion%emitter call write_vline (u) write (u, '(I3)', advance = 'no') sregion%mult call write_vline (u) write (u, '(I4)', advance = 'no') sregion%nregions call write_vline (u) if (sregion%i_res > 0) then write (u, '(I3)', advance = 'no') sregion%i_res call write_vline (u) end if nreg = sregion%nregions if (nreg == mr) then nleft = 0 nright = 0 else nreg_diff = mr - nreg nleft = nreg_diff / 2 if (mod(nreg_diff , 2) == 0) then nright = nleft else nright = nleft + 1 end if end if if (nleft > 0) then do i = 1, nleft write(u, ireg_space_format, advance='no') ' ' end do end if write (u, '(A)', advance = 'no') char (ftuple_string (sregion%ftuples, .false.)) call write_vline (u) write (u,'(A1)',advance = 'no') '[' do i = 1, nborn - 1 write(u, flst_format, advance = 'no') sregion%flst_uborn%flst(i), ',' end do write (u, flst_format, advance = 'no') sregion%flst_uborn%flst(nborn), ']' call write_vline (u) write (u, '(I7)', advance = 'no') sregion%uborn_index write (u, '(A)') end subroutine singular_region_write @ %def singular_region_write @ <>= procedure :: write_latex => singular_region_write_latex <>= subroutine singular_region_write_latex (region, unit) class(singular_region_t), intent(in) :: region integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(I2,A3,A,A3,I2,A3,I1,A3,I1,A3,A,A3,I2,A3,A,A3)") & region%alr, " & ", char (region%flst_real%to_string ()), & " & ", region%real_index, " & ", region%emitter, " & ", & region%mult, " & ", char (ftuple_string (region%ftuples, .true.)), & " & ", region%uborn_index, " & ", char (region%flst_uborn%to_string ()), & " \\" end subroutine singular_region_write_latex @ %def singular_region_write_latex @ In case of a $g \rightarrow gg$ or $g \rightarrow qq$ splitting, the factor \begin{equation*} \frac{2E_{\rm{em}}}{E_{\rm{em}} + E_{\rm{rad}}} \end{equation*} is multiplied to the real matrix element. This way, the symmetry of the splitting is used and only one singular region has to be taken into account. However, the factor ensures that there is only a soft singularity if the radiated parton becomes soft. <>= procedure :: set_splitting_info => singular_region_set_splitting_info <>= subroutine singular_region_set_splitting_info (region, n_in) class(singular_region_t), intent(inout) :: region integer, intent(in) :: n_in integer :: i1, i2 integer :: reg region%double_fsr = .false. associate (ftuple => region%ftuples) do reg = 1, region%nregions call ftuple(reg)%get (i1, i2) if (i1 /= region%emitter) then cycle else region%soft_divergence = & ftuple(reg)%splitting_type /= V_TO_FF if (i1 == 0) then region%coll_divergence = .not. any (region%flst_real%massive(1:n_in)) else region%coll_divergence = .not. region%flst_real%massive(i1) end if if (ftuple(reg)%splitting_type == V_TO_VV) then if (all (ftuple(reg)%ireg > n_in)) & region%double_fsr = all (is_gluon (region%flst_real%flst(ftuple(reg)%ireg))) exit else if (ftuple(reg)%splitting_type == UNDEFINED_SPLITTING) then call msg_fatal ("All splittings should be defined!") end if end if end do end associate end subroutine singular_region_set_splitting_info @ %def singular_region_set_splitting_info @ <>= procedure :: double_fsr_factor => singular_region_double_fsr_factor <>= function singular_region_double_fsr_factor (region, p) result (val) class(singular_region_t), intent(in) :: region type(vector4_t), intent(in), dimension(:) :: p real(default) :: val real(default) :: E_rad, E_em if (region%double_fsr) then E_em = energy (p(region%emitter)) E_rad = energy (p(region%flst_real%nlegs)) val = two * E_em / (E_em + E_rad) else val = one end if end function singular_region_double_fsr_factor @ %def singular_region_double_fsr_factor @ <>= procedure :: has_soft_divergence => singular_region_has_soft_divergence <>= function singular_region_has_soft_divergence (region) result (div) logical :: div class(singular_region_t), intent(in) :: region div = region%soft_divergence end function singular_region_has_soft_divergence @ %def singular_region_has_soft_divergence @ <>= procedure :: has_collinear_divergence => & singular_region_has_collinear_divergence <>= function singular_region_has_collinear_divergence (region) result (div) logical :: div class(singular_region_t), intent(in) :: region div = region%coll_divergence end function singular_region_has_collinear_divergence @ %def singular_region_has_collinear_divergence @ <>= procedure :: has_identical_ftuples => singular_region_has_identical_ftuples <>= elemental function singular_region_has_identical_ftuples (sregion) result (value) logical :: value class(singular_region_t), intent(in) :: sregion integer :: alr value = .false. do alr = 1, sregion%nregions value = value .or. (count (sregion%ftuples(alr) == sregion%ftuples) > 1) end do end function singular_region_has_identical_ftuples @ %def singular_region_has_identical_ftuples @ <>= interface assignment(=) module procedure singular_region_assign end interface <>= subroutine singular_region_assign (reg_out, reg_in) type(singular_region_t), intent(out) :: reg_out type(singular_region_t), intent(in) :: reg_in reg_out%alr = reg_in%alr reg_out%i_res = reg_in%i_res reg_out%flst_real = reg_in%flst_real reg_out%flst_uborn = reg_in%flst_uborn reg_out%mult = reg_in%mult reg_out%emitter = reg_in%emitter reg_out%nregions = reg_in%nregions reg_out%real_index = reg_in%real_index reg_out%uborn_index = reg_in%uborn_index reg_out%double_fsr = reg_in%double_fsr reg_out%soft_divergence = reg_in%soft_divergence reg_out%coll_divergence = reg_in%coll_divergence reg_out%nlo_correction_type = reg_in%nlo_correction_type if (allocated (reg_in%ftuples)) then allocate (reg_out%ftuples (size (reg_in%ftuples))) reg_out%ftuples = reg_in%ftuples else call msg_bug ("singular_region_assign: Trying to copy a singular region without allocated ftuples!") end if end subroutine singular_region_assign @ %def singular_region_assign @ <>= type :: resonance_mapping_t type(resonance_history_t), dimension(:), allocatable :: res_histories integer, dimension(:), allocatable :: alr_to_i_res integer, dimension(:,:), allocatable :: i_res_to_alr type(vector4_t), dimension(:), allocatable :: p_res contains <> end type resonance_mapping_t @ %def resonance_mapping_t @ Testing: Init resonance mapping for $\mu \mu b b$ final state. <>= procedure :: init => resonance_mapping_init <>= subroutine resonance_mapping_init (res_map, res_hist) class(resonance_mapping_t), intent(inout) :: res_map type(resonance_history_t), intent(in), dimension(:) :: res_hist integer :: n_hist, i_hist1, i_hist2, n_contributors n_contributors = 0 n_hist = size (res_hist) allocate (res_map%res_histories (n_hist)) do i_hist1 = 1, n_hist if (i_hist1 + 1 <= n_hist) then do i_hist2 = i_hist1 + 1, n_hist if (.not. (res_hist(i_hist1) .contains. res_hist(i_hist2))) & n_contributors = n_contributors + res_hist(i_hist2)%n_resonances end do else n_contributors = n_contributors + res_hist(i_hist1)%n_resonances end if end do allocate (res_map%p_res (n_contributors)) res_map%res_histories = res_hist res_map%p_res = vector4_null end subroutine resonance_mapping_init @ %def resonance_mapping_init @ <>= procedure :: set_alr_to_i_res => resonance_mapping_set_alr_to_i_res <>= subroutine resonance_mapping_set_alr_to_i_res (res_map, regions, alr_new_to_old) class(resonance_mapping_t), intent(inout) :: res_map type(singular_region_t), intent(in), dimension(:) :: regions integer, intent(out), dimension(:), allocatable :: alr_new_to_old integer :: alr, i_res integer :: alr_new, n_alr_res integer :: k call msg_debug (D_SUBTRACTION, "resonance_mapping_set_alr_to_i_res") n_alr_res = 0 do alr = 1, size (regions) do i_res = 1, size (res_map%res_histories) if (res_map%res_histories(i_res)%contains_leg (regions(alr)%emitter)) & n_alr_res = n_alr_res + 1 end do end do allocate (res_map%alr_to_i_res (n_alr_res)) allocate (res_map%i_res_to_alr (size (res_map%res_histories), 10)) res_map%i_res_to_alr = 0 allocate (alr_new_to_old (n_alr_res)) alr_new = 1 do alr = 1, size (regions) do i_res = 1, size (res_map%res_histories) if (res_map%res_histories(i_res)%contains_leg (regions(alr)%emitter)) then res_map%alr_to_i_res (alr_new) = i_res alr_new_to_old (alr_new) = alr alr_new = alr_new + 1 end if end do end do do i_res = 1, size (res_map%res_histories) k = 1 do alr = 1, size (regions) if (res_map%res_histories(i_res)%contains_leg (regions(alr)%emitter)) then res_map%i_res_to_alr (i_res, k) = alr k = k + 1 end if end do end do if (debug_active (D_SUBTRACTION)) then print *, 'i_res_to_alr:' do i_res = 1, size(res_map%i_res_to_alr, dim=1) print *, res_map%i_res_to_alr (i_res, :) end do print *, 'alr_new_to_old:', alr_new_to_old end if end subroutine resonance_mapping_set_alr_to_i_res @ %def resonance_mapping_set_alr_to_i_res @ <>= procedure :: get_resonance_history => resonance_mapping_get_resonance_history <>= function resonance_mapping_get_resonance_history (res_map, alr) result (res_hist) type(resonance_history_t) :: res_hist class(resonance_mapping_t), intent(in) :: res_map integer, intent(in) :: alr res_hist = res_map%res_histories(res_map%alr_to_i_res (alr)) end function resonance_mapping_get_resonance_history @ %def resonance_mapping_get_resonance_history @ <>= procedure :: write => resonance_mapping_write <>= subroutine resonance_mapping_write (res_map) class(resonance_mapping_t), intent(in) :: res_map integer :: i_res do i_res = 1, size (res_map%res_histories) call res_map%res_histories(i_res)%write () end do end subroutine resonance_mapping_write @ %def resonance_mapping_write @ <>= procedure :: get_resonance_value => resonance_mapping_get_resonance_value <>= function resonance_mapping_get_resonance_value (res_map, i_res, p, i_gluon) result (p_map) real(default) :: p_map class(resonance_mapping_t), intent(in) :: res_map integer, intent(in) :: i_res type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), optional :: i_gluon p_map = res_map%res_histories(i_res)%mapping (p, i_gluon) end function resonance_mapping_get_resonance_value @ %def resonance_mapping_get_resonance_value @ <>= procedure :: get_resonance_all => resonance_mapping_get_resonance_all <>= function resonance_mapping_get_resonance_all (res_map, alr, p, i_gluon) result (p_map) real(default) :: p_map class(resonance_mapping_t), intent(in) :: res_map integer, intent(in) :: alr type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), optional :: i_gluon integer :: i_res p_map = zero do i_res = 1, size (res_map%res_histories) associate (res => res_map%res_histories(i_res)) if (any (res_map%i_res_to_alr (i_res, :) == alr)) & p_map = p_map + res%mapping (p, i_gluon) end associate end do end function resonance_mapping_get_resonance_all @ %def resonance_mapping_get_resonance_all @ <>= procedure :: get_weight => resonance_mapping_get_weight <>= function resonance_mapping_get_weight (res_map, alr, p) result (pfr) real(default) :: pfr class(resonance_mapping_t), intent(in) :: res_map integer, intent(in) :: alr type(vector4_t), intent(in), dimension(:) :: p real(default) :: sumpfr integer :: i_res sumpfr = zero do i_res = 1, size (res_map%res_histories) sumpfr = sumpfr + res_map%get_resonance_value (i_res, p) end do pfr = res_map%get_resonance_value (res_map%alr_to_i_res (alr), p) / sumpfr end function resonance_mapping_get_weight @ %def resonance_mapping_get_weight @ <>= procedure :: get_resonance_alr => resonance_mapping_get_resonance_alr <>= function resonance_mapping_get_resonance_alr (res_map, alr, p, i_gluon) result (p_map) real(default) :: p_map class(resonance_mapping_t), intent(in) :: res_map integer, intent(in) :: alr type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), optional :: i_gluon integer :: i_res i_res = res_map%alr_to_i_res (alr) p_map = res_map%res_histories(i_res)%mapping (p, i_gluon) end function resonance_mapping_get_resonance_alr @ %def resonance_mapping_get_resonance_alr @ <>= interface assignment(=) module procedure resonance_mapping_assign end interface <>= subroutine resonance_mapping_assign (res_map_out, res_map_in) type(resonance_mapping_t), intent(out) :: res_map_out type(resonance_mapping_t), intent(in) :: res_map_in if (allocated (res_map_in%res_histories)) then allocate (res_map_out%res_histories (size (res_map_in%res_histories))) res_map_out%res_histories = res_map_in%res_histories end if if (allocated (res_map_in%alr_to_i_res)) then allocate (res_map_out%alr_to_i_res (size (res_map_in%alr_to_i_res))) res_map_out%alr_to_i_res = res_map_in%alr_to_i_res end if if (allocated (res_map_in%i_res_to_alr)) then allocate (res_map_out%i_res_to_alr & (size (res_map_in%i_res_to_alr, 1), size (res_map_in%i_res_to_alr, 2))) res_map_out%i_res_to_alr = res_map_in%i_res_to_alr end if if (allocated (res_map_in%p_res)) then allocate (res_map_out%p_res (size (res_map_in%p_res))) res_map_out%p_res = res_map_in%p_res end if end subroutine resonance_mapping_assign @ %def resonance_mapping_assign @ Every FKS mapping should store the $\sum_\alpha d_{ij}^{-1}$ and $\sum_\alpha d_{ij,\rm{soft}}^{-1}$. Also we keep the option open to use a normlization factor, which ensures $\sum_\alpha S_\alpha = 1$. <>= type, abstract :: fks_mapping_t real(default) :: sumdij real(default) :: sumdij_soft logical :: pseudo_isr = .false. real(default) :: normalization_factor = one contains <> end type fks_mapping_t @ %def fks_mapping_t @ <>= public :: fks_mapping_default_t <>= type, extends (fks_mapping_t) :: fks_mapping_default_t real(default) :: exp_1, exp_2 integer :: n_in contains <> end type fks_mapping_default_t @ %def fks_mapping_default_t @ <>= public :: fks_mapping_resonances_t <>= type, extends (fks_mapping_t) :: fks_mapping_resonances_t real(default) :: exp_1, exp_2 type(resonance_mapping_t) :: res_map integer :: i_con = 0 contains <> end type fks_mapping_resonances_t @ %def fks_mapping_resonances_t @ <>= public :: operator(.equiv.) public :: operator(.equivtag.) <>= interface operator(.equiv.) module procedure flv_structure_equivalent_no_tag end interface interface operator(.equivtag.) module procedure flv_structure_equivalent_with_tag end interface interface assignment(=) module procedure flv_structure_assign_flv module procedure flv_structure_assign_integer end interface @ %def operator_equiv @ <>= public :: region_data_t <>= type :: region_data_t type(singular_region_t), dimension(:), allocatable :: regions type(flv_structure_t), dimension(:), allocatable :: flv_born type(flv_structure_t), dimension(:), allocatable :: flv_real integer, dimension(:), allocatable :: emitters integer :: n_regions = 0 integer :: n_emitters = 0 integer :: n_flv_born = 0 integer :: n_flv_real = 0 integer :: n_in = 0 integer :: n_legs_born = 0 integer :: n_legs_real = 0 integer :: n_phs = 0 class(fks_mapping_t), allocatable :: fks_mapping integer, dimension(:), allocatable :: resonances type(resonance_contributors_t), dimension(:), allocatable :: alr_contributors integer, dimension(:), allocatable :: alr_to_i_contributor integer, dimension(:), allocatable :: i_phs_to_i_con contains <> end type region_data_t @ %def region_data_t @ <>= procedure :: allocate_fks_mappings => region_data_allocate_fks_mappings <>= subroutine region_data_allocate_fks_mappings (reg_data, mapping_type) class(region_data_t), intent(inout) :: reg_data integer, intent(in) :: mapping_type select case (mapping_type) case (FKS_DEFAULT) allocate (fks_mapping_default_t :: reg_data%fks_mapping) case (FKS_RESONANCES) allocate (fks_mapping_resonances_t :: reg_data%fks_mapping) case default call msg_fatal ("Init region_data: FKS mapping not implemented!") end select end subroutine region_data_allocate_fks_mappings @ %def region_data_allocate_fks_mappings @ <>= procedure :: init => region_data_init <>= subroutine region_data_init (reg_data, n_in, model, flavor_born, & flavor_real, nlo_correction_type) class(region_data_t), intent(inout) :: reg_data integer, intent(in) :: n_in type(model_t), intent(in) :: model integer, intent(in), dimension(:,:) :: flavor_born, flavor_real type(ftuple_list_t), dimension(:), allocatable :: ftuples integer, dimension(:), allocatable :: emitter type(flv_structure_t), dimension(:), allocatable :: flst_alr integer :: i integer :: n_flv_real_before_check type(string_t), intent(in) :: nlo_correction_type reg_data%n_in = n_in reg_data%n_flv_born = size (flavor_born, dim = 2) reg_data%n_legs_born = size (flavor_born, dim = 1) reg_data%n_legs_real = reg_data%n_legs_born + 1 n_flv_real_before_check = size (flavor_real, dim = 2) allocate (reg_data%flv_born (reg_data%n_flv_born)) allocate (reg_data%flv_real (n_flv_real_before_check)) do i = 1, reg_data%n_flv_born call reg_data%flv_born(i)%init (flavor_born (:, i), n_in) end do do i = 1, n_flv_real_before_check call reg_data%flv_real(i)%init (flavor_real (:, i), n_in) end do call reg_data%find_regions (model, ftuples, emitter, flst_alr) call reg_data%init_singular_regions (ftuples, emitter, flst_alr, nlo_correction_type) reg_data%n_flv_real = maxval (reg_data%regions%real_index) call reg_data%find_emitters () call reg_data%set_mass_color_and_charge (model) call reg_data%set_splitting_info () end subroutine region_data_init @ %def region_data_init @ <>= procedure :: init_resonance_information => region_data_init_resonance_information <>= subroutine region_data_init_resonance_information (reg_data) class(region_data_t), intent(inout) :: reg_data call reg_data%enlarge_singular_regions_with_resonances () call reg_data%find_resonances () end subroutine region_data_init_resonance_information @ %def region_data_init_resonance_information @ <>= procedure :: set_resonance_mappings => region_data_set_resonance_mappings <>= subroutine region_data_set_resonance_mappings (reg_data, resonance_histories) class(region_data_t), intent(inout) :: reg_data type(resonance_history_t), intent(in), dimension(:) :: resonance_histories select type (map => reg_data%fks_mapping) type is (fks_mapping_resonances_t) call map%res_map%init (resonance_histories) end select end subroutine region_data_set_resonance_mappings @ %def region_data_set_resonance_mappings @ <>= procedure :: setup_fks_mappings => region_data_setup_fks_mappings <>= subroutine region_data_setup_fks_mappings (reg_data, template, n_in) class(region_data_t), intent(inout) :: reg_data type(fks_template_t), intent(in) :: template integer, intent(in) :: n_in call reg_data%allocate_fks_mappings (template%mapping_type) select type (map => reg_data%fks_mapping) type is (fks_mapping_default_t) call map%set_parameter (n_in, template%fks_dij_exp1, template%fks_dij_exp2) end select end subroutine region_data_setup_fks_mappings @ %def region_data_setup_fks_mappings @ So far, we have only created singular regions for a non-resonant case. When resonance mappings are required, we have more singular regions, since they must now be identified by their emitter-resonance pair index, where the emitter must be compatible with the resonance. <>= procedure :: enlarge_singular_regions_with_resonances & => region_data_enlarge_singular_regions_with_resonances <>= subroutine region_data_enlarge_singular_regions_with_resonances (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr integer, dimension(:), allocatable :: alr_new_to_old integer :: n_alr_new type(singular_region_t), dimension(:), allocatable :: save_regions call msg_debug (D_SUBTRACTION, "region_data_enlarge_singular_regions_with_resonances") call debug_input_values () select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_default_t) return type is (fks_mapping_resonances_t) allocate (save_regions (reg_data%n_regions)) do alr = 1, reg_data%n_regions save_regions(alr) = reg_data%regions(alr) end do associate (res_map => fks_mapping%res_map) call res_map%set_alr_to_i_res (reg_data%regions, alr_new_to_old) deallocate (reg_data%regions) n_alr_new = size (alr_new_to_old) reg_data%n_regions = n_alr_new allocate (reg_data%regions (n_alr_new)) do alr = 1, n_alr_new reg_data%regions(alr) = save_regions(alr_new_to_old (alr)) reg_data%regions(alr)%i_res = res_map%alr_to_i_res (alr) end do end associate end select contains subroutine debug_input_values () if (debug2_active (D_SUBTRACTION)) then call reg_data%write () end if end subroutine debug_input_values end subroutine region_data_enlarge_singular_regions_with_resonances @ %def region_data_enlarge_singular_regions_with_resonances @ <>= procedure :: set_isr_pseudo_regions => region_data_set_isr_pseudo_regions <>= subroutine region_data_set_isr_pseudo_regions (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr integer :: n_alr_new !!! Subroutine called for threshold factorization -> !!! Size of singular regions at this point is fixed type(singular_region_t), dimension(2) :: save_regions integer, dimension(4) :: alr_new_to_old do alr = 1, reg_data%n_regions save_regions(alr) = reg_data%regions(alr) end do n_alr_new = reg_data%n_regions * 2 alr_new_to_old = [1, 1, 2, 2] deallocate (reg_data%regions) allocate (reg_data%regions (n_alr_new)) reg_data%n_regions = n_alr_new do alr = 1, n_alr_new reg_data%regions(alr) = save_regions(alr_new_to_old (alr)) call add_pseudo_emitters (reg_data%regions(alr)) if (mod (alr, 2) == 0) reg_data%regions(alr)%pseudo_isr = .true. end do contains subroutine add_pseudo_emitters (sregion) type(singular_region_t), intent(inout) :: sregion type(ftuple_t), dimension(2) :: ftuples_save integer :: alr do alr = 1, 2 ftuples_save(alr) = sregion%ftuples(alr) end do deallocate (sregion%ftuples) sregion%nregions = sregion%nregions * 2 allocate (sregion%ftuples (sregion%nregions)) do alr = 1, sregion%nregions sregion%ftuples(alr) = ftuples_save (alr_new_to_old(alr)) if (mod (alr, 2) == 0) sregion%ftuples(alr)%pseudo_isr = .true. end do end subroutine add_pseudo_emitters end subroutine region_data_set_isr_pseudo_regions @ %def region_data_set_isr_pseudo_regions @ This subroutine splits up the ftuple-list of the singular regions into interference-free lists, i.e. lists which only contain the same emitter. This is relevant for factorized NLO calculations. In the current implementation, it is hand-tailored for the threshold computation, but should be generalized further in the future. <>= procedure :: split_up_interference_regions_for_threshold => & region_data_split_up_interference_regions_for_threshold <>= subroutine region_data_split_up_interference_regions_for_threshold (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr, i_ftuple integer :: current_emitter integer :: i1, i2 integer :: n_new_reg type(ftuple_t), dimension(2) :: ftuples do alr = 1, reg_data%n_regions associate (region => reg_data%regions(alr)) current_emitter = region%emitter n_new_reg = 0 do i_ftuple = 1, region%nregions call region%ftuples(i_ftuple)%get (i1, i2) if (i1 == current_emitter) then n_new_reg = n_new_reg + 1 ftuples(n_new_reg) = region%ftuples(i_ftuple) end if end do deallocate (region%ftuples) allocate (region%ftuples(n_new_reg)) region%ftuples = ftuples (1 : n_new_reg) region%nregions = n_new_reg end associate end do reg_data%fks_mapping%normalization_factor = 0.5_default end subroutine region_data_split_up_interference_regions_for_threshold @ %def region_data_split_up_interference_regions_for_threshold @ <>= procedure :: set_mass_color_and_charge => region_data_set_mass_color_and_charge <>= subroutine region_data_set_mass_color_and_charge (reg_data, model) class(region_data_t), intent(inout) :: reg_data type(model_t), intent(in) :: model integer :: i do i = 1, reg_data%n_regions associate (region => reg_data%regions(i)) call region%flst_uborn%init_mass_color_and_charge (model) call region%flst_real%init_mass_color_and_charge (model) end associate end do do i = 1, reg_data%n_flv_born call reg_data%flv_born(i)%init_mass_color_and_charge (model) end do do i = 1, size (reg_data%flv_real) call reg_data%flv_real(i)%init_mass_color_and_charge (model) end do end subroutine region_data_set_mass_color_and_charge @ %def region_data_set_mass_color_and_charge @ <>= procedure :: uses_resonances => region_data_uses_resonances <>= function region_data_uses_resonances (reg_data) result (val) logical :: val class(region_data_t), intent(in) :: reg_data select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) val = .true. class default val = .false. end select end function region_data_uses_resonances @ %def region_data_uses_resonances @ Creates a list containing the emitter of each singular region. <>= procedure :: get_emitter_list => region_data_get_emitter_list <>= pure function region_data_get_emitter_list (reg_data) result(emitters) class(region_data_t), intent(in) :: reg_data integer, dimension(:), allocatable :: emitters integer :: i allocate (emitters (reg_data%n_regions)) do i = 1, reg_data%n_regions emitters(i) = reg_data%regions(i)%emitter end do end function region_data_get_emitter_list @ %def region_data_get_emitter_list @ <>= procedure :: get_associated_resonances => region_data_get_associated_resonances <>= function region_data_get_associated_resonances (reg_data, emitter) result (res) integer, dimension(:), allocatable :: res class(region_data_t), intent(in) :: reg_data integer, intent(in) :: emitter integer :: alr, i integer :: n_res select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) n_res = 0 do alr = 1, reg_data%n_regions if (reg_data%regions(alr)%emitter == emitter) & n_res = n_res + 1 end do if (n_res > 0) then allocate (res (n_res)) else return end if i = 1 do alr = 1, reg_data%n_regions if (reg_data%regions(alr)%emitter == emitter) then res (i) = fks_mapping%res_map%alr_to_i_res (alr) i = i + 1 end if end do end select end function region_data_get_associated_resonances @ %def region_data_get_associated_resonances @ <>= procedure :: emitter_is_compatible_with_resonance => & region_data_emitter_is_compatible_with_resonance <>= function region_data_emitter_is_compatible_with_resonance & (reg_data, i_res, emitter) result (compatible) logical :: compatible class(region_data_t), intent(in) :: reg_data integer, intent(in) :: i_res, emitter integer :: i_res_alr, alr compatible = .false. select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) do alr = 1, reg_data%n_regions i_res_alr = fks_mapping%res_map%alr_to_i_res (alr) if (i_res_alr == i_res .and. reg_data%get_emitter(alr) == emitter) then compatible = .true. exit end if end do end select end function region_data_emitter_is_compatible_with_resonance @ %def region_data_emitter_is_compatible_with_resonance @ <>= procedure :: emitter_is_in_resonance => region_data_emitter_is_in_resonance <>= function region_data_emitter_is_in_resonance (reg_data, i_res, emitter) result (exist) logical :: exist class(region_data_t), intent(in) :: reg_data integer, intent(in) :: i_res, emitter integer :: i exist = .false. select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) associate (res_history => fks_mapping%res_map%res_histories(i_res)) do i = 1, res_history%n_resonances exist = exist .or. any (res_history%resonances(i)%contributors%c == emitter) end do end associate end select end function region_data_emitter_is_in_resonance @ %def region_data_emitter_is_in_resonance @ <>= procedure :: get_contributors => region_data_get_contributors <>= subroutine region_data_get_contributors (reg_data, i_res, emitter, c, success) class(region_data_t), intent(in) :: reg_data integer, intent(in) :: i_res, emitter integer, intent(inout), dimension(:), allocatable :: c logical, intent(out) :: success integer :: i success = .false. select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) associate (res_history => fks_mapping%res_map%res_histories (i_res)) do i = 1, res_history%n_resonances if (any (res_history%resonances(i)%contributors%c == emitter)) then allocate (c (size (res_history%resonances(i)%contributors%c))) c = res_history%resonances(i)%contributors%c success = .true. exit end if end do end associate end select end subroutine region_data_get_contributors @ %def region_data_get_contributors @ <>= procedure :: get_emitter => region_data_get_emitter <>= pure function region_data_get_emitter (reg_data, alr) result (emitter) class(region_data_t), intent(in) :: reg_data integer, intent(in) :: alr integer :: emitter emitter = reg_data%regions(alr)%emitter end function region_data_get_emitter @ %def region_data_get_emitter @ <>= procedure :: map_real_to_born_index => region_data_map_real_to_born_index <>= function region_data_map_real_to_born_index (reg_data, real_index) result (uborn_index) integer :: uborn_index class(region_data_t), intent(in) :: reg_data integer, intent(in) :: real_index integer :: alr uborn_index = 0 do alr = 1, size (reg_data%regions) if (reg_data%regions(alr)%real_index == real_index) then uborn_index = reg_data%regions(alr)%uborn_index exit end if end do end function region_data_map_real_to_born_index @ %def region_data_map_real_to_born_index @ <>= generic :: get_flv_states_born => get_flv_states_born_single, get_flv_states_born_array procedure :: get_flv_states_born_single => region_data_get_flv_states_born_single procedure :: get_flv_states_born_array => region_data_get_flv_states_born_array <>= function region_data_get_flv_states_born_array (reg_data) result (flv_states) integer, dimension(:,:), allocatable :: flv_states class(region_data_t), intent(in) :: reg_data integer :: i_flv allocate (flv_states (reg_data%n_legs_born, reg_data%n_flv_born)) do i_flv = 1, reg_data%n_flv_born flv_states (:, i_flv) = reg_data%flv_born(i_flv)%flst end do end function region_data_get_flv_states_born_array function region_data_get_flv_states_born_single (reg_data, i_flv) result (flv_states) integer, dimension(:), allocatable :: flv_states class(region_data_t), intent(in) :: reg_data integer, intent(in) :: i_flv allocate (flv_states (reg_data%n_legs_born)) flv_states = reg_data%flv_born(i_flv)%flst end function region_data_get_flv_states_born_single @ %def region_data_get_flv_states_born @ <>= generic :: get_flv_states_real => get_flv_states_real_single, get_flv_states_real_array procedure :: get_flv_states_real_single => region_data_get_flv_states_real_single procedure :: get_flv_states_real_array => region_data_get_flv_states_real_array <>= function region_data_get_flv_states_real_single (reg_data, i_flv) result (flv_states) integer, dimension(:), allocatable :: flv_states class(region_data_t), intent(in) :: reg_data integer, intent(in) :: i_flv integer :: i_reg allocate (flv_states (reg_data%n_legs_real)) do i_reg = 1, reg_data%n_regions if (i_flv == reg_data%regions(i_reg)%real_index) then flv_states = reg_data%regions(i_reg)%flst_real%flst exit end if end do end function region_data_get_flv_states_real_single function region_data_get_flv_states_real_array (reg_data) result (flv_states) integer, dimension(:,:), allocatable :: flv_states class(region_data_t), intent(in) :: reg_data integer :: i_flv allocate (flv_states (reg_data%n_legs_real, reg_data%n_flv_real)) do i_flv = 1, reg_data%n_flv_real flv_states (:, i_flv) = reg_data%get_flv_states_real (i_flv) end do end function region_data_get_flv_states_real_array @ %def region_data_get_flv_states_real @ <>= procedure :: get_all_flv_states => region_data_get_all_flv_states <>= subroutine region_data_get_all_flv_states (reg_data, flv_born, flv_real) class(region_data_t), intent(in) :: reg_data integer, dimension(:,:), allocatable, intent(out) :: flv_born, flv_real allocate (flv_born (reg_data%n_legs_born, reg_data%n_flv_born)) flv_born = reg_data%get_flv_states_born () allocate (flv_real (reg_data%n_legs_real, reg_data%n_flv_real)) flv_real = reg_data%get_flv_states_real () end subroutine region_data_get_all_flv_states @ %def region_data_get_all_flv_states @ <>= procedure :: get_n_in => region_data_get_n_in <>= function region_data_get_n_in (reg_data) result (n_in) integer :: n_in class(region_data_t), intent(in) :: reg_data n_in = reg_data%n_in end function region_data_get_n_in @ %def region_data_get_n_in @ <>= procedure :: get_n_legs_real => region_data_get_n_legs_real <>= function region_data_get_n_legs_real (reg_data) result (n_legs) integer :: n_legs class(region_data_t), intent(in) :: reg_data n_legs = reg_data%n_legs_real end function region_data_get_n_legs_real @ %def region_data_get_n_legs_real <>= procedure :: get_n_legs_born => region_data_get_n_legs_born <>= function region_data_get_n_legs_born (reg_data) result (n_legs) integer :: n_legs class(region_data_t), intent(in) :: reg_data n_legs = reg_data%n_legs_born end function region_data_get_n_legs_born @ %def region_data_get_n_legs_born <>= procedure :: get_n_flv_real => region_data_get_n_flv_real <>= function region_data_get_n_flv_real (reg_data) result (n_flv) integer :: n_flv class(region_data_t), intent(in) :: reg_data n_flv = reg_data%n_flv_real end function region_data_get_n_flv_real @ %def region_data_get_n_flv_real <>= procedure :: get_n_flv_born => region_data_get_n_flv_born <>= function region_data_get_n_flv_born (reg_data) result (n_flv) integer :: n_flv class(region_data_t), intent(in) :: reg_data n_flv = reg_data%n_flv_born end function region_data_get_n_flv_born @ %def region_data_get_n_flv_born @ Returns $S_i = \frac{1}{\mathcal{D}d_i}$ or $S_{ij} = \frac{1}{\mathcal{D}d_{ij}}$ for one particular singular region. At this point, the flavor array should be rearranged in such a way that the emitted particle is at the last position of the flavor structure list. <>= generic :: get_svalue => get_svalue_last_pos, get_svalue_ij procedure :: get_svalue_last_pos => region_data_get_svalue_last_pos procedure :: get_svalue_ij => region_data_get_svalue_ij <>= function region_data_get_svalue_ij (reg_data, p, alr, i, j, i_res) result (sval) class(region_data_t), intent(inout) :: reg_data type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: alr, i, j integer, intent(in) :: i_res real(default) :: sval associate (map => reg_data%fks_mapping) call map%compute_sumdij (reg_data%regions(alr), p) select type (map) type is (fks_mapping_resonances_t) map%i_con = reg_data%alr_to_i_contributor (alr) end select map%pseudo_isr = reg_data%regions(alr)%pseudo_isr sval = map%svalue (p, i, j, i_res) * map%normalization_factor end associate end function region_data_get_svalue_ij function region_data_get_svalue_last_pos (reg_data, p, alr, emitter, i_res) result (sval) class(region_data_t), intent(inout) :: reg_data type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: alr, emitter integer, intent(in) :: i_res real(default) :: sval sval = reg_data%get_svalue (p, alr, emitter, reg_data%n_legs_real, i_res) end function region_data_get_svalue_last_pos @ %def region_data_get_svalue @ The same as above, but for the soft limit. <>= procedure :: get_svalue_soft => region_data_get_svalue_soft <>= function region_data_get_svalue_soft & (reg_data, p, p_soft, alr, emitter, i_res) result (sval) class(region_data_t), intent(inout) :: reg_data type(vector4_t), intent(in), dimension(:) :: p type(vector4_t), intent(in) :: p_soft integer, intent(in) :: alr, emitter, i_res real(default) :: sval associate (map => reg_data%fks_mapping) call map%compute_sumdij_soft (reg_data%regions(alr), p, p_soft) select type (map) type is (fks_mapping_resonances_t) map%i_con = reg_data%alr_to_i_contributor (alr) end select map%pseudo_isr = reg_data%regions(alr)%pseudo_isr sval = map%svalue_soft (p, p_soft, emitter, i_res) * map%normalization_factor end associate end function region_data_get_svalue_soft @ %def region_data_get_svalue_soft @ This subroutine starts with a specification of $N$- and $N+1$-particle configurations, [[flst_born]] and [[flst_real]], saved in [[reg_data]]. From these, it creates a list of fundamental tuples, a list of emitters and a list containing the $N+1$-particle configuration, rearranged in such a way that the emitter-radiation pair is last ([[flst_alr]]). For the $e^+ \, e^- \, \rightarrow u \, \bar{u} \, g$- example, the generated objects are shown in table \ref{table:ftuples and flavors}. Note that at this point, [[flst_alr]] is arranged in such a way that the emitter can only be equal to $n_{legs}-1$ for final-state radiation or 0, 1, or 2 for initial-state radiation. Further, it occurs that regions can be equivalent. For example in table \ref{table:ftuples and flavors} the regions corresponding to \texttt{alr} = 1 and \texttt{alr} = 3 as well as \texttt{alr} = 2 and \texttt{alr} = 4 describe the same physics and are therefore equivalent. @ <>= procedure :: find_regions => region_data_find_regions <>= subroutine region_data_find_regions & (reg_data, model, ftuples, emitters, flst_alr) class(region_data_t), intent(in) :: reg_data type(model_t), intent(in) :: model type(ftuple_list_t), intent(out), dimension(:), allocatable :: ftuples integer, intent(out), dimension(:), allocatable :: emitters type(flv_structure_t), intent(out), dimension(:), allocatable :: flst_alr type(ftuple_t) :: current_ftuple integer, dimension(:), allocatable :: emitter_tmp type(flv_structure_t), dimension(:), allocatable :: flst_alr_tmp type(ftuple_list_t), dimension(:,:), allocatable :: ftuples_tmp integer, dimension(:,:), allocatable :: ftuple_index integer :: n_born, n_real integer :: n_legreal integer, parameter :: n_regions_start = 20 integer, parameter :: increment_list = 50 integer :: i_born, i_real, i_reg, i_ftuple integer :: last_registered_i_born, last_registered_i_real n_born = size (reg_data%flv_born) n_real = size (reg_data%flv_real) n_legreal = size (reg_data%flv_real(1)%flst) allocate (ftuples_tmp (n_born,n_real)) allocate (ftuple_index (n_born,n_real)) allocate (emitter_tmp (n_regions_start)) allocate (flst_alr_tmp (n_regions_start)) i_reg = 0 ftuple_index = 0 i_ftuple = 0 last_registered_i_born = 0; last_registered_i_real = 0 do i_real = 1, n_real do i_born = 1, n_born call check_final_state_emissions (i_real, i_born, i_reg) call check_initial_state_emissions (i_real, i_born, i_reg) end do end do allocate (flst_alr (i_reg)) flst_alr = flst_alr_tmp(1 : i_reg) allocate (emitters (i_reg)) emitters = emitter_tmp(1 : i_reg) allocate (ftuples (count (ftuples_tmp%get_n_tuples () > 0))) do i_born = 1, n_born do i_real = 1, n_real if (ftuples_tmp(i_born,i_real)%get_n_tuples () > 0) & ftuples(ftuple_index(i_born,i_real)) = ftuples_tmp(i_born,i_real) end do end do deallocate (flst_alr_tmp) deallocate (emitter_tmp) deallocate (ftuples_tmp) deallocate (ftuple_index) contains subroutine extend_flv_array (flv) type(flv_structure_t), intent(inout), dimension(:), allocatable :: flv type(flv_structure_t), dimension(:), allocatable :: flv_store integer :: n n = size (flv) allocate (flv_store (n)) flv_store = flv deallocate (flv) allocate (flv (n + increment_list)) flv(1:n) = flv_store deallocate (flv_store) end subroutine extend_flv_array function incr_i_ftuple_if_required (i_born, i_real, i_ftuple_in) result (i_ftuple) integer :: i_ftuple integer, intent(in) :: i_born, i_real, i_ftuple_in if (last_registered_i_born /= i_born .or. last_registered_i_real /= i_real) then last_registered_i_born = i_born last_registered_i_real = i_real i_ftuple = i_ftuple_in + 1 else i_ftuple = i_ftuple_in end if end function incr_i_ftuple_if_required subroutine check_final_state_emissions (i_real, i_born, i_reg) integer, intent(in) :: i_real, i_born integer, intent(inout) :: i_reg integer :: leg1, leg2 type(flv_structure_t) :: born_flavor logical :: valid1, valid2 born_flavor = reg_data%flv_born(i_born) do leg1 = reg_data%n_in + 1, n_legreal do leg2 = leg1 + 1, n_legreal associate (flv_real => reg_data%flv_real(i_real)) valid1 = flv_real%valid_pair(leg1, leg2, born_flavor, model) valid2 = flv_real%valid_pair(leg2, leg1, born_flavor, model) if (valid1 .or. valid2) then i_reg = i_reg + 1 if (i_reg > size (flst_alr_tmp)) call extend_flv_array (flst_alr_tmp) if(valid1) then flst_alr_tmp(i_reg) = create_alr (flv_real, & reg_data%n_in, leg1, leg2) else flst_alr_tmp(i_reg) = create_alr (flv_real, & reg_data%n_in, leg2, leg1) end if call current_ftuple%set (leg1, leg2) call current_ftuple%determine_splitting_type_fsr & (flv_real, leg1, leg2) i_ftuple = incr_i_ftuple_if_required (i_born, i_real, i_ftuple) call ftuples_tmp(i_born,i_real)%append (current_ftuple) ftuple_index(i_born,i_real) = i_ftuple if (i_reg > size (emitter_tmp)) & call extend_integer_array (emitter_tmp, increment_list) emitter_tmp(i_reg) = n_legreal - 1 end if end associate end do end do end subroutine check_final_state_emissions subroutine check_initial_state_emissions (i_real, i_born, i_reg) integer, intent(in) :: i_real, i_born integer, intent(inout) :: i_reg integer :: leg, emitter type(flv_structure_t) :: born_flavor logical :: valid1, valid2 born_flavor = reg_data%flv_born (i_born) do leg = reg_data%n_in + 1, n_legreal associate (flv_real => reg_data%flv_real(i_real)) valid1 = flv_real%valid_pair(1, leg, born_flavor, model) if (reg_data%n_in > 1) then valid2 = flv_real%valid_pair(2, leg, born_flavor, model) else valid2 = .false. end if if (valid1 .and. valid2) then emitter = 0 else if (valid1 .and. .not. valid2) then emitter = 1 else if (.not. valid1 .and. valid2) then emitter = 2 else emitter = -1 end if if (valid1 .or. valid2) then i_reg = i_reg + 1 call current_ftuple%set(emitter, leg) call current_ftuple%determine_splitting_type_isr & (flv_real, emitter, leg) i_ftuple = incr_i_ftuple_if_required (i_born, i_real, i_ftuple) call ftuples_tmp(i_born,i_real)%append (current_ftuple) ftuple_index(i_born,i_real) = i_ftuple if (i_reg > size (emitter_tmp)) & call extend_integer_array (emitter_tmp, increment_list) emitter_tmp(i_reg) = emitter if (i_reg > size (flst_alr_tmp)) call extend_flv_array (flst_alr_tmp) flst_alr_tmp(i_reg) = & create_alr (flv_real, reg_data%n_in, emitter, leg) end if end associate end do end subroutine check_initial_state_emissions end subroutine region_data_find_regions @ %def region_data_find_regions @ Creates singular regions according to table \ref{table:singular regions}. It scans all regions in table \ref{table:ftuples and flavors} and records the real flavor structures. If they are equivalent, the flavor structure is not recorded, but the multiplicity of the present one is increased. <>= procedure :: init_singular_regions => region_data_init_singular_regions <>= subroutine region_data_init_singular_regions & (reg_data, ftuples, emitter, flv_alr, nlo_correction_type) class(region_data_t), intent(inout) :: reg_data type(ftuple_list_t), intent(inout), dimension(:), allocatable :: ftuples type(string_t), intent(in) :: nlo_correction_type integer :: n_independent_flv integer, intent(in), dimension(:) :: emitter type(flv_structure_t), intent(in), dimension(:) :: flv_alr type(flv_structure_t), dimension(:), allocatable :: flv_uborn, flv_alr_registered integer, dimension(:), allocatable :: mult integer, dimension(:), allocatable :: flst_emitter integer :: n_regions, maxregions integer, dimension(:), allocatable :: index integer :: i, i_flv, n_legs logical :: equiv, valid_fs_splitting integer :: i_first, i_reg, i_reg_prev integer, dimension(:), allocatable :: region_to_ftuple, alr_limits integer, dimension(:), allocatable :: equiv_index maxregions = size (emitter) n_legs = flv_alr(1)%nlegs allocate (flv_uborn (maxregions)) allocate (flv_alr_registered (maxregions)) allocate (mult (maxregions)) mult = 0 allocate (flst_emitter (maxregions)) allocate (index (maxregions)) allocate (region_to_ftuple (maxregions)) allocate (equiv_index (maxregions)) call setup_region_mappings (n_independent_flv, alr_limits, region_to_ftuple) i_first = 1 i_reg = 1 SCAN_FLAVORS: do i_flv = 1, n_independent_flv SCAN_FTUPLES: do i = i_first, i_first + alr_limits (i_flv) - 1 equiv = .false. if (i == i_first) then flv_alr_registered(i_reg) = flv_alr(i) mult(i_reg) = mult(i_reg) + 1 flv_uborn(i_reg) = flv_alr(i)%create_uborn (emitter(i), nlo_correction_type) flst_emitter(i_reg) = emitter(i) index (i_reg) = region_to_index(ftuples, i) equiv_index (i_reg) = region_to_ftuple(i) i_reg = i_reg + 1 else !!! Check for equivalent flavor structures do i_reg_prev = 1, i_reg - 1 if (emitter(i) == flst_emitter(i_reg_prev) .and. emitter(i) > reg_data%n_in) then valid_fs_splitting = check_fs_splitting (flv_alr(i)%get_last_two(n_legs), & flv_alr_registered(i_reg_prev)%get_last_two(n_legs), & flv_alr(i)%tag(n_legs - 1), flv_alr_registered(i_reg_prev)%tag(n_legs - 1)) if ((flv_alr(i) .equiv. flv_alr_registered(i_reg_prev)) & .and. valid_fs_splitting) then mult(i_reg_prev) = mult(i_reg_prev) + 1 equiv = .true. call ftuples (region_to_index(ftuples, i))%set_equiv & (equiv_index(i_reg_prev), region_to_ftuple(i)) exit end if else if (emitter(i) == flst_emitter(i_reg_prev) .and. emitter(i) <= reg_data%n_in) then if (flv_alr(i) .equiv. flv_alr_registered(i_reg_prev)) then mult(i_reg_prev) = mult(i_reg_prev) + 1 equiv = .true. call ftuples (region_to_index(ftuples, i))%set_equiv & (equiv_index(i_reg_prev), region_to_ftuple(i)) exit end if end if end do if (.not. equiv) then flv_alr_registered(i_reg) = flv_alr(i) mult(i_reg) = mult(i_reg) + 1 flv_uborn(i_reg) = flv_alr(i)%create_uborn (emitter(i), nlo_correction_type) flst_emitter(i_reg) = emitter(i) index (i_reg) = region_to_index (ftuples, i) equiv_index (i_reg) = region_to_ftuple(i) i_reg = i_reg + 1 end if end if end do SCAN_FTUPLES i_first = i_first + alr_limits(i_flv) end do SCAN_FLAVORS n_regions = i_reg - 1 allocate (reg_data%regions (n_regions)) reg_data%n_regions = n_regions call init_regions_with_permuted_flavors () call assign_real_indices () deallocate (flv_uborn) deallocate (flv_alr_registered) deallocate (mult) deallocate (flst_emitter) deallocate (index) deallocate (region_to_ftuple) deallocate (equiv_index) contains subroutine setup_region_mappings (n_independent_flv, & alr_limits, region_to_ftuple) integer, intent(inout) :: n_independent_flv integer, intent(inout), dimension(:), allocatable :: alr_limits integer, intent(inout), dimension(:), allocatable :: region_to_ftuple integer :: i, j, i_flv n_independent_flv = 0 do i = 1, size (ftuples) if (ftuples(i)%get_n_tuples() > 0) & n_independent_flv = n_independent_flv + 1 end do allocate (alr_limits (n_independent_flv)) j = 1 do i = 1, size (ftuples) if (ftuples(i)%get_n_tuples() > 0) then alr_limits(j) = ftuples(i)%get_n_tuples () j = j + 1 end if end do if (.not. (sum (alr_limits) == maxregions)) & call msg_fatal ("Too many regions!") j = 1 do i_flv = 1, n_independent_flv do i = 1, alr_limits(i_flv) region_to_ftuple(j) = i j = j + 1 end do end do end subroutine setup_region_mappings subroutine check_permutation (perm, flv_perm, flv_orig, i_reg) type(flavor_permutation_t), intent(in) :: perm type(flv_structure_t), intent(in) :: flv_perm, flv_orig integer, intent(in) :: i_reg type(flv_structure_t) :: flv_test flv_test = perm%apply (flv_orig, invert = .true.) if (.not. all (flv_test%flst == flv_perm%flst)) then print *, 'Fail at: ', i_reg print *, 'Original flavor structure: ', flv_orig%flst call perm%write () print *, 'Permuted flavor: ', flv_perm%flst print *, 'Should be: ', flv_test%flst call msg_fatal ("Permutation does not reproduce original flavor!") end if end subroutine check_permutation subroutine init_regions_with_permuted_flavors () type(flavor_permutation_t) :: perm_list type(ftuple_t), dimension(:), allocatable :: ftuple_array logical, dimension(:,:), allocatable :: equivalences integer :: i, j do j = 1, n_regions do i = 1, reg_data%n_flv_born if (reg_data%flv_born (i) .equiv. flv_uborn (j)) then call perm_list%reset () call perm_list%init (reg_data%flv_born(i), flv_uborn(j), & reg_data%n_in, reg_data%n_legs_born, .true.) flv_uborn(j) = perm_list%apply (flv_uborn(j)) flv_alr_registered(j) = perm_list%apply (flv_alr_registered(j)) flst_emitter(j) = perm_list%apply (flst_emitter(j)) end if end do call ftuples(index(j))%to_array (ftuple_array, equivalences, .true.) do i = 1, size (reg_data%flv_real) if (reg_data%flv_real(i) .equiv. flv_alr_registered(j)) then call perm_list%reset () call perm_list%init (flv_alr_registered(j), reg_data%flv_real(i), & reg_data%n_in, reg_data%n_legs_real, .false.) if (debug_active (D_SUBTRACTION)) call check_permutation & (perm_list, reg_data%flv_real(i), flv_alr_registered(j), j) ftuple_array = perm_list%apply (ftuple_array) end if end do call reg_data%regions(j)%init (j, mult(j), 0, flv_alr_registered(j), & flv_uborn(j), reg_data%flv_born, flst_emitter(j), ftuple_array, & equivalences, nlo_correction_type) if (allocated (ftuple_array)) deallocate (ftuple_array) if (allocated (equivalences)) deallocate (equivalences) end do end subroutine init_regions_with_permuted_flavors subroutine assign_real_indices () type(flv_structure_t) :: current_flv_real type(flv_structure_t), dimension(:), allocatable :: these_flv integer :: i_real, current_uborn_index integer :: i, j, this_i_real allocate (these_flv (size (flv_alr_registered))) i_real = 1 associate (regions => reg_data%regions) do i = 1, reg_data%n_regions do j = 1, size (these_flv) if (.not. allocated (these_flv(j)%flst)) then this_i_real = i_real call these_flv(i_real)%init (flv_alr_registered(i)%flst, reg_data%n_in) i_real = i_real + 1 exit else if (all (these_flv(j)%flst == flv_alr_registered(i)%flst)) then this_i_real = j exit end if end do regions(i)%real_index = this_i_real end do end associate deallocate (these_flv) end subroutine assign_real_indices subroutine write_perm_list (perm_list) integer, intent(in), dimension(:,:) :: perm_list integer :: i do i = 1, size (perm_list(:,1)) write (*,'(I1,1x,I1,A)', advance = "no" ) perm_list(i,1), perm_list(i,2), '/' end do print *, '' end subroutine write_perm_list function check_fs_splitting (flv1, flv2, tag1, tag2) result (valid) logical :: valid integer, intent(in), dimension(2) :: flv1, flv2 integer, intent(in) :: tag1, tag2 if (flv1(1) + flv1(2) == 0) then valid = abs(flv1(1)) == abs(flv2(1)) .and. abs(flv1(2)) == abs(flv2(2)) else valid = flv1(1) == flv2(1) .and. flv1(2) == flv2(2) .and. tag1 == tag2 end if end function check_fs_splitting end subroutine region_data_init_singular_regions @ %def region_data_init_singular_regions @ Create an array containing all emitters and resonances of [[region_data]]. <>= procedure :: find_emitters => region_data_find_emitters <>= subroutine region_data_find_emitters (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr, j, n_em, em integer, dimension(:), allocatable :: em_count allocate (em_count(reg_data%n_regions)) em_count = -1 n_em = 0 !!!Count the number of different emitters do alr = 1, reg_data%n_regions em = reg_data%regions(alr)%emitter if (.not. any (em_count == em)) then n_em = n_em + 1 em_count(alr) = em end if end do if (n_em < 1) call msg_fatal ("region_data_find_emitters: No emitters found!") reg_data%n_emitters = n_em allocate (reg_data%emitters (reg_data%n_emitters)) reg_data%emitters = -1 j = 1 do alr = 1, size (reg_data%regions) em = reg_data%regions(alr)%emitter if (.not. any (reg_data%emitters == em)) then reg_data%emitters(j) = em j = j + 1 end if end do end subroutine region_data_find_emitters @ %def region_data_find_emitters @ <>= procedure :: find_resonances => region_data_find_resonances <>= subroutine region_data_find_resonances (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr, j, k, n_res, n_contr integer :: res integer, dimension(10) :: res_count type(resonance_contributors_t), dimension(10) :: contributors_count type(resonance_contributors_t) :: contributors integer :: i_res, emitter logical :: share_emitter res_count = -1 n_res = 0; n_contr = 0 !!! Count the number of different resonances do alr = 1, reg_data%n_regions select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) res = fks_mapping%res_map%alr_to_i_res (alr) if (.not. any (res_count == res)) then n_res = n_res + 1 res_count(alr) = res end if end select end do if (n_res > 0) allocate (reg_data%resonances (n_res)) j = 1 select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) do alr = 1, size (reg_data%regions) res = fks_mapping%res_map%alr_to_i_res (alr) if (.not. any (reg_data%resonances == res)) then reg_data%resonances(j) = res j = j + 1 end if end do allocate (reg_data%alr_to_i_contributor (size (reg_data%regions))) do alr = 1, size (reg_data%regions) i_res = fks_mapping%res_map%alr_to_i_res (alr) emitter = reg_data%regions(alr)%emitter call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter) if (.not. share_emitter) cycle if (.not. any (contributors_count == contributors)) then n_contr = n_contr + 1 contributors_count(alr) = contributors end if if (allocated (contributors%c)) deallocate (contributors%c) end do allocate (reg_data%alr_contributors (n_contr)) j = 1 do alr = 1, size (reg_data%regions) i_res = fks_mapping%res_map%alr_to_i_res (alr) emitter = reg_data%regions(alr)%emitter call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter) if (.not. share_emitter) cycle if (.not. any (reg_data%alr_contributors == contributors)) then reg_data%alr_contributors(j) = contributors reg_data%alr_to_i_contributor (alr) = j j = j + 1 else do k = 1, size (reg_data%alr_contributors) if (reg_data%alr_contributors(k) == contributors) exit end do reg_data%alr_to_i_contributor (alr) = k end if if (allocated (contributors%c)) deallocate (contributors%c) end do end select call reg_data%extend_ftuples (n_res) call reg_data%set_contributors () end subroutine region_data_find_resonances @ %def region_data_find_resonances @ <>= procedure :: set_i_phs_to_i_con => region_data_set_i_phs_to_i_con <>= subroutine region_data_set_i_phs_to_i_con (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr integer :: i_res, emitter, i_con, i_phs, i_em type(phs_identifier_t), dimension(:), allocatable :: phs_id_tmp logical :: share_emitter, phs_exist type(resonance_contributors_t) :: contributors allocate (phs_id_tmp (reg_data%n_phs)) if (allocated (reg_data%resonances)) then allocate (reg_data%i_phs_to_i_con (reg_data%n_phs)) do i_em = 1, size (reg_data%emitters) emitter = reg_data%emitters(i_em) do i_res = 1, size (reg_data%resonances) if (reg_data%emitter_is_compatible_with_resonance (i_res, emitter)) then alr = find_alr (emitter, i_res) if (alr == 0) call msg_fatal ("Could not find requested alpha region!") i_con = reg_data%alr_to_i_contributor (alr) call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter) if (.not. share_emitter) cycle call check_for_phs_identifier & (phs_id_tmp, reg_data%n_in, emitter, contributors%c, phs_exist, i_phs) if (phs_id_tmp(i_phs)%emitter < 0) then phs_id_tmp(i_phs)%emitter = emitter allocate (phs_id_tmp(i_phs)%contributors (size (contributors%c))) phs_id_tmp(i_phs)%contributors = contributors%c end if reg_data%i_phs_to_i_con (i_phs) = i_con end if if (allocated (contributors%c)) deallocate (contributors%c) end do end do end if contains function find_alr (emitter, i_res) result (alr) integer :: alr integer, intent(in) :: emitter, i_res integer :: i do i = 1, reg_data%n_regions if (reg_data%regions(i)%emitter == emitter .and. & reg_data%regions(i)%i_res == i_res) then alr = i return end if end do alr = 0 end function find_alr end subroutine region_data_set_i_phs_to_i_con @ %def region_data_set_i_phs_to_i_con @ <>= procedure :: set_alr_to_i_phs => region_data_set_alr_to_i_phs <>= subroutine region_data_set_alr_to_i_phs (reg_data, phs_identifiers, alr_to_i_phs) class(region_data_t), intent(inout) :: reg_data type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers integer, intent(out), dimension(:) :: alr_to_i_phs integer :: alr, i_phs integer :: emitter, i_res type(resonance_contributors_t) :: contributors logical :: share_emitter, phs_exist do alr = 1, reg_data%n_regions associate (region => reg_data%regions(alr)) emitter = region%emitter i_res = region%i_res if (i_res /= 0) then call reg_data%get_contributors (i_res, emitter, & contributors%c, share_emitter) if (.not. share_emitter) cycle end if if (allocated (contributors%c)) then call check_for_phs_identifier (phs_identifiers, reg_data%n_in, & emitter, contributors%c, phs_exist = phs_exist, i_phs = i_phs) else call check_for_phs_identifier (phs_identifiers, reg_data%n_in, & emitter, phs_exist = phs_exist, i_phs = i_phs) end if if (.not. phs_exist) & call msg_fatal ("phs identifiers are not set up correctly!") alr_to_i_phs(alr) = i_phs end associate if (allocated (contributors%c)) deallocate (contributors%c) end do end subroutine region_data_set_alr_to_i_phs @ %def region_data_set_alr_to_i_phs @ <>= procedure :: set_contributors => region_data_set_contributors <>= subroutine region_data_set_contributors (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr, i_res, i_reg, i_con integer :: i1, i2, i_em integer, dimension(:), allocatable :: contributors logical :: share_emitter do alr = 1, size (reg_data%regions) associate (sregion => reg_data%regions(alr)) allocate (sregion%i_reg_to_i_con (sregion%nregions)) do i_reg = 1, sregion%nregions call sregion%ftuples(i_reg)%get (i1, i2) i_em = get_emitter_index (i1, i2, reg_data%n_legs_real) i_res = sregion%ftuples(i_reg)%i_res call reg_data%get_contributors (i_res, i_em, contributors, share_emitter) !!! Lookup contributor index do i_con = 1, size (reg_data%alr_contributors) if (all (reg_data%alr_contributors(i_con)%c == contributors)) then sregion%i_reg_to_i_con (i_reg) = i_con exit end if end do deallocate (contributors) end do end associate end do contains function get_emitter_index (i1, i2, n) result (i_em) integer :: i_em integer, intent(in) :: i1, i2, n if (i1 == n) then i_em = i2 else i_em = i1 end if end function get_emitter_index end subroutine region_data_set_contributors @ %def region_data_set_contributors @ This extension of the ftuples is still too naive as it assumes that the same resonances are possible for all ftuples <>= procedure :: extend_ftuples => region_data_extend_ftuples <>= subroutine region_data_extend_ftuples (reg_data, n_res) class(region_data_t), intent(inout) :: reg_data integer, intent(in) :: n_res integer :: alr, n_reg_save integer :: i_reg, i_res, i_em, k type(ftuple_t), dimension(:), allocatable :: ftuple_save integer :: n_new do alr = 1, size (reg_data%regions) associate (sregion => reg_data%regions(alr)) n_reg_save = sregion%nregions allocate (ftuple_save (n_reg_save)) ftuple_save = sregion%ftuples n_new = count_n_new_ftuples (sregion, n_res) deallocate (sregion%ftuples) sregion%nregions = n_new allocate (sregion%ftuples (n_new)) k = 1 do i_res = 1, n_res do i_reg = 1, n_reg_save associate (ftuple_new => sregion%ftuples(k)) i_em = ftuple_save(i_reg)%ireg(1) if (reg_data%emitter_is_in_resonance (i_res, i_em)) then call ftuple_new%set (i_em, ftuple_save(i_reg)%ireg(2)) ftuple_new%i_res = i_res ftuple_new%splitting_type = ftuple_save(i_reg)%splitting_type k = k + 1 end if end associate end do end do end associate deallocate (ftuple_save) end do contains function count_n_new_ftuples (sregion, n_res) result (n_new) integer :: n_new type(singular_region_t), intent(in) :: sregion integer, intent(in) :: n_res integer :: i_reg, i_res, i_em n_new = 0 do i_reg = 1, sregion%nregions do i_res = 1, n_res i_em = sregion%ftuples(i_reg)%ireg(1) if (reg_data%emitter_is_in_resonance (i_res, i_em)) & n_new = n_new + 1 end do end do end function count_n_new_ftuples end subroutine region_data_extend_ftuples @ %def region_data_extend_ftuples @ <>= procedure :: get_flavor_indices => region_data_get_flavor_indices <>= function region_data_get_flavor_indices (reg_data, born) result (i_flv) integer, dimension(:), allocatable :: i_flv class(region_data_t), intent(in) :: reg_data logical, intent(in) :: born allocate (i_flv (reg_data%n_regions)) if (born) then i_flv = reg_data%regions%uborn_index else i_flv = reg_data%regions%real_index end if end function region_data_get_flavor_indices @ %def region_data_get_flavor_indices @ <>= procedure :: get_matrix_element_index => region_data_get_matrix_element_index <>= function region_data_get_matrix_element_index (reg_data, i_reg) result (i_me) integer :: i_me class(region_data_t), intent(in) :: reg_data integer, intent(in) :: i_reg i_me = reg_data%regions(i_reg)%real_index end function region_data_get_matrix_element_index @ %def region_data_get_matrix_element_index @ <>= procedure :: compute_number_of_phase_spaces & => region_data_compute_number_of_phase_spaces <>= subroutine region_data_compute_number_of_phase_spaces (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: i_em, i_res, i_phs integer :: emitter type(resonance_contributors_t) :: contributors integer, parameter :: n_max_phs = 10 type(phs_identifier_t), dimension(n_max_phs) :: phs_id_tmp logical :: share_emitter, phs_exist if (allocated (reg_data%resonances)) then reg_data%n_phs = 0 do i_em = 1, size (reg_data%emitters) emitter = reg_data%emitters(i_em) do i_res = 1, size (reg_data%resonances) if (reg_data%emitter_is_compatible_with_resonance (i_res, emitter)) then call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter) if (.not. share_emitter) cycle call check_for_phs_identifier & (phs_id_tmp, reg_data%n_in, emitter, contributors%c, phs_exist, i_phs) if (.not. phs_exist) then reg_data%n_phs = reg_data%n_phs + 1 if (reg_data%n_phs > n_max_phs) call msg_fatal & ("Buffer of phase space identifieres: Too much phase spaces!") call phs_id_tmp(i_phs)%init (emitter, contributors%c) end if end if if (allocated (contributors%c)) deallocate (contributors%c) end do end do else reg_data%n_phs = size (remove_duplicates_from_list (reg_data%emitters)) end if end subroutine region_data_compute_number_of_phase_spaces @ %def region_data_compute_number_of_phase_spaces @ <>= procedure :: get_n_phs => region_data_get_n_phs <>= function region_data_get_n_phs (reg_data) result (n_phs) integer :: n_phs class(region_data_t), intent(in) :: reg_data n_phs = reg_data%n_phs end function region_data_get_n_phs @ %def region_data_get_n_phs @ <>= procedure :: set_splitting_info => region_data_set_splitting_info <>= subroutine region_data_set_splitting_info (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr do alr = 1, reg_data%n_regions call reg_data%regions(alr)%set_splitting_info (reg_data%n_in) end do end subroutine region_data_set_splitting_info @ %def region_data_set_splitting_info @ <>= procedure :: init_phs_identifiers => region_data_init_phs_identifiers <>= subroutine region_data_init_phs_identifiers (reg_data, phs_id) class(region_data_t), intent(in) :: reg_data type(phs_identifier_t), intent(out), dimension(:), allocatable :: phs_id integer :: i_em, i_res, i_phs integer :: emitter type(resonance_contributors_t) :: contributors logical :: share_emitter, phs_exist allocate (phs_id (reg_data%n_phs)) do i_em = 1, size (reg_data%emitters) emitter = reg_data%emitters(i_em) if (allocated (reg_data%resonances)) then do i_res = 1, size (reg_data%resonances) call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter) if (.not. share_emitter) cycle call check_for_phs_identifier & (phs_id, reg_data%n_in, emitter, contributors%c, phs_exist, i_phs) if (.not. phs_exist) & call phs_id(i_phs)%init (emitter, contributors%c) if (allocated (contributors%c)) deallocate (contributors%c) end do else call check_for_phs_identifier (phs_id, reg_data%n_in, emitter, & phs_exist = phs_exist, i_phs = i_phs) if (.not. phs_exist) call phs_id(i_phs)%init (emitter) end if end do end subroutine region_data_init_phs_identifiers @ %def region_data_init_phs_identifiers @ <>= procedure :: get_all_ftuples => region_data_get_all_ftuples <>= subroutine region_data_get_all_ftuples (reg_data, ftuples) class(region_data_t), intent(in) :: reg_data type(ftuple_t), intent(inout), dimension(:), allocatable :: ftuples type(ftuple_t), dimension(:), allocatable :: ftuple_tmp integer :: i, j, alr !!! Can have at most n * (n-1) ftuples j = 0 allocate (ftuple_tmp (reg_data%n_legs_real * (reg_data%n_legs_real - 1))) do i = 1, reg_data%n_regions associate (region => reg_data%regions(i)) do alr = 1, region%nregions if (.not. any (region%ftuples(alr) == ftuple_tmp)) then j = j + 1 ftuple_tmp(j) = region%ftuples(alr) end if end do end associate end do allocate (ftuples (j)) ftuples = ftuple_tmp(1:j) deallocate (ftuple_tmp) end subroutine region_data_get_all_ftuples @ %def region_data_get_all_ftuples @ <>= procedure :: write_to_file => region_data_write_to_file <>= subroutine region_data_write_to_file (reg_data, proc_id, latex, os_data) class(region_data_t), intent(inout) :: reg_data type(string_t), intent(in) :: proc_id logical, intent(in) :: latex type(os_data_t), intent(in) :: os_data type(string_t) :: filename integer :: u integer :: status if (latex) then filename = proc_id // "_fks_regions.tex" else filename = proc_id // "_fks_regions.out" end if u = free_unit () open (u, file=char(filename), action = "write", status="replace") if (latex) then call reg_data%write_latex (u) close (u) call os_data%build_latex_file & (proc_id // "_fks_regions", stat_out = status) if (status /= 0) & call msg_error (char ("Failed to compile " // filename)) else call reg_data%write (u) close (u) end if end subroutine region_data_write_to_file @ %def region_data_write_to_file @ <>= procedure :: write_latex => region_data_write_latex <>= subroutine region_data_write_latex (reg_data, unit) class(region_data_t), intent(in) :: reg_data integer, intent(in), optional :: unit integer :: i, u u = given_output_unit (); if (present (unit)) u = unit write (u, "(A)") "\documentclass{article}" write (u, "(A)") "\begin{document}" write (u, "(A)") "%FKS region data, automatically created by WHIZARD" write (u, "(A)") "\begin{table}" write (u, "(A)") "\begin{center}" write (u, "(A)") "\begin{tabular} {|c|c|c|c|c|c|c|c|}" write (u, "(A)") "\hline" write (u, "(A)") "$\alpha_r$ & $f_r$ & $i_r$ & $\varepsilon$ & $\varsigma$ & $\mathcal{P}_{\rm{FKS}}$ & $i_b$ & $f_b$ \\" write (u, "(A)") "\hline" do i = 1, reg_data%n_regions call reg_data%regions(i)%write_latex (u) end do write (u, "(A)") "\hline" write (u, "(A)") "\end{tabular}" write (u, "(A)") "\caption{List of singular regions}" write (u, "(A)") "\begin{description}" write (u, "(A)") "\item[$\alpha_r$] Index of the singular region" write (u, "(A)") "\item[$f_r$] Real flavor structure" write (u, "(A)") "\item[$i_r$] Index of the associated real flavor structure" write (u, "(A)") "\item[$\varepsilon$] Emitter" write (u, "(A)") "\item[$\varsigma$] Multiplicity" !!! The symbol used by 0908.4272 for multiplicities write (u, "(A)") "\item[$\mathcal{P}_{\rm{FKS}}$] The set of singular FKS-pairs" write (u, "(A)") "\item[$i_b$] Underlying Born index" write (u, "(A)") "\item[$f_b$] Underlying Born flavor structure" write (u, "(A)") "\end{description}" write (u, "(A)") "\end{center}" write (u, "(A)") "\end{table}" write (u, "(A)") "\end{document}" end subroutine region_data_write_latex @ %def region_data_write_latex @ Creates a table with information about all singular regions and writes it to a file. @ Returns the index of the real flavor structure an ftuple belongs to. <>= procedure :: write => region_data_write <>= subroutine region_data_write (reg_data, unit) class(region_data_t), intent(in) :: reg_data integer, intent(in), optional :: unit integer :: j integer :: maxnregions, i_reg_max type(string_t) :: flst_title, ftuple_title integer :: n_res, u u = given_output_unit (unit); if (u < 0) return maxnregions = 1; i_reg_max = 1 do j = 1, reg_data%n_regions if (size (reg_data%regions(j)%ftuples) > maxnregions) then maxnregions = reg_data%regions(j)%nregions i_reg_max = j end if end do flst_title = '(A' // flst_title_format(reg_data%n_legs_real) // ')' ftuple_title = '(A' // ftuple_title_format() // ')' write (u,'(A,1X,I3)') 'Total number of regions: ', size(reg_data%regions) write (u, '(A3)', advance = 'no') 'alr' call write_vline (u) write (u, char (flst_title), advance = 'no') 'flst_real' call write_vline (u) write (u, '(A6)', advance = 'no') 'i_real' call write_vline (u) write (u, '(A3)', advance = 'no') 'em' call write_vline (u) write (u, '(A3)', advance = 'no') 'mult' call write_vline (u) write (u, '(A4)', advance = 'no') 'nreg' call write_vline (u) if (allocated (reg_data%fks_mapping)) then select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) write (u, '(A3)', advance = 'no') 'res' call write_vline (u) end select end if write (u, char (ftuple_title), advance = 'no') 'ftuples' call write_vline (u) flst_title = '(A' // flst_title_format(reg_data%n_legs_born) // ')' write (u, char (flst_title), advance = 'no') 'flst_born' call write_vline (u) write (u, '(A7)') 'i_born' do j = 1, reg_data%n_regions write (u, '(I3)', advance = 'no') j call reg_data%regions(j)%write (u, maxnregions) end do call write_separator (u) if (allocated (reg_data%fks_mapping)) then select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) write (u, '(A)') write (u, '(A)') "The FKS regions are combined with resonance information: " n_res = size (fks_mapping%res_map%res_histories) write (u, '(A,1X,I1)') "Number of QCD resonance histories: ", n_res do j = 1, n_res write (u, '(A,1X,I1)') "i_res = ", j call fks_mapping%res_map%res_histories(j)%write (u) call write_separator (u) end do end select end if contains function flst_title_format (n) result (frmt) integer, intent(in) :: n type(string_t) :: frmt character(len=2) :: frmt_char write (frmt_char, '(I2)') 4 * n + 1 frmt = var_str (frmt_char) end function flst_title_format function ftuple_title_format () result (frmt) type(string_t) :: frmt integer :: n_ftuple_char !!! An ftuple (x,x) consists of five characters. In the string, they !!! are separated by maxregions - 1 commas. In total these are !!! 5 * maxnregions + maxnregions - 1 = 6 * maxnregions - 1 characters. !!! The {} brackets at add two additional characters. n_ftuple_char = 6 * maxnregions + 1 !!! If there are resonances, each ftuple with a resonance adds a ";x" !!! to the ftuple n_ftuple_char = n_ftuple_char + 2 * count (reg_data%regions(i_reg_max)%ftuples%i_res > 0) !!! Pseudo-ISR regions are denoted with a * at the end n_ftuple_char = n_ftuple_char + count (reg_data%regions(i_reg_max)%ftuples%pseudo_isr) frmt = str (n_ftuple_char) end function ftuple_title_format end subroutine region_data_write @ %def region_data_write @ <>= subroutine write_vline (u) integer, intent(in) :: u character(len=10), parameter :: sep_format = "(1X,A2,1X)" write (u, sep_format, advance = 'no') '||' end subroutine write_vline @ %def write_vline @ <>= public :: assignment(=) <>= interface assignment(=) module procedure region_data_assign end interface <>= subroutine region_data_assign (reg_data_out, reg_data_in) type(region_data_t), intent(out) :: reg_data_out type(region_data_t), intent(in) :: reg_data_in integer :: i if (allocated (reg_data_in%regions)) then allocate (reg_data_out%regions (size (reg_data_in%regions))) do i = 1, size (reg_data_in%regions) reg_data_out%regions(i) = reg_data_in%regions(i) end do else call msg_warning ("Copying region data without allocated singular regions!") end if if (allocated (reg_data_in%flv_born)) then allocate (reg_data_out%flv_born (size (reg_data_in%flv_born))) do i = 1, size (reg_data_in%flv_born) reg_data_out%flv_born(i) = reg_data_in%flv_born(i) end do else call msg_warning ("Copying region data without allocated born flavor structure!") end if if (allocated (reg_data_in%flv_real)) then allocate (reg_data_out%flv_real (size (reg_data_in%flv_real))) do i = 1, size (reg_data_in%flv_real) reg_data_out%flv_real(i) = reg_data_in%flv_real(i) end do else call msg_warning ("Copying region data without allocated real flavor structure!") end if if (allocated (reg_data_in%emitters)) then allocate (reg_data_out%emitters (size (reg_data_in%emitters))) do i = 1, size (reg_data_in%emitters) reg_data_out%emitters(i) = reg_data_in%emitters(i) end do else call msg_warning ("Copying region data without allocated emitters!") end if reg_data_out%n_regions = reg_data_in%n_regions reg_data_out%n_emitters = reg_data_in%n_emitters reg_data_out%n_flv_born = reg_data_in%n_flv_born reg_data_out%n_flv_real = reg_data_in%n_flv_real reg_data_out%n_in = reg_data_in%n_in reg_data_out%n_legs_born = reg_data_in%n_legs_born reg_data_out%n_legs_real = reg_data_in%n_legs_real if (allocated (reg_data_in%fks_mapping)) then select type (fks_mapping_in => reg_data_in%fks_mapping) type is (fks_mapping_default_t) allocate (fks_mapping_default_t :: reg_data_out%fks_mapping) select type (fks_mapping_out => reg_data_out%fks_mapping) type is (fks_mapping_default_t) fks_mapping_out = fks_mapping_in end select type is (fks_mapping_resonances_t) allocate (fks_mapping_resonances_t :: reg_data_out%fks_mapping) select type (fks_mapping_out => reg_data_out%fks_mapping) type is (fks_mapping_resonances_t) fks_mapping_out = fks_mapping_in end select end select else call msg_warning ("Copying region data without allocated FKS regions!") end if if (allocated (reg_data_in%resonances)) then allocate (reg_data_out%resonances (size (reg_data_in%resonances))) reg_data_out%resonances = reg_data_in%resonances end if reg_data_out%n_phs = reg_data_in%n_phs if (allocated (reg_data_in%alr_contributors)) then allocate (reg_data_out%alr_contributors (size (reg_data_in%alr_contributors))) reg_data_out%alr_contributors = reg_data_in%alr_contributors end if if (allocated (reg_data_in%alr_to_i_contributor)) then allocate (reg_data_out%alr_to_i_contributor & (size (reg_data_in%alr_to_i_contributor))) reg_data_out%alr_to_i_contributor = reg_data_in%alr_to_i_contributor end if end subroutine region_data_assign @ %def region_data_assign @ Returns the index of the real flavor structure an ftuple belogs to. <>= function region_to_index (list, i) result(index) type(ftuple_list_t), intent(inout), dimension(:), allocatable :: list integer, intent(in) :: i integer :: index, nlist, j integer, dimension(:), allocatable :: nreg nlist = size(list) allocate (nreg (nlist)) index = 0 do j = 1, nlist if (j == 1) then nreg(j) = list(j)%get_n_tuples () else nreg(j) = nreg(j - 1) + list(j)%get_n_tuples () end if end do do j = 1, nlist if (j == 1) then if (i <= nreg(j)) then index = j exit end if else if (i > nreg(j - 1) .and. i <= nreg(j)) then index = j exit end if end if end do end function region_to_index @ %def region_to_index @ Final state emission: Rearrange the flavor array in such a way that the emitted particle is last and the emitter is second last. [[i1]] is the index of the emitter, [[i2]] is the index of the emitted particle. Initial state emission: Just put the emitted particle to the last position. <>= function create_alr (flv1, n_in, i_em, i_rad) result(flv2) type(flv_structure_t), intent(in) :: flv1 integer, intent(in) :: n_in integer, intent(in) :: i_em, i_rad type(flv_structure_t) :: flv2 integer :: n n = size (flv1%flst) allocate (flv2%flst (n), flv2%tag (n)) flv2%nlegs = n flv2%n_in = n_in if (i_em > n_in) then flv2%flst(1 : n_in) = flv1%flst(1 : n_in) flv2%flst(n - 1) = flv1%flst(i_em) flv2%flst(n) = flv1%flst(i_rad) flv2%tag(1 : n_in) = flv1%tag(1 : n_in) flv2%tag(n - 1) = flv1%tag(i_em) flv2%tag(n) = flv1%tag(i_rad) call fill_remaining_flavors (n_in, .true.) else flv2%flst(1 : n_in) = flv1%flst(1 : n_in) flv2%flst(n) = flv1%flst(i_rad) flv2%tag(1 : n_in) = flv1%tag(1 : n_in) flv2%tag(n) = flv1%tag(i_rad) call fill_remaining_flavors (n_in, .false.) end if contains @ Order remaining particles according to their original position <>= subroutine fill_remaining_flavors (n_in, final_final) integer, intent(in) :: n_in logical, intent(in) :: final_final integer :: i, j logical :: check j = n_in + 1 do i = n_in + 1, n if (final_final) then check = (i /= i_em .and. i /= i_rad) else check = (i /= i_rad) end if if (check) then flv2%flst(j) = flv1%flst(i) flv2%tag(j) = flv1%tag(i) j = j + 1 end if end do end subroutine fill_remaining_flavors end function create_alr @ %def create_alr @ <>= procedure :: has_pseudo_isr => region_data_has_pseudo_isr <>= function region_data_has_pseudo_isr (reg_data) result (val) logical :: val class(region_data_t), intent(in) :: reg_data val = any (reg_data%regions%pseudo_isr) end function region_data_has_pseudo_isr @ %def region_data_has_pseudo_isr @ Performs consistency checks on [[region_data]]. Up to now only checks that no [[futple]] appears more than once. <>= procedure :: check_consistency => region_data_check_consistency <>= subroutine region_data_check_consistency (reg_data, fail_fatal, unit) class(region_data_t), intent(in) :: reg_data logical, intent(in) :: fail_fatal integer, intent(in), optional :: unit integer :: u integer :: i_reg, alr integer :: i1, f1, f2 logical :: undefined_ftuples, same_ftuple_indices, valid_splitting logical, dimension(4) :: no_fail u = given_output_unit(unit); if (u < 0) return no_fail = .true. call msg_message ("Check that no negative ftuple indices occur", unit = u) do i_reg = 1, reg_data%n_regions if (any (reg_data%regions(i_reg)%ftuples%has_negative_elements ())) then !!! This error is so severe that we stop immediately call msg_fatal ("Negative ftuple indices!") end if end do call msg_message ("Success!", unit = u) call msg_message ("Check that there is no ftuple with identical elements", unit = u) do i_reg = 1, reg_data%n_regions if (any (reg_data%regions(i_reg)%ftuples%has_identical_elements ())) then !!! This error is so severe that we stop immediately call msg_fatal ("Identical ftuple indices!") end if end do call msg_message ("Success!", unit = u) call msg_message ("Check that there are no duplicate ftuples in a region", unit = u) do i_reg = 1, reg_data%n_regions if (reg_data%regions(i_reg)%has_identical_ftuples ()) then if (no_fail(1)) then call msg_error ("FAIL: ", unit = u) no_fail(1) = .false. end if write (u, '(A,1x,I3)') 'i_reg:', i_reg end if end do if (no_fail(1)) call msg_message ("Success!", unit = u) call msg_message ("Check that ftuples add up to a valid splitting", unit = u) do i_reg = 1, reg_data%n_regions do alr = 1, reg_data%regions(i_reg)%nregions associate (region => reg_data%regions(i_reg)) i1 = region%ftuples(alr)%ireg(1) if (i1 == 0) i1 = 1 !!! Gluon emission from both initial-state quarks f1 = region%flst_real%flst(i1) f2 = region%flst_real%flst(region%ftuples(alr)%ireg(2)) valid_splitting = f1 + f2 == 0 & .or. (f1 == 21 .and. f2 == 21) & .or. (is_massive_vector (f1) .and. f2 == 22) & .or. is_fermion_vector_splitting (f1, f2) if (.not. valid_splitting) then if (no_fail(2)) then call msg_error ("FAIL: ", unit = u) no_fail(2) = .false. end if write (u, '(A,1x,I3)') 'i_reg:', i_reg exit end if end associate end do end do if (no_fail(2)) call msg_message ("Success!", unit = u) call msg_message ("Check that at least one ftuple contains the emitter", unit = u) do i_reg = 1, reg_data%n_regions associate (region => reg_data%regions(i_reg)) if (.not. any (region%emitter == region%ftuples%ireg(1))) then if (no_fail(3)) then call msg_error ("FAIL: ", unit = u) no_fail(3) = .false. end if write (u, '(A,1x,I3)') 'i_reg:', i_reg end if end associate end do if (no_fail(3)) call msg_message ("Success!", unit = u) call msg_message ("Check that each region has at least one ftuple & &with index n + 1", unit = u) do i_reg = 1, reg_data%n_regions if (.not. any (reg_data%regions(i_reg)%ftuples%ireg(2) == reg_data%n_legs_real)) then if (no_fail(4)) then call msg_error ("FAIL: ", unit = u) no_fail(4) = .false. end if write (u, '(A,1x,I3)') 'i_reg:', i_reg end if end do if (no_fail(4)) call msg_message ("Success!", unit = u) if (.not. all (no_fail)) & call abort_with_message ("Stop due to inconsistent region data!") contains subroutine abort_with_message (msg) character(len=*), intent(in) :: msg if (fail_fatal) then call msg_fatal (msg) else call msg_error (msg, unit = u) end if end subroutine abort_with_message function is_fermion_vector_splitting (pdg_1, pdg_2) result (value) logical :: value integer, intent(in) :: pdg_1, pdg_2 value = (is_fermion (pdg_1) .and. is_massless_vector (pdg_2)) .or. & (is_fermion (pdg_2) .and. is_massless_vector (pdg_1)) end function end subroutine region_data_check_consistency @ %def region_data_check_consistency @ <>= procedure :: requires_spin_correlations => region_data_requires_spin_correlations <>= function region_data_requires_spin_correlations (reg_data) result (val) class(region_data_t), intent(in) :: reg_data logical :: val integer :: alr val = .false. do alr = 1, reg_data%n_regions val = reg_data%regions(alr)%sc_required if (val) return end do end function region_data_requires_spin_correlations @ %def region_data_requires_spin_correlations @ <>= procedure :: final => region_data_final <>= subroutine region_data_final (reg_data) class(region_data_t), intent(inout) :: reg_data if (allocated (reg_data%regions)) deallocate (reg_data%regions) if (allocated (reg_data%flv_born)) deallocate (reg_data%flv_born) if (allocated (reg_data%flv_real)) deallocate (reg_data%flv_real) if (allocated (reg_data%emitters)) deallocate (reg_data%emitters) if (allocated (reg_data%fks_mapping)) deallocate (reg_data%fks_mapping) if (allocated (reg_data%resonances)) deallocate (reg_data%resonances) if (allocated (reg_data%alr_contributors)) deallocate (reg_data%alr_contributors) if (allocated (reg_data%alr_to_i_contributor)) deallocate (reg_data%alr_to_i_contributor) end subroutine region_data_final @ %def region_data_final @ <>= procedure (fks_mapping_dij), deferred :: dij <>= abstract interface function fks_mapping_dij (map, p, i, j, i_con) result (d) import real(default) :: d class(fks_mapping_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: i, j integer, intent(in), optional :: i_con end function fks_mapping_dij end interface @ %def fks_mapping_dij @ <>= procedure (fks_mapping_compute_sumdij), deferred :: compute_sumdij <>= abstract interface subroutine fks_mapping_compute_sumdij (map, sregion, p) import class(fks_mapping_t), intent(inout) :: map type(singular_region_t), intent(in) :: sregion type(vector4_t), intent(in), dimension(:) :: p end subroutine fks_mapping_compute_sumdij end interface @ %def fks_mapping_compute_sumdij @ <>= procedure (fks_mapping_svalue), deferred :: svalue <>= abstract interface function fks_mapping_svalue (map, p, i, j, i_res) result (value) import real(default) :: value class(fks_mapping_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: i, j integer, intent(in), optional :: i_res end function fks_mapping_svalue end interface @ %def fks_mapping_svalue <>= procedure (fks_mapping_dij_soft), deferred :: dij_soft <>= abstract interface function fks_mapping_dij_soft (map, p_born, p_soft, em, i_con) result (d) import real(default) :: d class(fks_mapping_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft integer, intent(in) :: em integer, intent(in), optional :: i_con end function fks_mapping_dij_soft end interface @ %def fks_mapping_dij_soft @ <>= procedure (fks_mapping_compute_sumdij_soft), deferred :: compute_sumdij_soft <>= abstract interface subroutine fks_mapping_compute_sumdij_soft (map, sregion, p_born, p_soft) import class(fks_mapping_t), intent(inout) :: map type(singular_region_t), intent(in) :: sregion type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft end subroutine fks_mapping_compute_sumdij_soft end interface @ %def fks_mapping_compute_sumdij_soft @ <>= procedure (fks_mapping_svalue_soft), deferred :: svalue_soft <>= abstract interface function fks_mapping_svalue_soft (map, p_born, p_soft, em, i_res) result (value) import real(default) :: value class(fks_mapping_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft integer, intent(in) :: em integer, intent(in), optional :: i_res end function fks_mapping_svalue_soft end interface @ %def fks_mapping_svalue_soft @ <>= procedure :: set_parameter => fks_mapping_default_set_parameter <>= subroutine fks_mapping_default_set_parameter (map, n_in, dij_exp1, dij_exp2) class(fks_mapping_default_t), intent(inout) :: map integer, intent(in) :: n_in real(default), intent(in) :: dij_exp1, dij_exp2 map%n_in = n_in map%exp_1 = dij_exp1 map%exp_2 = dij_exp2 end subroutine fks_mapping_default_set_parameter @ %def fks_mapping_default_set_parameter @ Computes the $d_{ij}$-quantities defined als follows: \begin{align*} d_{0i} &= \left[E_i^2\left(1-y_i\right)\right]^{p_1}\\, d_{1i} &= \left[2E_i^2\left(1-y_i\right)\right]^{p_1}\\, d_{2i} &= \left[2E_i^2\left(1+y_i\right)\right]^{p_1}\\, \end{align*} for initial state regions and \begin{align*} d_{ij} = \left[2(k_i \cdot k_j) \frac{E_i E_j}{(E_i+E_j)^2}\right]^{p_2} \end{align*} for final state regions. The exponents $p_1$ and $p_2$ can be used for tuning the efficiency of the mapping and are set to $1$ per default. <>= procedure :: dij => fks_mapping_default_dij <>= function fks_mapping_default_dij (map, p, i, j, i_con) result (d) real(default) :: d class(fks_mapping_default_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: i, j integer, intent(in), optional :: i_con d = zero if (map%pseudo_isr) then d = dij_threshold_gluon_from_top (i, j, p, map%exp_1) else if (i > map%n_in .and. j > map%n_in) then d = dij_fsr (p(i), p(j), map%exp_1) else d = dij_isr (map%n_in, i, j, p, map%exp_2) end if contains function dij_fsr (p1, p2, expo) result (d_ij) real(default) :: d_ij type(vector4_t), intent(in) :: p1, p2 real(default), intent(in) :: expo real(default) :: E1, E2 E1 = p1%p(0); E2 = p2%p(0) d_ij = (two * p1 * p2 * E1 * E2 / (E1 + E2)**2)**expo end function dij_fsr function dij_threshold_gluon_from_top (i, j, p, expo) result (d_ij) real(default) :: d_ij integer, intent(in) :: i, j type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: expo type(vector4_t) :: p_top if (i == THR_POS_B) then p_top = p(THR_POS_WP) + p(THR_POS_B) else p_top = p(THR_POS_WM) + p(THR_POS_BBAR) end if d_ij = dij_fsr (p_top, p(j), expo) end function dij_threshold_gluon_from_top function dij_isr (n_in, i, j, p, expo) result (d_ij) real(default) :: d_ij integer, intent(in) :: n_in, i, j type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: expo real(default) :: E, y select case (n_in) case (1) call get_emitter_variables (1, i, j, p, E, y) d_ij = (E**2 * (one - y**2))**expo case (2) if ((i == 0 .and. j > 2) .or. (j == 0 .and. i > 2)) then call get_emitter_variables (0, i, j, p, E, y) d_ij = (E**2 * (one - y**2))**expo else if ((i == 1 .and. j > 2) .or. (j == 1 .and. i > 2)) then call get_emitter_variables (1, i, j, p, E, y) d_ij = (two * E**2 * (one - y))**expo else if ((i == 2 .and. j > 2) .or. (j == 2 .and. i > 2)) then call get_emitter_variables (2, i, j, p, E, y) d_ij = (two * E**2 * (one + y))**expo end if end select end function dij_isr subroutine get_emitter_variables (i_check, i, j, p, E, y) integer, intent(in) :: i_check, i, j type(vector4_t), intent(in), dimension(:) :: p real(default), intent(out) :: E, y if (j == i_check) then E = energy (p(i)) y = polar_angle_ct (p(i)) else E = energy (p(j)) y = polar_angle_ct(p(j)) end if end subroutine get_emitter_variables end function fks_mapping_default_dij @ %def fks_mapping_default_dij @ Computes the quantity \begin{equation*} \mathcal{D} = \sum_k \frac{1}{d_{0k}} + \sum_{kl} \frac{1}{d_{kl}}. \end{equation*} <>= procedure :: compute_sumdij => fks_mapping_default_compute_sumdij <>= subroutine fks_mapping_default_compute_sumdij (map, sregion, p) class(fks_mapping_default_t), intent(inout) :: map type(singular_region_t), intent(in) :: sregion type(vector4_t), intent(in), dimension(:) :: p real(default) :: d integer :: alr, i, j associate (ftuples => sregion%ftuples) d = zero do alr = 1, sregion%nregions call ftuples(alr)%get (i, j) map%pseudo_isr = ftuples(alr)%pseudo_isr d = d + one / map%dij (p, i, j) end do end associate map%sumdij = d end subroutine fks_mapping_default_compute_sumdij @ %def fks_mapping_default_compute_sumdij @ Computes \begin{equation*} S_i = \frac{1}{\mathcal{D} d_{0i}} \end{equation*} or \begin{equation*} S_{ij} = \frac{1}{\mathcal{D} d_{ij}}, \end{equation*} respectively. <>= procedure :: svalue => fks_mapping_default_svalue <>= function fks_mapping_default_svalue (map, p, i, j, i_res) result (value) real(default) :: value class(fks_mapping_default_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: i, j integer, intent(in), optional :: i_res value = one / (map%dij (p, i, j) * map%sumdij) end function fks_mapping_default_svalue @ %def fks_mapping_default_svalue @ In the soft limit, our treatment of the divergences requires a modification of the mapping functions. Recall that there, the ratios of the $d$-functions must approach either $1$ or $0$. This means \begin{equation*} \frac{d_{lm}}{d_{0m}} = \frac{(2k_l \cdot k_m) \left[E_lE_m /(E_l + E_m)^2\right]}{E_m^2 (1-y^2)} = \overset {k_m = E_m \hat{k}} {=} \frac{E_l E_m^2}{(E_l + E_m)^2} \frac{2k_l \cdot \hat{k}}{E_m^2 (1-y^2)} \overset {E_m \rightarrow 0}{=} \frac{2}{k_l \cdot \hat{k}}{(1-y^2)E_l}, \end{equation*} where we have written the gluon momentum in terms of the soft momentum $\hat{k}$. In the same limit \begin{equation*} \frac{d_{lm}}{d_{nm}} = \frac{k_l \cdot \hat{k}}{k_n \cdot \hat{k}} \frac{E_n}{E_l}. \end{equation*} From these equations we can deduce the soft limit of $d$: \begin{align*} d_0^{\rm{soft}} &= 1 - y^2,\\ d_1^{\rm{soft}} &= 2(1-y),\\ d_2^{\rm{soft}} &= 2(1+y),\\ d_i^{\rm{soft}} &= \frac{2 k_i \cdot \hat{k}}{E_i}. \end{align*} <>= procedure :: dij_soft => fks_mapping_default_dij_soft <>= function fks_mapping_default_dij_soft (map, p_born, p_soft, em, i_con) result (d) real(default) :: d class(fks_mapping_default_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft integer, intent(in) :: em integer, intent(in), optional :: i_con if (map%pseudo_isr) then d = dij_soft_threshold_gluon_from_top (em, p_born, p_soft, map%exp_1) else if (em <= map%n_in) then d = dij_soft_isr (map%n_in, p_soft, map%exp_2) else d = dij_soft_fsr (p_born(em), p_soft, map%exp_1) end if contains function dij_soft_threshold_gluon_from_top (em, p, p_soft, expo) result (dij_soft) real(default) :: dij_soft integer, intent(in) :: em type(vector4_t), intent(in), dimension(:) :: p type(vector4_t), intent(in) :: p_soft real(default), intent(in) :: expo type(vector4_t) :: p_top if (em == THR_POS_B) then p_top = p(THR_POS_WP) + p(THR_POS_B) else p_top = p(THR_POS_WM) + p(THR_POS_BBAR) end if dij_soft = dij_soft_fsr (p_top, p_soft, expo) end function dij_soft_threshold_gluon_from_top function dij_soft_fsr (p_em, p_soft, expo) result (dij_soft) real(default) :: dij_soft type(vector4_t), intent(in) :: p_em, p_soft real(default), intent(in) :: expo dij_soft = (two * p_em * p_soft / p_em%p(0))**expo end function dij_soft_fsr function dij_soft_isr (n_in, p_soft, expo) result (dij_soft) real(default) :: dij_soft integer, intent(in) :: n_in type(vector4_t), intent(in) :: p_soft real(default), intent(in) :: expo real(default) :: y y = polar_angle_ct (p_soft) select case (n_in) case (1) dij_soft = one - y**2 case (2) select case (em) case (0) dij_soft = one - y**2 case (1) dij_soft = two * (one - y) case (2) dij_soft = two * (one + y) case default dij_soft = zero call msg_fatal ("fks_mappings_default_dij_soft: n_in > 2") end select case default dij_soft = zero call msg_fatal ("fks_mappings_default_dij_soft: n_in > 2") end select dij_soft = dij_soft**expo end function dij_soft_isr end function fks_mapping_default_dij_soft @ %def fks_mapping_default_dij_soft @ <>= procedure :: compute_sumdij_soft => fks_mapping_default_compute_sumdij_soft <>= subroutine fks_mapping_default_compute_sumdij_soft (map, sregion, p_born, p_soft) class(fks_mapping_default_t), intent(inout) :: map type(singular_region_t), intent(in) :: sregion type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft real(default) :: d integer :: alr, i, j integer :: nlegs d = zero nlegs = size (sregion%flst_real%flst) associate (ftuples => sregion%ftuples) do alr = 1, sregion%nregions call ftuples(alr)%get (i ,j) if (j == nlegs) then map%pseudo_isr = ftuples(alr)%pseudo_isr d = d + one / map%dij_soft (p_born, p_soft, i) end if end do end associate map%sumdij_soft = d end subroutine fks_mapping_default_compute_sumdij_soft @ %def fks_mapping_default_compute_sumdij_soft @ <>= procedure :: svalue_soft => fks_mapping_default_svalue_soft <>= function fks_mapping_default_svalue_soft (map, p_born, p_soft, em, i_res) result (value) real(default) :: value class(fks_mapping_default_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft integer, intent(in) :: em integer, intent(in), optional :: i_res value = one / (map%sumdij_soft * map%dij_soft (p_born, p_soft, em)) end function fks_mapping_default_svalue_soft @ %def fks_mapping_default_svalue_soft @ <>= interface assignment(=) module procedure fks_mapping_default_assign end interface <>= subroutine fks_mapping_default_assign (fks_map_out, fks_map_in) type(fks_mapping_default_t), intent(out) :: fks_map_out type(fks_mapping_default_t), intent(in) :: fks_map_in fks_map_out%exp_1 = fks_map_in%exp_1 fks_map_out%exp_2 = fks_map_in%exp_2 fks_map_out%n_in = fks_map_in%n_in end subroutine fks_mapping_default_assign @ %def fks_mapping_default_assign @ The $d_{ij,k}$-functions for the resonance mapping are basically the same as in the default case, but the kinematical values here must be evaluated in the resonance frame of reference. The energy of parton $i$ in a given resonance frame with momentum $p_{res}$ is \begin{equation*} E_i = \frac{p_i^0 \cdot p_{res}}{m_{res}}. \end{equation*} However, since the expressions only depend on ratios of four-momenta, we leave out the denominator because it will cancel out anyway. <>= procedure :: dij => fks_mapping_resonances_dij <>= function fks_mapping_resonances_dij (map, p, i, j, i_con) result (d) real(default) :: d class(fks_mapping_resonances_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: i, j integer, intent(in), optional :: i_con real(default) :: E1, E2 integer :: ii_con if (present (i_con)) then ii_con = i_con else call msg_fatal ("Resonance mappings require resonance index as input!") end if d = 0 if (i /= j) then if (i > 2 .and. j > 2) then associate (p_res => map%res_map%p_res (ii_con)) E1 = p(i) * p_res E2 = p(j) * p_res d = two * p(i) * p(j) * E1 * E2 / (E1 + E2)**2 end associate else call msg_fatal ("Resonance mappings are not implemented for ISR") end if end if end function fks_mapping_resonances_dij @ %def fks_mapping_resonances_dij @ Computes \begin{equation*} S_\alpha = \frac{P^{f_r(\alpha)}d^{-1}(\alpha)} {\sum_{f_r' \in T(F_r(\alpha))}P^{f_r'}\sum_{\alpha' \in Sr(f_r')}d^{-1}(\alpha)}. \end{equation*} <>= procedure :: compute_sumdij => fks_mapping_resonances_compute_sumdij <>= subroutine fks_mapping_resonances_compute_sumdij (map, sregion, p) class(fks_mapping_resonances_t), intent(inout) :: map type(singular_region_t), intent(in) :: sregion type(vector4_t), intent(in), dimension(:) :: p real(default) :: d, pfr integer :: i_res, i_reg, i, j, i_con integer :: nlegreal nlegreal = size (p) d = zero do i_reg = 1, sregion%nregions associate (ftuple => sregion%ftuples(i_reg)) call ftuple%get (i, j) i_res = ftuple%i_res end associate pfr = map%res_map%get_resonance_value (i_res, p, nlegreal) i_con = sregion%i_reg_to_i_con (i_reg) d = d + pfr / map%dij (p, i, j, i_con) end do map%sumdij = d end subroutine fks_mapping_resonances_compute_sumdij @ %def fks_mapping_resonances_compute_sumdij @ <>= procedure :: svalue => fks_mapping_resonances_svalue <>= function fks_mapping_resonances_svalue (map, p, i, j, i_res) result (value) real(default) :: value class(fks_mapping_resonances_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: i, j integer, intent(in), optional :: i_res real(default) :: pfr integer :: i_gluon i_gluon = size (p) pfr = map%res_map%get_resonance_value (i_res, p, i_gluon) value = pfr / (map%dij (p, i, j, map%i_con) * map%sumdij) end function fks_mapping_resonances_svalue @ %def fks_mapping_resonances_svalue @ <>= procedure :: get_resonance_weight => fks_mapping_resonances_get_resonance_weight <>= function fks_mapping_resonances_get_resonance_weight (map, alr, p) result (pfr) real(default) :: pfr class(fks_mapping_resonances_t), intent(in) :: map integer, intent(in) :: alr type(vector4_t), intent(in), dimension(:) :: p pfr = map%res_map%get_weight (alr, p) end function fks_mapping_resonances_get_resonance_weight @ %def fks_mapping_resonances_get_resonance_weight @ As above, the soft limit of $d_{ij,k}$ must be computed in the resonance frame of reference. <>= procedure :: dij_soft => fks_mapping_resonances_dij_soft <>= function fks_mapping_resonances_dij_soft (map, p_born, p_soft, em, i_con) result (d) real(default) :: d class(fks_mapping_resonances_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft integer, intent(in) :: em integer, intent(in), optional :: i_con real(default) :: E1, E2 integer :: ii_con type(vector4_t) :: pb if (present (i_con)) then ii_con = i_con else call msg_fatal ("fks_mapping_resonances requires resonance index") end if associate (p_res => map%res_map%p_res(ii_con)) pb = p_born(em) E1 = pb * p_res E2 = p_soft * p_res d = two * pb * p_soft * E1 * E2 / E1**2 end associate end function fks_mapping_resonances_dij_soft @ %def fks_mapping_resonances_dij_soft @ <>= procedure :: compute_sumdij_soft => fks_mapping_resonances_compute_sumdij_soft <>= subroutine fks_mapping_resonances_compute_sumdij_soft (map, sregion, p_born, p_soft) class(fks_mapping_resonances_t), intent(inout) :: map type(singular_region_t), intent(in) :: sregion type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft real(default) :: d real(default) :: pfr integer :: i_res, i, j, i_reg, i_con integer :: nlegs d = zero nlegs = size (sregion%flst_real%flst) do i_reg = 1, sregion%nregions associate (ftuple => sregion%ftuples(i_reg)) call ftuple%get(i, j) i_res = ftuple%i_res end associate pfr = map%res_map%get_resonance_value (i_res, p_born) i_con = sregion%i_reg_to_i_con (i_reg) if (j == nlegs) d = d + pfr / map%dij_soft (p_born, p_soft, i, i_con) end do map%sumdij_soft = d end subroutine fks_mapping_resonances_compute_sumdij_soft @ %def fks_mapping_resonances_compute_sumdij_soft @ <>= procedure :: svalue_soft => fks_mapping_resonances_svalue_soft <>= function fks_mapping_resonances_svalue_soft (map, p_born, p_soft, em, i_res) result (value) real(default) :: value class(fks_mapping_resonances_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft integer, intent(in) :: em integer, intent(in), optional :: i_res real(default) :: pfr pfr = map%res_map%get_resonance_value (i_res, p_born) value = pfr / (map%sumdij_soft * map%dij_soft (p_born, p_soft, em, map%i_con)) end function fks_mapping_resonances_svalue_soft @ %def fks_mapping_resonances_svalue_soft @ <>= procedure :: set_resonance_momentum => fks_mapping_resonances_set_resonance_momentum <>= subroutine fks_mapping_resonances_set_resonance_momentum (map, p) class(fks_mapping_resonances_t), intent(inout) :: map type(vector4_t), intent(in) :: p map%res_map%p_res = p end subroutine fks_mapping_resonances_set_resonance_momentum @ %def fks_mapping_resonances_set_resonance_momentum @ <>= procedure :: set_resonance_momenta => fks_mapping_resonances_set_resonance_momenta <>= subroutine fks_mapping_resonances_set_resonance_momenta (map, p) class(fks_mapping_resonances_t), intent(inout) :: map type(vector4_t), intent(in), dimension(:) :: p map%res_map%p_res = p end subroutine fks_mapping_resonances_set_resonance_momenta @ %def fks_mapping_resonances_set_resonance_momenta @ <>= interface assignment(=) module procedure fks_mapping_resonances_assign end interface <>= subroutine fks_mapping_resonances_assign (fks_map_out, fks_map_in) type(fks_mapping_resonances_t), intent(out) :: fks_map_out type(fks_mapping_resonances_t), intent(in) :: fks_map_in fks_map_out%exp_1 = fks_map_in%exp_1 fks_map_out%exp_2 = fks_map_in%exp_2 fks_map_out%res_map = fks_map_in%res_map end subroutine fks_mapping_resonances_assign @ %def fks_mapping_resonances_assign @ <>= public :: create_resonance_histories_for_threshold <>= function create_resonance_histories_for_threshold () result (res_history) type(resonance_history_t) :: res_history res_history%n_resonances = 2 allocate (res_history%resonances (2)) allocate (res_history%resonances(1)%contributors%c(2)) allocate (res_history%resonances(2)%contributors%c(2)) res_history%resonances(1)%contributors%c = [THR_POS_WP, THR_POS_B] res_history%resonances(2)%contributors%c = [THR_POS_WM, THR_POS_BBAR] end function create_resonance_histories_for_threshold @ %def create_resonance_histories_for_threshold @ <>= public :: setup_region_data_for_test <>= subroutine setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, nlo_corr_type) integer, intent(in) :: n_in integer, intent(in), dimension(:,:) :: flv_born, flv_real type(string_t), intent(in) :: nlo_corr_type type(region_data_t), intent(out) :: reg_data type(model_t), pointer :: test_model => null () call create_test_model (var_str ("SM"), test_model) call reg_data%init (n_in, test_model, flv_born, flv_real, nlo_corr_type) end subroutine setup_region_data_for_test @ %def setup_region_data_for_test @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Unit tests} \clearpage <<[[fks_regions_ut.f90]]>>= <> module fks_regions_ut use unit_tests use fks_regions_uti <> <> contains <> end module fks_regions_ut @ %def fks_regions_ut @ <<[[fks_regions_uti.f90]]>>= <> module fks_regions_uti <> use format_utils, only: write_separator use os_interface use models use fks_regions <> <> contains <> end module fks_regions_uti @ %def fks_regions_uti @ <>= public :: fks_regions_test <>= subroutine fks_regions_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results call test(fks_regions_1, "fks_regions_1", & "Test flavor structure utilities", u, results) call test(fks_regions_2, "fks_regions_2", & "Test singular regions for final-state radiation for n = 2", & u, results) call test(fks_regions_3, "fks_regions_3", & "Test singular regions for final-state radiation for n = 3", & u, results) call test(fks_regions_4, "fks_regions_4", & "Test singular regions for final-state radiation for n = 4", & u, results) call test(fks_regions_5, "fks_regions_5", & "Test singular regions for final-state radiation for n = 5", & u, results) call test(fks_regions_6, "fks_regions_6", & "Test singular regions for initial-state radiation", & u, results) call test(fks_regions_7, "fks_regions_7", & "Check Latex output", u, results) call test(fks_regions_8, "fks_regions_8", & "Test singular regions for initial-state photon contributions", & u, results) end subroutine fks_regions_test @ %def fks_regions_test @ <>= public :: fks_regions_1 <>= subroutine fks_regions_1 (u) integer, intent(in) :: u type(flv_structure_t) :: flv_born, flv_real type(model_t), pointer :: test_model => null () write (u, "(A)") "* Test output: fks_regions_1" write (u, "(A)") "* Purpose: Test utilities of flavor structure manipulation" write (u, "(A)") call create_test_model (var_str ("SM"), test_model) flv_born = [11, -11, 2, -2] flv_real = [11, -11, 2, -2, 21] flv_born%n_in = 2; flv_real%n_in = 2 write (u, "(A)") "* Valid splittings of ee -> uu" write (u, "(A)") "Born Flavors: " call flv_born%write (u) write (u, "(A)") "Real Flavors: " call flv_real%write (u) write (u, "(A,L1)") "3, 4 (2, -2) : ", flv_real%valid_pair (3, 4, flv_born, test_model) write (u, "(A,L1)") "4, 3 (-2, 2) : ", flv_real%valid_pair (4, 3, flv_born, test_model) write (u, "(A,L1)") "3, 5 (2, 21) : ", flv_real%valid_pair (3, 5, flv_born, test_model) write (u, "(A,L1)") "5, 3 (21, 2) : ", flv_real%valid_pair (5, 3, flv_born, test_model) write (u, "(A,L1)") "4, 5 (-2, 21): ", flv_real%valid_pair (4, 5, flv_born, test_model) write (u, "(A,L1)") "5, 4 (21, -2): ", flv_real%valid_pair (5, 4, flv_born, test_model) call write_separator (u) call flv_born%final () call flv_real%final () flv_born = [2, -2, 11, -11] flv_real = [2, -2, 11, -11, 21] flv_born%n_in = 2; flv_real%n_in = 2 write (u, "(A)") "* Valid splittings of uu -> ee" write (u, "(A)") "Born Flavors: " call flv_born%write (u) write (u, "(A)") "Real Flavors: " call flv_real%write (u) write (u, "(A,L1)") "1, 2 (2, -2) : " , flv_real%valid_pair (1, 2, flv_born, test_model) write (u, "(A,L1)") "2, 1 (-2, 2) : " , flv_real%valid_pair (2, 1, flv_born, test_model) write (u, "(A,L1)") "5, 2 (21, -2): " , flv_real%valid_pair (5, 2, flv_born, test_model) write (u, "(A,L1)") "2, 5 (-2, 21): " , flv_real%valid_pair (2, 5, flv_born, test_model) write (u, "(A,L1)") "1, 5 (21, 2) : " , flv_real%valid_pair (5, 1, flv_born, test_model) write (u, "(A,L1)") "5, 1 (2, 21) : " , flv_real%valid_pair (1, 5, flv_born, test_model) call flv_real%final () flv_real = [21, -2, 11, -11, -2] flv_real%n_in = 2 write (u, "(A)") "Real Flavors: " call flv_real%write (u) write (u, "(A,L1)") "1, 2 (21, -2): " , flv_real%valid_pair (1, 2, flv_born, test_model) write (u, "(A,L1)") "2, 1 (-2, 21): " , flv_real%valid_pair (2, 1, flv_born, test_model) write (u, "(A,L1)") "5, 2 (-2, -2): " , flv_real%valid_pair (5, 2, flv_born, test_model) write (u, "(A,L1)") "2, 5 (-2, -2): " , flv_real%valid_pair (2, 5, flv_born, test_model) write (u, "(A,L1)") "5, 1 (-2, 21): " , flv_real%valid_pair (5, 1, flv_born, test_model) write (u, "(A,L1)") "1, 5 (21, -2): " , flv_real%valid_pair (1, 5, flv_born, test_model) call flv_real%final () flv_real = [2, 21, 11, -11, 2] flv_real%n_in = 2 write (u, "(A)") "Real Flavors: " call flv_real%write (u) write (u, "(A,L1)") "1, 2 (2, 21) : " , flv_real%valid_pair (1, 2, flv_born, test_model) write (u, "(A,L1)") "2, 1 (21, 2) : " , flv_real%valid_pair (2, 1, flv_born, test_model) write (u, "(A,L1)") "5, 2 (2, 21) : " , flv_real%valid_pair (5, 2, flv_born, test_model) write (u, "(A,L1)") "2, 5 (21, 2) : " , flv_real%valid_pair (2, 5, flv_born, test_model) write (u, "(A,L1)") "5, 1 (2, 2) : " , flv_real%valid_pair (5, 1, flv_born, test_model) write (u, "(A,L1)") "1, 5 (2, 2) : " , flv_real%valid_pair (1, 5, flv_born, test_model) call write_separator (u) call flv_born%final () call flv_real%final () flv_born = [11, -11, 2, -2, 21] flv_real = [11, -11, 2, -2, 21, 21] flv_born%n_in = 2; flv_real%n_in = 2 write (u, "(A)") "* Valid splittings of ee -> uug" write (u, "(A)") "Born Flavors: " call flv_born%write (u) write (u, "(A)") "Real Flavors: " call flv_real%write (u) write (u, "(A,L1)") "3, 4 (2, -2) : " , flv_real%valid_pair (3, 4, flv_born, test_model) write (u, "(A,L1)") "4, 3 (-2, 2) : " , flv_real%valid_pair (4, 3, flv_born, test_model) write (u, "(A,L1)") "3, 5 (2, 21) : " , flv_real%valid_pair (3, 5, flv_born, test_model) write (u, "(A,L1)") "5, 3 (21, 2) : " , flv_real%valid_pair (5, 3, flv_born, test_model) write (u, "(A,L1)") "4, 5 (-2, 21): " , flv_real%valid_pair (4, 5, flv_born, test_model) write (u, "(A,L1)") "5, 4 (21, -2): " , flv_real%valid_pair (5, 4, flv_born, test_model) write (u, "(A,L1)") "3, 6 (2, 21) : " , flv_real%valid_pair (3, 6, flv_born, test_model) write (u, "(A,L1)") "6, 3 (21, 2) : " , flv_real%valid_pair (6, 3, flv_born, test_model) write (u, "(A,L1)") "4, 6 (-2, 21): " , flv_real%valid_pair (4, 6, flv_born, test_model) write (u, "(A,L1)") "6, 4 (21, -2): " , flv_real%valid_pair (6, 4, flv_born, test_model) write (u, "(A,L1)") "5, 6 (21, 21): " , flv_real%valid_pair (5, 6, flv_born, test_model) write (u, "(A,L1)") "6, 5 (21, 21): " , flv_real%valid_pair (6, 5, flv_born, test_model) call flv_real%final () flv_real = [11, -11, 2, -2, 1, -1] flv_real%n_in = 2 write (u, "(A)") "Real Flavors (exemplary g -> dd splitting): " call flv_real%write (u) write (u, "(A,L1)") "3, 4 (2, -2) : " , flv_real%valid_pair (3, 4, flv_born, test_model) write (u, "(A,L1)") "4, 3 (-2, 2) : " , flv_real%valid_pair (4, 3, flv_born, test_model) write (u, "(A,L1)") "3, 5 (2, 1) : " , flv_real%valid_pair (3, 5, flv_born, test_model) write (u, "(A,L1)") "5, 3 (1, 2) : " , flv_real%valid_pair (5, 3, flv_born, test_model) write (u, "(A,L1)") "4, 5 (-2, 1) : " , flv_real%valid_pair (4, 5, flv_born, test_model) write (u, "(A,L1)") "5, 4 (1, -2) : " , flv_real%valid_pair (5, 4, flv_born, test_model) write (u, "(A,L1)") "3, 6 (2, -1) : " , flv_real%valid_pair (3, 6, flv_born, test_model) write (u, "(A,L1)") "6, 3 (-1, 2) : " , flv_real%valid_pair (6, 3, flv_born, test_model) write (u, "(A,L1)") "4, 6 (-2, -1): " , flv_real%valid_pair (4, 6, flv_born, test_model) write (u, "(A,L1)") "6, 4 (-1, -2): " , flv_real%valid_pair (6, 4, flv_born, test_model) write (u, "(A,L1)") "5, 6 (1, -1) : " , flv_real%valid_pair (5, 6, flv_born, test_model) write (u, "(A,L1)") "6, 5 (-1, 1) : " , flv_real%valid_pair (6, 5, flv_born, test_model) call write_separator (u) call flv_born%final () call flv_real%final () flv_born = [6, -5, 2, -1 ] flv_real = [6, -5, 2, -1, 21] flv_born%n_in = 1; flv_real%n_in = 1 write (u, "(A)") "* Valid splittings of t -> b u d~" write (u, "(A)") "Born Flavors: " call flv_born%write (u) write (u, "(A)") "Real Flavors: " call flv_real%write (u) write (u, "(A,L1)") "1, 2 (6, -5) : " , flv_real%valid_pair (1, 2, flv_born, test_model) write (u, "(A,L1)") "1, 3 (6, 2) : " , flv_real%valid_pair (1, 3, flv_born, test_model) write (u, "(A,L1)") "1, 4 (6, -1) : " , flv_real%valid_pair (1, 4, flv_born, test_model) write (u, "(A,L1)") "2, 1 (-5, 6) : " , flv_real%valid_pair (2, 1, flv_born, test_model) write (u, "(A,L1)") "3, 1 (2, 6) : " , flv_real%valid_pair (3, 1, flv_born, test_model) write (u, "(A,L1)") "4, 1 (-1, 6) : " , flv_real%valid_pair (4, 1, flv_born, test_model) write (u, "(A,L1)") "2, 3 (-5, 2) : " , flv_real%valid_pair (2, 3, flv_born, test_model) write (u, "(A,L1)") "2, 4 (-5, -1): " , flv_real%valid_pair (2, 4, flv_born, test_model) write (u, "(A,L1)") "3, 2 (2, -5) : " , flv_real%valid_pair (3, 2, flv_born, test_model) write (u, "(A,L1)") "4, 2 (-1, -5): " , flv_real%valid_pair (4, 2, flv_born, test_model) write (u, "(A,L1)") "3, 4 (2, -1) : " , flv_real%valid_pair (3, 4, flv_born, test_model) write (u, "(A,L1)") "4, 3 (-1, 2) : " , flv_real%valid_pair (4, 3, flv_born, test_model) write (u, "(A,L1)") "1, 5 (6, 21) : " , flv_real%valid_pair (1, 5, flv_born, test_model) write (u, "(A,L1)") "5, 1 (21, 6) : " , flv_real%valid_pair (5, 1, flv_born, test_model) write (u, "(A,L1)") "2, 5 (-5, 21): " , flv_real%valid_pair (2, 5, flv_born, test_model) write (u, "(A,L1)") "5, 2 (21, 5) : " , flv_real%valid_pair (5, 2, flv_born, test_model) write (u, "(A,L1)") "3, 5 (2, 21) : " , flv_real%valid_pair (3, 5, flv_born, test_model) write (u, "(A,L1)") "5, 3 (21, 2) : " , flv_real%valid_pair (5, 3, flv_born, test_model) write (u, "(A,L1)") "4, 5 (-1, 21): " , flv_real%valid_pair (4, 5, flv_born, test_model) write (u, "(A,L1)") "5, 4 (21, -1): " , flv_real%valid_pair (5, 4, flv_born, test_model) call flv_born%final () call flv_real%final () end subroutine fks_regions_1 @ %def fks_regions_1 @ <>= public :: fks_regions_2 <>= subroutine fks_regions_2 (u) integer, intent(in) :: u integer :: n_flv_born, n_flv_real integer :: n_legs_born, n_legs_real integer :: n_in integer, dimension(:,:), allocatable :: flv_born, flv_real type(region_data_t) :: reg_data write (u, "(A)") "* Test output: fks_regions_2" write (u, "(A)") "* Create singular regions for processes with up to four singular regions" write (u, "(A)") "* ee -> qq with QCD corrections" write (u, "(A)") n_flv_born = 1; n_flv_real = 1 n_legs_born = 4; n_legs_real = 5 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, 2, -2] flv_real (:, 1) = [11, -11, 2, -2, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD")) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () call write_separator (u) write (u, "(A)") "* ee -> qq with QED corrections" write (u, "(A)") allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, 2, -2] flv_real (:, 1) = [11, -11, 2, -2, 22] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QED")) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () call write_separator (u) write (u, "(A)") "* ee -> tt" write (u, "(A)") write (u, "(A)") "* This process has four singular regions because they are not equivalent." n_flv_born = 1; n_flv_real = 1 n_legs_born = 6; n_legs_real = 7 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, 6, -6, 6, -6] flv_real (:, 1) = [11, -11, 6, -6, 6, -6, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD")) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () end subroutine fks_regions_2 @ %def fks_regions_2 @ <>= public :: fks_regions_3 <>= subroutine fks_regions_3 (u) integer, intent(in) :: u integer :: n_flv_born, n_flv_real integer :: n_legs_born, n_legs_real integer :: n_in, i, j integer, dimension(:,:), allocatable :: flv_born, flv_real type(region_data_t) :: reg_data write (u, "(A)") "* Test output: fks_regions_3" write (u, "(A)") "* Create singular regions for processes with three final-state particles" write (u, "(A)") "* ee -> qqg" write (u, "(A)") n_flv_born = 1; n_flv_real = 2 n_legs_born = 5; n_legs_real = 6 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, 2, -2, 21] flv_real (:, 1) = [11, -11, 2, -2, 21, 21] flv_real (:, 2) = [11, -11, 2, -2, 1, -1] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD")) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () call write_separator (u) write (u, "(A)") "* ee -> qqA" write (u, "(A)") n_flv_born = 1; n_flv_real = 2 n_legs_born = 5; n_legs_real = 6 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, 2, -2, 22] flv_real (:, 1) = [11, -11, 2, -2, 22, 22] flv_real (:, 2) = [11, -11, 2, -2, 11, -11] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QED")) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () call write_separator (u) write (u, "(A)") "* ee -> jet jet jet" write (u, "(A)") "* with jet = u:U:d:D:s:S:c:C:b:B:gl" write (u, "(A)") n_flv_born = 5; n_flv_real = 22 n_legs_born = 5; n_legs_real = 6 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, -4, 4, 21] flv_born (:, 2) = [11, -11, -2, 2, 21] flv_born (:, 3) = [11, -11, -5, 5, 21] flv_born (:, 4) = [11, -11, -3, 3, 21] flv_born (:, 5) = [11, -11, -1, 1, 21] flv_real (:, 1) = [11, -11, -4, -4, 4, 4] flv_real (:, 2) = [11, -11, -4, -2, 2, 4] flv_real (:, 3) = [11, -11, -4, 4, 21, 21] flv_real (:, 4) = [11, -11, -4, -5, 4, 5] flv_real (:, 5) = [11, -11, -4, -3, 4, 3] flv_real (:, 6) = [11, -11, -4, -1, 2, 3] flv_real (:, 7) = [11, -11, -4, -1, 4, 1] flv_real (:, 8) = [11, -11, -2, -2, 2, 2] flv_real (:, 9) = [11, -11, -2, 2, 21, 21] flv_real (:, 10) = [11, -11, -2, -5, 2, 5] flv_real (:, 11) = [11, -11, -2, -3, 2, 3] flv_real (:, 12) = [11, -11, -2, -3, 4, 1] flv_real (:, 13) = [11, -11, -2, -1, 2, 1] flv_real (:, 14) = [11, -11, -5, -5, 5, 5] flv_real (:, 15) = [11, -11, -5, -3, 3, 5] flv_real (:, 16) = [11, -11, -5, -1, 1, 5] flv_real (:, 17) = [11, -11, -5, 5, 21, 21] flv_real (:, 18) = [11, -11, -3, -3, 3, 3] flv_real (:, 19) = [11, -11, -3, -1, 1, 3] flv_real (:, 20) = [11, -11, -3, 3, 21, 21] flv_real (:, 21) = [11, -11, -1, -1, 1, 1] flv_real (:, 22) = [11, -11, -1, 1, 21, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD")) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () call write_separator (u) write (u, "(A)") "* ee -> L L A" write (u, "(A)") "* with L = e2:E2:e3:E3" write (u, "(A)") n_flv_born = 2; n_flv_real = 6 n_legs_born = 5; n_legs_real = 6 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, -15, 15, 22] flv_born (:, 2) = [11, -11, -13, 13, 22] flv_real (:, 1) = [11, -11, -15, -15, 15, 15] flv_real (:, 2) = [11, -11, -15, -13, 13, 13] flv_real (:, 3) = [11, -11, -13, -15, 13, 15] flv_real (:, 4) = [11, -11, -15, 15, 22, 22] flv_real (:, 5) = [11, -11, -13, -13, 13, 13] flv_real (:, 6) = [11, -11, -13, 13, 22, 22] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QED")) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () end subroutine fks_regions_3 @ %def fks_regions_3 @ <>= public :: fks_regions_4 <>= subroutine fks_regions_4 (u) integer, intent(in) :: u integer :: n_flv_born, n_flv_real integer :: n_legs_born, n_legs_real integer :: n_in integer, dimension(:,:), allocatable :: flv_born, flv_real type(region_data_t) :: reg_data write (u, "(A)") "* Test output: fks_regions_4" write (u, "(A)") "* Create singular regions for processes with four final-state particles" write (u, "(A)") "* ee -> 4 jet" write (u, "(A)") "* with jet = u:U:d:D:s:S:c:C:b:B:gl" write (u, "(A)") n_flv_born = 22; n_flv_real = 22 n_legs_born = 6; n_legs_real = 7 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, -4, -4, 4, 4] flv_born (:, 2) = [11, -11, -4, -2, 2, 4] flv_born (:, 3) = [11, -11, -4, 4, 21, 21] flv_born (:, 4) = [11, -11, -4, -5, 4, 5] flv_born (:, 5) = [11, -11, -4, -3, 4, 3] flv_born (:, 6) = [11, -11, -4, -1, 2, 3] flv_born (:, 7) = [11, -11, -4, -1, 4, 1] flv_born (:, 8) = [11, -11, -2, -2, 2, 2] flv_born (:, 9) = [11, -11, -2, 2, 21, 21] flv_born (:, 10) = [11, -11, -2, -5, 2, 5] flv_born (:, 11) = [11, -11, -2, -3, 2, 3] flv_born (:, 12) = [11, -11, -2, -3, 4, 1] flv_born (:, 13) = [11, -11, -2, -1, 2, 1] flv_born (:, 14) = [11, -11, -5, -5, 5, 5] flv_born (:, 15) = [11, -11, -5, -3, 3, 5] flv_born (:, 16) = [11, -11, -5, -1, 1, 5] flv_born (:, 17) = [11, -11, -5, 5, 21, 21] flv_born (:, 18) = [11, -11, -3, -3, 3, 3] flv_born (:, 19) = [11, -11, -3, -1, 1, 3] flv_born (:, 20) = [11, -11, -3, -3, 21, 21] flv_born (:, 21) = [11, -11, -1, -1, 1, 1] flv_born (:, 22) = [11, -11, -1, 1, 21, 21] flv_real (:, 1) = [11, -11, -4, -4, 4, 4, 21] flv_real (:, 2) = [11, -11, -4, -2, 2, 4, 21] flv_real (:, 3) = [11, -11, -4, 4, 21, 21, 21] flv_real (:, 4) = [11, -11, -4, -5, 4, 5, 21] flv_real (:, 5) = [11, -11, -4, -3, 4, 3, 21] flv_real (:, 6) = [11, -11, -4, -1, 2, 3, 21] flv_real (:, 7) = [11, -11, -4, -1, 4, 1, 21] flv_real (:, 8) = [11, -11, -2, -2, 2, 2, 21] flv_real (:, 9) = [11, -11, -2, 2, 21, 21, 21] flv_real (:, 10) = [11, -11, -2, -5, 2, 5, 21] flv_real (:, 11) = [11, -11, -2, -3, 2, 3, 21] flv_real (:, 12) = [11, -11, -2, -3, 4, 1, 21] flv_real (:, 13) = [11, -11, -2, -1, 2, 1, 21] flv_real (:, 14) = [11, -11, -5, -5, 5, 5, 21] flv_real (:, 15) = [11, -11, -5, -3, 3, 5, 21] flv_real (:, 16) = [11, -11, -5, -1, 1, 5, 21] flv_real (:, 17) = [11, -11, -5, 5, 21, 21, 21] flv_real (:, 18) = [11, -11, -3, -3, 3, 3, 21] flv_real (:, 19) = [11, -11, -3, -1, 1, 3, 21] flv_real (:, 20) = [11, -11, -3, 3, 21, 21, 21] flv_real (:, 21) = [11, -11, -1, -1, 1, 1, 21] flv_real (:, 22) = [11, -11, -1, 1, 21, 21, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD")) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () call write_separator (u) write (u, "(A)") "* ee -> bbmumu with QCD corrections" write (u, "(A)") n_flv_born = 1; n_flv_real = 1 n_legs_born = 6; n_legs_real = 7 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, -5, 5, -13, 13] flv_real (:, 1) = [11, -11, -5, 5, -13, 13, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD")) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () call write_separator (u) write (u, "(A)") "* ee -> bbmumu with QED corrections" write (u, "(A)") n_flv_born = 1; n_flv_real = 1 n_legs_born = 6; n_legs_real = 7 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, -5, 5, -13, 13] flv_real (:, 1) = [11, -11, -5, 5, -13, 13, 22] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD")) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () end subroutine fks_regions_4 @ %def fks_regions_4 @ <>= public :: fks_regions_5 <>= subroutine fks_regions_5 (u) integer, intent(in) :: u integer :: n_flv_born, n_flv_real integer :: n_legs_born, n_legs_real integer :: n_in integer, dimension(:,:), allocatable :: flv_born, flv_real type(region_data_t) :: reg_data write (u, "(A)") "* Test output: fks_regions_5" write (u, "(A)") "* Create singular regions for processes with five final-state particles" write (u, "(A)") "* ee -> 5 jet" write (u, "(A)") "* with jet = u:U:d:D:s:S:c:C:b:B:gl" write (u, "(A)") n_flv_born = 22; n_flv_real = 67 n_legs_born = 7; n_legs_real = 8 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:,1) = [11,-11,-4,-4,4,4,21] flv_born (:,2) = [11,-11,-4,-2,2,4,21] flv_born (:,3) = [11,-11,-4,4,21,21,21] flv_born (:,4) = [11,-11,-4,-5,4,5,21] flv_born (:,5) = [11,-11,-4,-3,4,3,21] flv_born (:,6) = [11,-11,-4,-1,2,3,21] flv_born (:,7) = [11,-11,-4,-1,4,1,21] flv_born (:,8) = [11,-11,-2,-2,2,2,21] flv_born (:,9) = [11,-11,-2,2,21,21,21] flv_born (:,10) = [11,-11,-2,-5,2,5,21] flv_born (:,11) = [11,-11,-2,-3,2,3,21] flv_born (:,12) = [11,-11,-2,-3,4,1,21] flv_born (:,13) = [11,-11,-2,-1,2,1,21] flv_born (:,14) = [11,-11,-5,-5,5,5,21] flv_born (:,15) = [11,-11,-5,-3,3,5,21] flv_born (:,16) = [11,-11,-5,-1,1,5,21] flv_born (:,17) = [11,-11,-5,5,21,21,21] flv_born (:,18) = [11,-11,-3,-3,3,3,21] flv_born (:,19) = [11,-11,-3,-1,1,3,21] flv_born (:,20) = [11,-11,-3,3,21,21,21] flv_born (:,21) = [11,-11,-1,-1,1,1,21] flv_born (:,22) = [11,-11,-1,1,21,21,21] flv_real (:,1) = [11,-11,-4,-4,-4,4,4,4] flv_real (:,2) = [11,-11,-4,-4,-2,2,4,4] flv_real (:,3) = [11,-11,-4,-4,4,4,21,21] flv_real (:,4) = [11,-11,-4,-4,-5,4,4,5] flv_real (:,5) = [11,-11,-4,-4,-3,4,4,3] flv_real (:,6) = [11,-11,-4,-4,-1,2,4,3] flv_real (:,7) = [11,-11,-4,-4,-1,4,4,1] flv_real (:,8) = [11,-11,-4,-2,-2,2,2,4] flv_real (:,9) = [11,-11,-4,-2,2,4,21,21] flv_real (:,10) = [11,-11,-4,-2,-5,2,4,5] flv_real (:,11) = [11,-11,-4,-2,-3,2,4,3] flv_real (:,12) = [11,-11,-4,-2,-3,4,4,1] flv_real (:,13) = [11,-11,-4,-2,-1,2,2,3] flv_real (:,14) = [11,-11,-4,-2,-1,2,4,1] flv_real (:,15) = [11,-11,-4,4,21,21,21,21] flv_real (:,16) = [11,-11,-4,-5,4,5,21,21] flv_real (:,17) = [11,-11,-4,-5,-5,4,5,5] flv_real (:,18) = [11,-11,-4,-5,-3,4,3,5] flv_real (:,19) = [11,-11,-4,-5,-1,2,3,5] flv_real (:,20) = [11,-11,-4,-5,-1,4,1,5] flv_real (:,21) = [11,-11,-4,-3,4,3,21,21] flv_real (:,22) = [11,-11,-4,-3,-3,4,3,3] flv_real (:,23) = [11,-11,-4,-3,-1,2,3,3] flv_real (:,24) = [11,-11,-4,-3,-1,4,1,3] flv_real (:,25) = [11,-11,-4,-1,2,3,21,21] flv_real (:,26) = [11,-11,-4,-1,4,1,21,21] flv_real (:,27) = [11,-11,-4,-1,-1,2,1,3] flv_real (:,28) = [11,-11,-4,-1,-1,4,1,1] flv_real (:,29) = [11,-11,-2,-2,-2,2,2,2] flv_real (:,30) = [11,-11,-2,-2,2,2,21,21] flv_real (:,31) = [11,-11,-2,-2,-5,2,2,5] flv_real (:,32) = [11,-11,-2,-2,-3,2,2,3] flv_real (:,33) = [11,-11,-2,-2,-3,2,4,1] flv_real (:,34) = [11,-11,-2,-2,-1,2,2,1] flv_real (:,35) = [11,-11,-2,2,21,21,21,21] flv_real (:,36) = [11,-11,-2,-5,2,5,21,21] flv_real (:,37) = [11,-11,-2,-5,-5,2,5,5] flv_real (:,38) = [11,-11,-2,-5,-3,2,3,5] flv_real (:,39) = [11,-11,-2,-5,-3,4,1,5] flv_real (:,40) = [11,-11,-2,-5,-1,2,1,5] flv_real (:,41) = [11,-11,-2,-3,2,3,21,21] flv_real (:,42) = [11,-11,-2,-3,4,1,21,21] flv_real (:,43) = [11,-11,-2,-3,-3,2,3,3] flv_real (:,44) = [11,-11,-2,-3,-3,4,1,3] flv_real (:,45) = [11,-11,-2,-3,-1,2,1,3] flv_real (:,46) = [11,-11,-2,-3,-1,4,1,1] flv_real (:,47) = [11,-11,-2,-1,2,1,21,21] flv_real (:,48) = [11,-11,-2,-1,-1,2,1,1] flv_real (:,49) = [11,-11,-5,-5,-5,5,5,5] flv_real (:,50) = [11,-11,-5,-5,-3,3,5,5] flv_real (:,51) = [11,-11,-5,-5,-1,1,5,5] flv_real (:,52) = [11,-11,-5,-5,5,5,21,21] flv_real (:,53) = [11,-11,-5,-3,-3,3,3,5] flv_real (:,54) = [11,-11,-5,-3,-1,1,3,5] flv_real (:,55) = [11,-11,-5,-3,3,5,21,21] flv_real (:,56) = [11,-11,-5,-1,-1,1,1,5] flv_real (:,57) = [11,-11,-5,-1,1,5,21,21] flv_real (:,58) = [11,-11,-5,5,21,21,21,21] flv_real (:,59) = [11,-11,-3,-3,-3,3,3,3] flv_real (:,60) = [11,-11,-3,-3,-1,1,3,3] flv_real (:,61) = [11,-11,-3,-3,3,3,21,21] flv_real (:,62) = [11,-11,-3,-1,-1,1,1,3] flv_real (:,63) = [11,-11,-3,-1,1,3,21,21] flv_real (:,64) = [11,-11,-3,3,21,21,21,21] flv_real (:,65) = [11,-11,-1,-1,-1,1,1,1] flv_real (:,66) = [11,-11,-1,-1,1,1,21,21] flv_real (:,67) = [11,-11,-1,1,21,21,21,21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD")) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () end subroutine fks_regions_5 @ %def fks_regions_5 @ <>= public :: fks_regions_6 <>= subroutine fks_regions_6 (u) integer, intent(in) :: u integer :: n_flv_born, n_flv_real integer :: n_legs_born, n_legs_real integer :: n_in integer, dimension(:,:), allocatable :: flv_born, flv_real type(region_data_t) :: reg_data integer :: i, j integer, dimension(10) :: flavors write (u, "(A)") "* Test output: fks_regions_6" write (u, "(A)") "* Create table of singular regions for Drell Yan" write (u, "(A)") n_flv_born = 10; n_flv_real = 30 n_legs_born = 4; n_legs_real = 5 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flavors = [-5, -4, -3, -2, -1, 1, 2, 3, 4, 5] do i = 1, n_flv_born flv_born (3:4, i) = [11, -11] end do do j = 1, n_flv_born flv_born (1, j) = flavors (j) flv_born (2, j) = -flavors (j) end do do i = 1, n_flv_real flv_real (3:4, i) = [11, -11] end do i = 1 do j = 1, n_flv_real if (mod (j, 3) == 1) then flv_real (1, j) = flavors (i) flv_real (2, j) = -flavors (i) flv_real (5, j) = 21 else if (mod (j, 3) == 2) then flv_real (1, j) = flavors (i) flv_real (2, j) = 21 flv_real (5, j) = flavors (i) else flv_real (1, j) = 21 flv_real (2, j) = -flavors (i) flv_real (5, j) = -flavors (i) i = i + 1 end if end do call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD")) call reg_data%check_consistency (.false., u) call reg_data%write (u) call write_separator (u) deallocate (flv_born, flv_real) call reg_data%final () write (u, "(A)") "* Create table of singular regions for hadronic top decay" write (u, "(A)") n_flv_born = 1; n_flv_real = 1 n_legs_born = 4; n_legs_real = 5 n_in = 1 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [6, -5, 2, -1] flv_real (:, 1) = [6, -5, 2, -1, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD")) call reg_data%check_consistency (.false., u) call reg_data%write (u) call write_separator (u) deallocate (flv_born, flv_real) call reg_data%final () write (u, "(A)") "* Create table of singular regions for dijet s sbar -> jet jet" write (u, "(A)") "* With jet = u:d:gl" write (u, "(A)") n_flv_born = 3; n_flv_real = 3 n_legs_born = 4; n_legs_real = 5 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) do i = 1, n_flv_born flv_born (1:2, i) = [3, -3] end do flv_born (3, :) = [1, 2, 21] flv_born (4, :) = [-1, -2, 21] do i = 1, n_flv_real flv_real (1:2, i) = [3, -3] end do flv_real (3, :) = [1, 2, 21] flv_real (4, :) = [-1, -2, 21] flv_real (5, :) = [21, 21, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD")) call reg_data%check_consistency (.false., u) call reg_data%write (u) call reg_data%final () end subroutine fks_regions_6 @ %def fks_regions_6 @ <>= public :: fks_regions_7 <>= subroutine fks_regions_7 (u) integer, intent(in) :: u integer :: n_flv_born, n_flv_real integer :: n_legs_born, n_legs_real integer :: n_in integer, dimension(:,:), allocatable :: flv_born, flv_real type(region_data_t) :: reg_data write (u, "(A)") "* Test output: fks_regions_7" write (u, "(A)") "* Create table of singular regions for ee -> qq" write (u, "(A)") n_flv_born = 1; n_flv_real = 1 n_legs_born = 4; n_legs_real = 5 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, 2, -2] flv_real (:, 1) = [11, -11, 2, -2, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD")) call reg_data%write_latex (u) call reg_data%final () end subroutine fks_regions_7 @ %def fks_regions_7 @ <>= public :: fks_regions_8 <>= subroutine fks_regions_8 (u) integer, intent(in) :: u integer :: n_flv_born, n_flv_real integer :: n_legs_born, n_legs_real integer :: n_in integer, dimension(:,:), allocatable :: flv_born, flv_real type(region_data_t) :: reg_data integer :: i, j integer, dimension(10) :: flavors write (u, "(A)") "* Test output: fks_regions_8" write (u, "(A)") "* Create table of singular regions for ee -> ee" write (u, "(A)") n_flv_born = 1; n_flv_real = 3 n_legs_born = 4; n_legs_real = 5 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, -11, 11] flv_real (:, 1) = [11, -11, -11, 11, 22] flv_real (:, 2) = [11, 22, -11, 11, 11] flv_real (:, 3) = [22, -11, 11, -11, -11] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QED")) call reg_data%check_consistency (.false., u) call reg_data%write (u) call reg_data%final () end subroutine fks_regions_8 @ %def fks_regions_8 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Virtual contribution to the cross section} <<[[virtual.f90]]>>= <> module virtual <> <> use numeric_utils use constants use diagnostics use pdg_arrays use models use model_data, only: model_data_t use physics_defs use sm_physics use lorentz use flavors use nlo_data, only: get_threshold_momenta, nlo_settings_t use nlo_data, only: ASSOCIATED_LEG_PAIR use fks_regions <> <> <> <> contains <> end module virtual @ %def virtual @ <>= public :: virtual_t <>= type :: virtual_t type(nlo_settings_t), pointer :: settings real(default), dimension(:,:), allocatable :: gamma_0, gamma_p, c_flv real(default) :: ren_scale2, fac_scale, es_scale2 integer, dimension(:), allocatable :: n_is_neutrinos integer :: n_in, n_legs, n_flv logical :: bad_point = .false. type(string_t) :: selection real(default), dimension(:), allocatable :: sqme_born real(default), dimension(:), allocatable :: sqme_virt_fin real(default), dimension(:,:,:), allocatable :: sqme_color_c real(default), dimension(:,:,:), allocatable :: sqme_charge_c logical :: has_pdfs = .false. contains <> end type virtual_t @ %def virtual_t @ <>= procedure :: init => virtual_init <>= subroutine virtual_init (virt, flv_born, n_in, settings, & nlo_corr_type, model, has_pdfs) class(virtual_t), intent(inout) :: virt integer, intent(in), dimension(:,:) :: flv_born integer, intent(in) :: n_in type(nlo_settings_t), intent(in), pointer :: settings type(string_t), intent(in) :: nlo_corr_type class(model_data_t), intent(in) :: model logical, intent(in) :: has_pdfs integer :: i_flv virt%n_legs = size (flv_born, 1); virt%n_flv = size (flv_born, 2) virt%n_in = n_in allocate (virt%sqme_born (virt%n_flv)) allocate (virt%sqme_virt_fin (virt%n_flv)) allocate (virt%sqme_color_c (virt%n_legs, virt%n_legs, virt%n_flv)) allocate (virt%sqme_charge_c (virt%n_legs, virt%n_legs, virt%n_flv)) allocate (virt%gamma_0 (virt%n_legs, virt%n_flv), & virt%gamma_p (virt%n_legs, virt%n_flv), & virt%c_flv (virt%n_legs, virt%n_flv)) call virt%init_constants (flv_born, settings%fks_template%n_f, nlo_corr_type, model) allocate (virt%n_is_neutrinos (virt%n_flv)) virt%n_is_neutrinos = 0 do i_flv = 1, virt%n_flv if (is_neutrino (flv_born(1, i_flv))) & virt%n_is_neutrinos(i_flv) = virt%n_is_neutrinos(i_flv) + 1 if (is_neutrino (flv_born(2, i_flv))) & virt%n_is_neutrinos(i_flv) = virt%n_is_neutrinos(i_flv) + 1 end do select case (char (settings%virtual_selection)) case ("Full", "OLP", "Subtraction") virt%selection = settings%virtual_selection case default call msg_fatal ('Virtual selection: Possible values are "Full", "OLP" or "Subtraction') end select virt%settings => settings virt%has_pdfs = has_pdfs contains function is_neutrino (flv) result (neutrino) integer, intent(in) :: flv logical :: neutrino neutrino = (abs(flv) == 12 .or. abs(flv) == 14 .or. abs(flv) == 16) end function is_neutrino end subroutine virtual_init @ %def virtual_init @ The virtual subtraction terms contain Casimir operators and derived constants, listed below: \begin{align} \label{eqn:C(q)} C(q) = C(\bar{q}) &= C_F, \\ \label{eqn:C(g)} C(g) &= C_A,\\ \label{eqn:gamma(q)} \gamma(q) = \gamma(\bar{q}) &= \frac{3}{2} C_F,\\ \label{eqn:gamma(g)} \gamma(g) &= \frac{11}{6} C_A - \frac{2}{3} T_F N_f,\\ \label{eqn:gammap(q)} \gamma'(q) = \gamma'(\bar{q}) &= \left(\frac{13}{2} - \frac{2\pi^2}{3}\right) C_F, \\ \label{eqn:gammap(g)} \gamma'(g) &= \left(\frac{67}{9} - \frac{2\pi^2}{3}\right) C_A - \frac{23}{9} T_F N_f. \end{align} For uncolored particles, [[virtual_init_constants]] sets $C$, $\gamma$ and $\gamma'$ to zero. <>= procedure :: init_constants => virtual_init_constants <>= subroutine virtual_init_constants (virt, flv_born, nf_input, nlo_corr_type, model) class(virtual_t), intent(inout) :: virt integer, intent(in), dimension(:,:) :: flv_born integer, intent(in) :: nf_input type(string_t), intent(in) :: nlo_corr_type class(model_data_t), intent(in) :: model integer :: i_part, i_flv real(default) :: nf, CA_factor real(default), dimension(:,:), allocatable :: CF_factor, TR_factor type(flavor_t) :: flv allocate (CF_factor (size (flv_born, 1), size (flv_born, 2)), & TR_factor (size (flv_born, 1), size (flv_born, 2))) if (nlo_corr_type == "QCD") then CA_factor = CA; CF_factor = CF; TR_factor = TR nf = real(nf_input, default) else if (nlo_corr_type == "QED") then CA_factor = zero do i_flv = 1, size (flv_born, 2) do i_part = 1, size (flv_born, 1) call flv%init (flv_born(i_part, i_flv), model) CF_factor(i_part, i_flv) = (flv%get_charge ())**2 TR_factor(i_part, i_flv) = (flv%get_charge ())**2 end do end do ! TODO vincent_r fixed nf needs replacement !!! for testing only, needs dynamical treatment! nf = real(4, default) end if do i_flv = 1, size (flv_born, 2) do i_part = 1, size (flv_born, 1) if (is_corresponding_vector (flv_born(i_part, i_flv), nlo_corr_type)) then virt%gamma_0(i_part, i_flv) = 11._default / 6._default * CA_factor & - two / three * TR_factor(i_part, i_flv) * nf virt%gamma_p(i_part, i_flv) = (67._default / 9._default & - two * pi**2 / three) * CA_factor & - 23._default / 9._default * TR_factor(i_part, i_flv) * nf virt%c_flv(i_part, i_flv) = CA_factor else if (is_corresponding_fermion (flv_born(i_part, i_flv), nlo_corr_type)) then virt%gamma_0(i_part, i_flv) = 1.5_default * CF_factor(i_part, i_flv) virt%gamma_p(i_part, i_flv) = (6.5_default - two * pi**2 / three) * CF_factor(i_part, i_flv) virt%c_flv(i_part, i_flv) = CF_factor(i_part, i_flv) else virt%gamma_0(i_part, i_flv) = zero virt%gamma_p(i_part, i_flv) = zero virt%c_flv(i_part, i_flv) = zero end if end do end do contains function is_corresponding_vector (pdg_nr, nlo_corr_type) logical :: is_corresponding_vector integer, intent(in) :: pdg_nr type(string_t), intent(in) :: nlo_corr_type is_corresponding_vector = .false. if (nlo_corr_type == "QCD") then is_corresponding_vector = is_gluon (pdg_nr) else if (nlo_corr_type == "QED") then is_corresponding_vector = is_photon (pdg_nr) end if end function is_corresponding_vector function is_corresponding_fermion (pdg_nr, nlo_corr_type) logical :: is_corresponding_fermion integer, intent(in) :: pdg_nr type(string_t), intent(in) :: nlo_corr_type is_corresponding_fermion = .false. if (nlo_corr_type == "QCD") then is_corresponding_fermion = is_quark (pdg_nr) else if (nlo_corr_type == "QED") then is_corresponding_fermion = is_fermion (pdg_nr) end if end function is_corresponding_fermion end subroutine virtual_init_constants @ %def virtual_init_constants @ Set the renormalization scale. If the input is zero, use the center-of-mass energy. <>= procedure :: set_ren_scale => virtual_set_ren_scale <>= subroutine virtual_set_ren_scale (virt, p, ren_scale) class(virtual_t), intent(inout) :: virt type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: ren_scale if (ren_scale > 0) then virt%ren_scale2 = ren_scale**2 else virt%ren_scale2 = (p(1) + p(2))**2 end if end subroutine virtual_set_ren_scale @ %def virtual_set_ren_scale @ <>= procedure :: set_fac_scale => virtual_set_fac_scale <>= subroutine virtual_set_fac_scale (virt, p, fac_scale) class(virtual_t), intent(inout) :: virt type(vector4_t), dimension(:), intent(in) :: p real(default), optional :: fac_scale if (present (fac_scale)) then virt%fac_scale = fac_scale else virt%fac_scale = (p(1) + p(2))**1 end if end subroutine virtual_set_fac_scale @ %def virtual_set_fac_scale <>= procedure :: set_ellis_sexton_scale => virtual_set_ellis_sexton_scale <>= subroutine virtual_set_ellis_sexton_scale (virt, Q2) class(virtual_t), intent(inout) :: virt real(default), intent(in), optional :: Q2 if (present (Q2)) then virt%es_scale2 = Q2 else virt%es_scale2 = virt%ren_scale2 end if end subroutine virtual_set_ellis_sexton_scale @ %def virtual_set_ellis_sexton_scale @ The virtual-subtracted matrix element is given by the equation \begin{equation} \label{eqn:virt_sub} \mathcal{V} = \frac{\alpha_s}{2\pi}\left(\mathcal{Q}\mathcal{B} + \sum \mathcal{I}_{ij}\mathcal{B}_{ij} + \mathcal{V}_{fin}\right), \end{equation} The expressions for $\mathcal{Q}$ can be found in equations \ref{eqn:virt_Q_isr} and \ref{eqn:virt_Q_fsr}. The expressions for $\mathcal{I}_{ij}$ can be found in equations (\ref{I_00}), (\ref{I_mm}), (\ref{I_0m}), depending on whether the particles involved in the radiation process are massive or massless. <>= procedure :: evaluate => virtual_evaluate <>= subroutine virtual_evaluate (virt, reg_data, alpha_coupling, & p_born, separate_alrs, sqme_virt) class(virtual_t), intent(inout) :: virt type(region_data_t), intent(in) :: reg_data real(default), intent(in) :: alpha_coupling type(vector4_t), intent(in), dimension(:) :: p_born logical, intent(in) :: separate_alrs real(default), dimension(:), intent(inout) :: sqme_virt real(default) :: s, s_o_Q2 real(default), dimension(reg_data%n_flv_born) :: QB, BI integer :: i_flv, ii_flv QB = zero; BI = zero if (virt%bad_point) return if (debug2_active (D_VIRTUAL)) then print *, 'Compute virtual component using alpha = ', alpha_coupling print *, 'Virtual selection: ', char (virt%selection) print *, 'virt%es_scale2 = ', virt%es_scale2 !!! Debugging end if s = sum (p_born(1 : virt%n_in))**2 if (virt%settings%factorization_mode == FACTORIZATION_THRESHOLD) & call set_s_for_threshold () s_o_Q2 = s / virt%es_scale2 * virt%settings%fks_template%xi_cut**2 do i_flv = 1, reg_data%n_flv_born if (separate_alrs) then ii_flv = i_flv else ii_flv = 1 end if if (virt%selection == var_str ("Full") .or. virt%selection == var_str ("OLP")) then !!! A factor of alpha_coupling/twopi is assumed to be included in vfin sqme_virt(ii_flv) = sqme_virt(ii_flv) + virt%sqme_virt_fin(i_flv) end if if (virt%selection == var_str ("Full") .or. virt%selection == var_str ("Subtraction")) then call virt%evaluate_initial_state (i_flv, QB) call virt%compute_collinear_contribution (i_flv, p_born, sqrt(s), reg_data, QB) select case (virt%settings%factorization_mode) case (FACTORIZATION_THRESHOLD) call virt%compute_eikonals_threshold (i_flv, p_born, s_o_Q2, QB, BI) case default call virt%compute_massive_self_eikonals (i_flv, p_born, s_o_Q2, reg_data, QB) call virt%compute_eikonals (i_flv, p_born, s_o_Q2, reg_data, BI) end select if (debug2_active (D_VIRTUAL)) then print *, 'Evaluate i_flv: ', i_flv print *, 'sqme_born: ', virt%sqme_born (i_flv) print *, 'Q * sqme_born: ', alpha_coupling / twopi * QB(i_flv) print *, 'BI: ', alpha_coupling / twopi * BI(i_flv) print *, 'vfin: ', virt%sqme_virt_fin (i_flv) end if sqme_virt(ii_flv) = & sqme_virt(ii_flv) + alpha_coupling / twopi * (QB(i_flv) + BI(i_flv)) end if end do if (debug2_active (D_VIRTUAL)) then call msg_debug2 (D_VIRTUAL, "virtual-subtracted matrix element(s): ") print *, sqme_virt end if do i_flv = 1, reg_data%n_flv_born if (virt%n_is_neutrinos(i_flv) > 0) & sqme_virt = sqme_virt * virt%n_is_neutrinos(i_flv) * two end do contains subroutine set_s_for_threshold () use ttv_formfactors, only: m1s_to_mpole real(default) :: mtop2 mtop2 = m1s_to_mpole (sqrt(s))**2 if (s < four * mtop2) s = four * mtop2 end subroutine set_s_for_threshold end subroutine virtual_evaluate @ %def virtual_evaluate @ <>= procedure :: compute_eikonals => virtual_compute_eikonals <>= subroutine virtual_compute_eikonals (virtual, i_flv, & p_born, s_o_Q2, reg_data, BI) class(virtual_t), intent(inout) :: virtual integer, intent(in) :: i_flv type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in) :: s_o_Q2 type(region_data_t), intent(in) :: reg_data real(default), intent(inout), dimension(:) :: BI integer :: i, j real(default) :: I_ij, BI_tmp BI_tmp = zero ! TODO vincent_r: Split the procedure into one computing QCD eikonals and one computing QED eikonals. ! TODO vincent_r: In the best case, remove the dependency on reg_data completely. associate (flst_born => reg_data%flv_born(i_flv), & nlo_corr_type => reg_data%regions(1)%nlo_correction_type) do i = 1, virtual%n_legs do j = 1, virtual%n_legs if (i /= j) then if (nlo_corr_type == "QCD") then if (flst_born%colored(i) .and. flst_born%colored(j)) then I_ij = compute_eikonal_factor (p_born, flst_born%massive, & i, j, s_o_Q2) BI_tmp = BI_tmp + virtual%sqme_color_c (i, j, i_flv) * I_ij if (debug2_active (D_VIRTUAL)) & print *, 'b_ij: ', i, j, virtual%sqme_color_c (i, j, i_flv), 'I_ij: ', I_ij end if else if (nlo_corr_type == "QED") then I_ij = compute_eikonal_factor (p_born, flst_born%massive, & i, j, s_o_Q2) BI_tmp = BI_tmp + virtual%sqme_charge_c (i, j, i_flv) * I_ij if (debug2_active (D_VIRTUAL)) & print *, 'b_ij: ', virtual%sqme_charge_c (i, j, i_flv), 'I_ij: ', I_ij end if else if (debug2_active (D_VIRTUAL)) then print *, 'b_ij: ', i, j, virtual%sqme_color_c (i, j, i_flv), 'I_ij: ', I_ij end if end do end do if (virtual%settings%use_internal_color_correlations .or. nlo_corr_type == "QED") & BI_tmp = BI_tmp * virtual%sqme_born (i_flv) end associate BI(i_flv) = BI(i_flv) + BI_tmp end subroutine virtual_compute_eikonals @ %def virtual_compute_eikonals @ <>= procedure :: compute_eikonals_threshold => virtual_compute_eikonals_threshold <>= subroutine virtual_compute_eikonals_threshold (virtual, i_flv, & p_born, s_o_Q2, QB, BI) class(virtual_t), intent(in) :: virtual integer, intent(in) :: i_flv type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in) :: s_o_Q2 real(default), intent(inout), dimension(:) :: QB real(default), intent(inout), dimension(:) :: BI type(vector4_t), dimension(4) :: p_thr integer :: leg BI = zero; p_thr = get_threshold_momenta (p_born) call compute_massive_self_eikonals (virtual%sqme_born(i_flv), QB(i_flv)) do leg = 1, 2 BI(i_flv) = BI(i_flv) + evaluate_leg_pair (ASSOCIATED_LEG_PAIR(leg), i_flv) end do contains subroutine compute_massive_self_eikonals (sqme_born, QB) real(default), intent(in) :: sqme_born real(default), intent(inout) :: QB integer :: i call msg_debug2 (D_VIRTUAL, "compute_massive_self_eikonals") call msg_debug2 (D_VIRTUAL, "s_o_Q2", s_o_Q2) call msg_debug2 (D_VIRTUAL, "log (s_o_Q2)", log (s_o_Q2)) do i = 1, 4 QB = QB - (cf * (log (s_o_Q2) - 0.5_default * I_m_eps (p_thr(i)))) & * sqme_born end do end subroutine compute_massive_self_eikonals function evaluate_leg_pair (i_start, i_flv) result (b_ij_times_I) real(default) :: b_ij_times_I integer, intent(in) :: i_start, i_flv real(default) :: I_ij integer :: i, j b_ij_times_I = zero do i = i_start, i_start + 1 do j = i_start, i_start + 1 if (i /= j) then I_ij = compute_eikonal_factor & (p_thr, [.true., .true., .true., .true.], i, j, s_o_Q2) b_ij_times_I = b_ij_times_I + & virtual%sqme_color_c (i, j, i_flv) * I_ij if (debug2_active (D_VIRTUAL)) & print *, 'b_ij: ', virtual%sqme_color_c (i, j, i_flv), 'I_ij: ', I_ij end if end do end do if (virtual%settings%use_internal_color_correlations) & b_ij_times_I = b_ij_times_I * virtual%sqme_born (i_flv) if (debug2_active (D_VIRTUAL)) then print *, 'internal color: ', virtual%settings%use_internal_color_correlations print *, 'b_ij_times_I = ', b_ij_times_I print *, 'QB = ', QB end if end function evaluate_leg_pair end subroutine virtual_compute_eikonals_threshold @ %def virtual_compute_eikonals_threshold @ <>= procedure :: set_bad_point => virtual_set_bad_point <>= subroutine virtual_set_bad_point (virt, value) class(virtual_t), intent(inout) :: virt logical, intent(in) :: value virt%bad_point = value end subroutine virtual_set_bad_point @ %def virtual_set_bad_point @ The collinear limit of $\tilde{\mathcal{R}}$ can be integrated over the radiation degrees of freedom, giving the collinear contribution to the virtual component. Its general structure is $\mathcal{Q} \cdot \mathcal{B}$. The initial-state contribution to $\mathcal{Q}$ is simply given by \begin{equation} \label{eqn:virt_Q_isr} \mathcal{Q} = -\log\frac{\mu_F^2}{Q^2} \left(\gamma(\mathcal{I}_1) + 2 C (\mathcal{I}_1) \log(\xi_{\text{cut}}) + \gamma(\mathcal{I}_2) + 2 C (\mathcal{I}_2) \log(\xi_{\text{cut}}) \right), \end{equation} where $Q^2$ is the Ellis-Sexton scale and $\gamma$ is as in eqns. \ref{eqn:gamma(q)} and \ref{eqn:gamma(g)}.\\ [[virtual_evaluate_initial_state]] computes this quantity. The loop over the initial-state particles is only executed if we are dealing with a scattering process, because for decays there are no virtual initial-initial interactions. <>= procedure :: evaluate_initial_state => virtual_evaluate_initial_state <>= subroutine virtual_evaluate_initial_state (virt, i_flv, QB) class(virtual_t), intent(inout) :: virt integer, intent(in) :: i_flv real(default), intent(inout), dimension(:) :: QB integer :: i if (virt%n_in == 2) then do i = 1, virt%n_in QB(i_flv) = QB(i_flv) - (virt%gamma_0 (i, i_flv) + two * virt%c_flv(i, i_flv) & * log (virt%settings%fks_template%xi_cut)) & * log(virt%fac_scale**2 / virt%es_scale2) * virt%sqme_born (i_flv) end do end if end subroutine virtual_evaluate_initial_state @ %def virtual_evaluate_initial_state @ Same as above, but for final-state particles. The collinear limit for final-state particles follows from the integral \begin{equation*} I_{+,\alpha_r} = \int d\Phi_{n+1} \frac{\xi_+^{-1-2\epsilon}}{\xi^{-1-2\epsilon}} \mathcal{R}_{\alpha_r}. \end{equation*} We can distinguish three situations: \begin{enumerate} \item $\alpha_r$ contains a massive emitter. In this case, no collinear subtraction terms is required and the integral above irrelevant. \item $\alpha_r$ contains a massless emitter, but resonances are not taken into account in the subtraction. Here, $\xi_{max} = \frac{2E_{em}}{\sqrt{s}}$ is the upper bound on $\xi$. \item $\alpha_r$ contains a massless emitter and resonance-aware subtraction is used. Here, $\xi_{max} = \frac{2E_{em}}{\sqrt{k_{res}^2}}$. \end{enumerate} Before version 2.4, only situations 1 and 2 were covered. The difference between situation 2 and 3 comes from the expansion of the plus-distribution in the integral above, \begin{equation*} \xi_+^{-1-2\epsilon} = \xi^{-1-2\epsilon} + \frac{1}{2\epsilon}\delta(\xi) = \xi_{max}^{-1-2\epsilon}\left[(1-z)^{-1-2\epsilon} + \frac{\xi_{max}^{2\epsilon}}{2\epsilon}\delta(1-z)\right]. \end{equation*} The expression from the standard FKS literature is given by $\mathcal{Q}$ is given by \begin{equation} \label{eqn:virt_Q_fsr_old} \begin{split} \mathcal{Q} = \sum_{k=n_{in}}^{n_L^{(B)}} \left[\gamma'(\mathcal{I}_k) - \log\frac{s\delta_{0}}{2Q^2}\left(\gamma(\mathcal{I}_k) - 2C(\mathcal{I}_k) \log\frac{2E_k}{\xi_{\text{cut}}\sqrt{s}}\right) \right.\\ + \left. 2C(\mathcal{I}_k) \left( \log^2\frac{2E_k}{\sqrt{s}} - \log^2 \xi_{\text{cut}} \right) - 2\gamma(\mathcal{I}_k)\log\frac{2E_k}{\sqrt{s}}\right]. \end{split} \end{equation} $n_L^{(B)}$ is the number of legs at Born level. Here, $\xi_{max}$ is implicitly present in the ratios in the logarithms. Using the resonance-aware $\xi_{max}$ yields \begin{equation} \label{eqn:virt_Q_fsr} \begin{split} \mathcal{Q} = \sum_{k=n_{in}}^{n_L^{(B)}} \left[\gamma'(\mathcal{I}_k) + 2\left(\log\frac{\sqrt{s}}{2E_{em}} + \log\xi_{max}\right) \left(\log\frac{\sqrt{s}}{2E_{em}} + \log\xi_{max} + \log\frac{Q^2}{s}\right) C(\mathcal{I}_k) \right.\\ + \left. 2 \log\xi_{max} \left(\log\xi_{max} - \log\frac{Q^2}{k_{res}^2}\right) C(\mathcal{I}_k) + \left(\log\frac{Q^2}{k_{res}^2} - 2 \log\xi_{max}\right) \gamma(\mathcal{I}_k)\right]. \end{split} \end{equation} Equation \ref{eqn:virt_Q_fsr} leads to \ref{eqn:virt_Q_fsr_old} with the substitutions $\xi_{max} \rightarrow \frac{2E_{em}}{\sqrt{s}}$ and $k_{res}^2 \rightarrow s$. [[virtual_compute_collinear_contribution]] only implements the second one. <>= procedure :: compute_collinear_contribution & => virtual_compute_collinear_contribution <>= subroutine virtual_compute_collinear_contribution (virt, i_flv, & p_born, sqrts, reg_data, QB) class(virtual_t), intent(inout) :: virt integer, intent(in) :: i_flv type(vector4_t), dimension(:), intent(in) :: p_born real(default), intent(in) :: sqrts type(region_data_t), intent(in) :: reg_data real(default), intent(inout), dimension(:) :: QB real(default) :: s1, s2, s3, s4, s5 integer :: alr, em real(default) :: E_em, xi_max, log_xi_max, E_tot2 logical, dimension(virt%n_flv, virt%n_legs) :: evaluated integer :: i_contr type(vector4_t) :: k_res type(lorentz_transformation_t) :: L_to_resonance evaluated = .false. do alr = 1, reg_data%n_regions if (i_flv /= reg_data%regions(alr)%uborn_index) cycle em = reg_data%regions(alr)%emitter if (em == 0) cycle if (evaluated(i_flv, em)) cycle !!! Collinear terms only for massless particles if (reg_data%regions(alr)%flst_uborn%massive(em)) cycle E_em = p_born(em)%p(0) if (allocated (reg_data%alr_contributors)) then i_contr = reg_data%alr_to_i_contributor (alr) k_res = get_resonance_momentum (p_born, reg_data%alr_contributors(i_contr)%c) E_tot2 = k_res%p(0)**2 L_to_resonance = inverse (boost (k_res, k_res**1)) xi_max = two * space_part_norm (L_to_resonance * p_born(em)) / k_res%p(0) log_xi_max = log (xi_max) else E_tot2 = sqrts**2 xi_max = two * E_em / sqrts log_xi_max = log (xi_max) end if - ! TODO sbrass evaluate xi-cut formalism for resonance-aware FKS - ! also: check rescaling with xi_max! - !associate (xi_cut => xi_max * virt%settings%fks_template%xi_cut, delta_zero => virt%settings%fks_template%delta_zero) associate (xi_cut => virt%settings%fks_template%xi_cut, delta_zero => virt%settings%fks_template%delta_zero) if (virt%settings%virtual_resonance_aware_collinear) then if (debug_active (D_VIRTUAL)) & call msg_debug (D_VIRTUAL, "Using resonance-aware collinear subtraction") s1 = virt%gamma_p(em, i_flv) s2 = two * (log (sqrts / (two * E_em)) + log_xi_max) * & (log (sqrts / (two * E_em)) + log_xi_max + log (virt%es_scale2 / sqrts**2)) & * virt%c_flv(em, i_flv) s3 = two * log_xi_max * & (log_xi_max - log (virt%es_scale2 / E_tot2)) * virt%c_flv(em, i_flv) s4 = (log (virt%es_scale2 / E_tot2) - two * log_xi_max) * virt%gamma_0(em, i_flv) QB(i_flv) = QB(i_flv) + (s1 + s2 + s3 + s4) * virt%sqme_born(i_flv) else if (debug_active (D_VIRTUAL)) & call msg_debug (D_VIRTUAL, "Using old-fashioned collinear subtraction") s1 = virt%gamma_p(em, i_flv) s2 = log (delta_zero * sqrts**2 / (two * virt%es_scale2)) * virt%gamma_0(em,i_flv) s3 = log (delta_zero * sqrts**2 / (two * virt%es_scale2)) * two * virt%c_flv(em,i_flv) * & log (two * E_em / (xi_cut * sqrts)) ! s4 = two * virt%c_flv(em,i_flv) * (log (two * E_em / sqrts)**2 - log (xi_cut)**2) s4 = two * virt%c_flv(em,i_flv) * & ! a**2 - b**2 = (a - b) * (a + b), for better numerical performance (log (two * E_em / sqrts) + log (xi_cut)) * (log (two * E_em / sqrts) - log (xi_cut)) s5 = two * virt%gamma_0(em,i_flv) * log (two * E_em / sqrts) QB(i_flv) = QB(i_flv) + (s1 - s2 + s3 + s4 - s5) * virt%sqme_born(i_flv) end if end associate evaluated(i_flv, em) = .true. end do end subroutine virtual_compute_collinear_contribution @ %def virtual_compute_collinear_contribution @ For the massless-massive case and $i = j$ we get the massive self-eikonal of (A.10) in arXiv:0908.4272, given as \begin{equation} \mathcal{I}_{ii} = \log \frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{1}{\beta} \log \frac{1 + \beta}{1 - \beta}. \end{equation} <>= procedure :: compute_massive_self_eikonals => virtual_compute_massive_self_eikonals <>= subroutine virtual_compute_massive_self_eikonals (virt, i_flv, & p_born, s_over_Q2, reg_data, QB) class(virtual_t), intent(inout) :: virt integer, intent(in) :: i_flv type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in) :: s_over_Q2 type(region_data_t), intent(in) :: reg_data real(default), intent(inout), dimension(:) :: QB integer :: i logical :: massive do i = 1, virt%n_legs massive = reg_data%flv_born(i_flv)%massive(i) if (massive) then QB(i_flv) = QB(i_flv) - (virt%c_flv (i, i_flv) & * (log (s_over_Q2) - 0.5_default * I_m_eps (p_born(i)))) & * virt%sqme_born (i_flv) end if end do end subroutine virtual_compute_massive_self_eikonals @ %def virtual_compute_massive_self_eikonals @ The following code implements the $\mathcal{I}_{ij}$-function. The complete formulas can be found in arXiv:0908.4272 (A.1-A.17). The implementation may differ in the detail from the formulas presented in the above paper. The parameter $\xi_{\text{cut}}$ is unphysically and cancels with appropriate factors in the real subtraction. We keep the additional parameter for debug usage. The implemented formulas are then defined as follows: \begin{itemize} \item[massless-massless case] $p^2 = 0, k^2 = 0,$ \begin{equation} \begin{split} \mathcal{I}_{ij} &= \frac{1}{2}\log^2\frac{\xi^2_{\text{cut}}s}{Q^2} + \log\frac{\xi^2_{\text{cut}}s}{Q^2}\log\frac{k_ik_j}{2E_iE_j} - \rm{Li}_2\left(\frac{k_ik_j}{2E_iE_j}\right) \\ &+ \frac{1}{2}\log^2\frac{k_ik_j}{2E_iE_j} - \log\left(1-\frac{k_ik_j}{2E_iE_j}\right) \log\frac{k_ik_j}{2E_iE_j}. \end{split} \label{I_00} \end{equation} \item[massive-massive case] $p^2 \neq 0, k^2 \neq 0,$ \begin{equation} \mathcal{I}_{ij} = \frac{1}{2}I_0(k_i, k_j)\log\frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{1}{2}I_\epsilon(k_i,k_j) \label{I_mm} \end{equation} with \begin{equation} I_0(k_i, k_j) = \frac{1}{\beta}\log\frac{1+\beta}{1-\beta}, \qquad \beta = \sqrt{1-\frac{k_i^2k_j^2}{(k_i \cdot k_j)^2}} \end{equation} and a rather involved expression for $I_\epsilon$: \begin{align} \allowdisplaybreaks I_\epsilon(k_i, k_j) &= \left(K(z_j)-K(z_i)\right) \frac{1-\vec{\beta_i}\cdot\vec{\beta_j}}{\sqrt{a(1-b)}}, \\ \vec{\beta_i} &= \frac{\vec{k}_i}{k_i^0}, \\ a &= \beta_i^2 + \beta_j^2 - 2\vec{\beta}_i \cdot \vec{\beta}_j, \\ x_i &= \frac{\beta_i^2 -\vec{\beta}_i \cdot \vec{\beta}_j}{a}, \\ x_j &= \frac{\beta_j^2 -\vec{\beta}_i \cdot \vec{\beta}_j}{a} = 1-x_j, \\ b &= \frac{\beta_i^2\beta_j^2 - (\vec{\beta}_i\cdot\vec{\beta}_j)^2}{a}, \\ c &= \sqrt{\frac{b}{4a}}, \\ z_+ &= \frac{1+\sqrt{1-b}}{\sqrt{b}}, \\ z_- &= \frac{1-\sqrt{1-b}}{\sqrt{b}}, \\ z_i &= \frac{\sqrt{x_i^2 + 4c^2} - x_i}{2c}, \\ z_j &= \frac{\sqrt{x_j^2 + 4c^2} + x_j}{2c}, \\ K(z) = &-\frac{1}{2}\log^2\frac{(z-z_-)(z_+-z)}{(z_++z)(z_-+z)} - 2Li_2\left(\frac{2z_-(z_+-z)}{(z_+-z_-)(z_-+z)}\right) \\ &-2Li_2\left(-\frac{2z_+(z_-+z)}{(z_+-z_-)(z_+-z)}\right) \end{align} \item[massless-massive case] $p^2 = 0, k^2 \neq 0,$ \begin{equation} \mathcal{I}_{ij} = \frac{1}{2}\left[\log^2\frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{\pi^2}{6}\right] -\frac{1}{2}I_0(k_i,k_j)\log\frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{1}{2}I_\epsilon(k_i,k_j) \label{I_0m} \end{equation} with \begin{align} I_0(p,k) &= \log\frac{(\hat{p}\cdot\hat{k})^2}{\hat{k}^2}, \\ I_\varepsilon(p,k) &= -2\left[\frac{1}{4}\log^2\frac{1-\beta}{1+\beta} + \log\frac{\hat{p}\cdot\hat{k}}{1+\beta}\log\frac{\hat{p}\cdot\hat{k}}{1-\beta} + \rm{Li}_2\left(1-\frac{\hat{p}\cdot\hat{k}}{1+\beta}\right) + \rm{Li}_2\left(1-\frac{\hat{p}\cdot\hat{k}}{1-\beta}\right)\right], \end{align} using \begin{align} \hat{p} = \frac{p}{p^0}, \quad \hat{k} = \frac{k}{k^0}, \quad \beta = \frac{|\vec{k}|}{k_0}, \\ \rm{Li}_2(1 - x) + \rm{Li}_2(1 - x^{-1}) = -\frac{1}{2} \log^2 x. \end{align} \end{itemize} <>= function compute_eikonal_factor (p_born, massive, i, j, s_o_Q2) result (I_ij) real(default) :: I_ij type(vector4_t), intent(in), dimension(:) :: p_born logical, dimension(:), intent(in) :: massive integer, intent(in) :: i, j real(default), intent(in) :: s_o_Q2 if (massive(i) .and. massive(j)) then I_ij = compute_Imm (p_born(i), p_born(j), s_o_Q2) else if (.not. massive(i) .and. massive(j)) then I_ij = compute_I0m (p_born(i), p_born(j), s_o_Q2) else if (massive(i) .and. .not. massive(j)) then I_ij = compute_I0m (p_born(j), p_born(i), s_o_Q2) else I_ij = compute_I00 (p_born(i), p_born(j), s_o_Q2) end if end function compute_eikonal_factor function compute_I00 (pi, pj, s_o_Q2) result (I) type(vector4_t), intent(in) :: pi, pj real(default), intent(in) :: s_o_Q2 real(default) :: I real(default) :: Ei, Ej real(default) :: pij, Eij real(default) :: s1, s2, s3, s4, s5 real(default) :: arglog real(default), parameter :: tiny_value = epsilon(1.0) s1 = 0; s2 = 0; s3 = 0; s4 = 0; s5 = 0 Ei = pi%p(0); Ej = pj%p(0) pij = pi * pj; Eij = Ei * Ej s1 = 0.5_default * log(s_o_Q2)**2 s2 = log(s_o_Q2) * log(pij / (two * Eij)) s3 = Li2 (pij / (two * Eij)) s4 = 0.5_default * log (pij / (two * Eij))**2 arglog = one - pij / (two * Eij) if (arglog > tiny_value) then s5 = log(arglog) * log(pij / (two * Eij)) else s5 = zero end if I = s1 + s2 - s3 + s4 - s5 end function compute_I00 function compute_I0m (ki, kj, s_o_Q2) result (I) type(vector4_t), intent(in) :: ki, kj real(default), intent(in) :: s_o_Q2 real(default) :: I real(default) :: logsomu real(default) :: s1, s2, s3 s1 = 0; s2 = 0; s3 = 0 logsomu = log(s_o_Q2) s1 = 0.5 * (0.5 * logsomu**2 - pi**2 / 6) s2 = 0.5 * I_0m_0 (ki, kj) * logsomu s3 = 0.5 * I_0m_eps (ki, kj) I = s1 + s2 - s3 end function compute_I0m function compute_Imm (pi, pj, s_o_Q2) result (I) type(vector4_t), intent(in) :: pi, pj real(default), intent(in) :: s_o_Q2 real(default) :: I real(default) :: s1, s2 s1 = 0.5 * log(s_o_Q2) * I_mm_0(pi, pj) s2 = 0.5 * I_mm_eps(pi, pj) I = s1 - s2 end function compute_Imm function I_m_eps (p) result (I) type(vector4_t), intent(in) :: p real(default) :: I real(default) :: beta beta = space_part_norm (p)/p%p(0) if (beta < tiny_07) then I = four * (one + beta**2/3 + beta**4/5 + beta**6/7) else I = two * log((one + beta) / (one - beta)) / beta end if end function I_m_eps function I_0m_eps (p, k) result (I) type(vector4_t), intent(in) :: p, k real(default) :: I type(vector4_t) :: pp, kp real(default) :: beta pp = p / p%p(0); kp = k / k%p(0) beta = sqrt (one - kp*kp) I = -2*(log((one - beta) / (one + beta))**2/4 + log((pp*kp) / (one + beta))*log((pp*kp) / (one - beta)) & + Li2(one - (pp*kp) / (one + beta)) + Li2(one - (pp*kp) / (one - beta))) end function I_0m_eps function I_0m_0 (p, k) result (I) type(vector4_t), intent(in) :: p, k real(default) :: I type(vector4_t) :: pp, kp pp = p / p%p(0); kp = k / k%p(0) I = log((pp*kp)**2 / kp**2) end function I_0m_0 function I_mm_eps (p1, p2) result (I) type(vector4_t), intent(in) :: p1, p2 real(default) :: I type(vector3_t) :: beta1, beta2 real(default) :: a, b, b2 real(default) :: zp, zm, z1, z2, x1, x2 real(default) :: zmb, z1b real(default) :: K1, K2 beta1 = space_part (p1) / energy(p1) beta2 = space_part (p2) / energy(p2) a = beta1**2 + beta2**2 - 2 * beta1 * beta2 b = beta1**2 * beta2**2 - (beta1 * beta2)**2 if (beta1**1 > beta2**1) call switch_beta (beta1, beta2) if (beta1 == vector3_null) then b2 = beta2**1 I = (-0.5 * log ((one - b2) / (one + b2))**2 - two * Li2 (-two * b2 / (one - b2))) & * one / sqrt (a - b) return end if x1 = beta1**2 - beta1 * beta2 x2 = beta2**2 - beta1 * beta2 zp = sqrt (a) + sqrt (a - b) zm = sqrt (a) - sqrt (a - b) zmb = one / zp z1 = sqrt (x1**2 + b) - x1 z2 = sqrt (x2**2 + b) + x2 z1b = one / (sqrt (x1**2 + b) + x1) K1 = - 0.5 * log (((z1b - zmb) * (zp - z1)) / ((zp + z1) * (z1b + zmb)))**2 & - two * Li2 ((two * zmb * (zp - z1)) / ((zp - zm) * (zmb + z1b))) & - two * Li2 ((-two * zp * (zm + z1)) / ((zp - zm) * (zp - z1))) K2 = - 0.5 * log ((( z2 - zm) * (zp - z2)) / ((zp + z2) * (z2 + zm)))**2 & - two * Li2 ((two * zm * (zp - z2)) / ((zp - zm) * (zm + z2))) & - two * Li2 ((-two * zp * (zm + z2)) / ((zp - zm) * (zp - z2))) I = (K2 - K1) * (one - beta1 * beta2) / sqrt (a - b) contains subroutine switch_beta (beta1, beta2) type(vector3_t), intent(inout) :: beta1, beta2 type(vector3_t) :: beta_tmp beta_tmp = beta1 beta1 = beta2 beta2 = beta_tmp end subroutine switch_beta end function I_mm_eps function I_mm_0 (k1, k2) result (I) type(vector4_t), intent(in) :: k1, k2 real(default) :: I real(default) :: beta beta = sqrt (one - k1**2 * k2**2 / (k1 * k2)**2) I = log ((one + beta) / (one - beta)) / beta end function I_mm_0 @ %def I_mm_0 @ <>= procedure :: final => virtual_final <>= subroutine virtual_final (virtual) class(virtual_t), intent(inout) :: virtual if (allocated (virtual%gamma_0)) deallocate (virtual%gamma_0) if (allocated (virtual%gamma_p)) deallocate (virtual%gamma_p) if (allocated (virtual%c_flv)) deallocate (virtual%c_flv) if (allocated (virtual%n_is_neutrinos)) deallocate (virtual%n_is_neutrinos) end subroutine virtual_final @ %def virtual_final @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Real Subtraction} <<[[real_subtraction.f90]]>>= <> module real_subtraction <> <> use io_units use format_defs, only: FMT_15 use string_utils use constants use numeric_utils use diagnostics use pdg_arrays use models use physics_defs use sm_physics use lorentz use flavors use phs_fks, only: real_kinematics_t, isr_kinematics_t use phs_fks, only: I_PLUS, I_MINUS use phs_fks, only: SQRTS_VAR, SQRTS_FIXED use phs_fks, only: phs_point_set_t use ttv_formfactors, only: m1s_to_mpole use fks_regions use nlo_data <> <> <> <> <> contains <> end module real_subtraction @ %def real_subtraction @ \subsubsection{Soft subtraction terms} <>= integer, parameter, public :: INTEGRATION = 0 integer, parameter, public :: FIXED_ORDER_EVENTS = 1 integer, parameter, public :: POWHEG = 2 @ %def real subtraction parameters @ <>= public :: this_purpose <>= function this_purpose (purpose) type(string_t) :: this_purpose integer, intent(in) :: purpose select case (purpose) case (INTEGRATION) this_purpose = var_str ("Integration") case (FIXED_ORDER_EVENTS) this_purpose = var_str ("Fixed order NLO events") case (POWHEG) this_purpose = var_str ("Powheg events") case default this_purpose = var_str ("Undefined!") end select end function this_purpose @ %def this_purpose @ In the soft limit, the real matrix element behaves as \begin{equation*} \mathcal{R}_{\rm{soft}} = 4\pi\alpha_s \left[\sum_{i \neq j} \mathcal{B}_{ij} \frac{k_i \cdot k_j}{(k_i \cdot k)(k_j \cdot k)} - \mathcal{B} \sum_{i} \frac{k_i^2}{(k_i \cdot k)^2}C_i\right], \end{equation*} where $k$ denotes the momentum of the emitted parton. The quantity $\mathcal{B}_{ij}$ is called the color-correlated Born matrix element defined as \begin{equation*} \mathcal{B}_{ij} = \frac{1}{2s} \sum_{\stackrel{colors}{spins}} \mathcal{M}_{\{c_k\}}\left(\mathcal{M}^\dagger_{\{c_k\}}\right)_{\stackrel{c_i \rightarrow c_i'}{c_j \rightarrow c_j'}} T^a_{c_i,c_i'} T^a_{c_j,c_j'}. \end{equation*} <>= type :: soft_subtraction_t type(region_data_t), pointer :: reg_data => null () real(default), dimension(:,:), allocatable :: momentum_matrix logical :: use_resonance_mappings = .false. type(vector4_t) :: p_soft = vector4_null logical :: use_internal_color_correlations = .true. logical :: use_internal_spin_correlations = .false. logical :: xi2_expanded = .true. integer :: factorization_mode = NO_FACTORIZATION contains <> end type soft_subtraction_t @ %def soft_subtraction_t @ <>= procedure :: init => soft_subtraction_init <>= subroutine soft_subtraction_init (sub_soft, reg_data) class(soft_subtraction_t), intent(inout) :: sub_soft type(region_data_t), intent(in), target :: reg_data sub_soft%reg_data => reg_data allocate (sub_soft%momentum_matrix (reg_data%n_legs_born, & reg_data%n_legs_born)) end subroutine soft_subtraction_init @ %def soft_subtraction_init @ <>= procedure :: requires_boost => soft_subtraction_requires_boost <>= function soft_subtraction_requires_boost (sub_soft, sqrts) result (requires_boost) logical :: requires_boost class(soft_subtraction_t), intent(in) :: sub_soft real(default), intent(in) :: sqrts real(default) :: mtop logical :: above_threshold if (sub_soft%factorization_mode == FACTORIZATION_THRESHOLD) then mtop = m1s_to_mpole (sqrts) above_threshold = sqrts**2 - four * mtop**2 > zero else above_threshold = .false. end if requires_boost = sub_soft%use_resonance_mappings .or. above_threshold end function soft_subtraction_requires_boost @ %def soft_subtraction_requires_boost @ The treatment of the momentum $k$ follows the discussion about the soft limit of the partition functions (ref????). The parton momentum is pulled out, $k = E \hat{k}$. In fact, we will substitute $\hat{k}$ for $k$ throughout the code, because the energy will factor out of the equation when the soft $\mathcal{S}$-function is multiplied. The soft momentum is a unit vector, because $k^2 = \left(k^0\right)^2 - \left(k^0\right)^2\hat{\vec{k}}^2 = 0$. The soft momentum is constructed by first creating a unit vector parallel to the emitter's Born momentum. This unit vector is then rotated about the corresponding angles $y$ and $\phi$. <>= procedure :: create_softvec_fsr => soft_subtraction_create_softvec_fsr <>= subroutine soft_subtraction_create_softvec_fsr & (sub_soft, p_born, y, phi, emitter, xi_ref_momentum) class(soft_subtraction_t), intent(inout) :: sub_soft type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in) :: y, phi integer, intent(in) :: emitter type(vector4_t), intent(in) :: xi_ref_momentum type(vector3_t) :: dir type(vector4_t) :: p_em type(lorentz_transformation_t) :: rot type(lorentz_transformation_t) :: boost_to_rest_frame logical :: requires_boost associate (p_soft => sub_soft%p_soft) p_soft%p(0) = one requires_boost = sub_soft%requires_boost (two * p_born(1)%p(0)) if (requires_boost) then boost_to_rest_frame = inverse (boost (xi_ref_momentum, xi_ref_momentum**1)) p_em = boost_to_rest_frame * p_born(emitter) else p_em = p_born(emitter) end if p_soft%p(1:3) = p_em%p(1:3) / space_part_norm (p_em) dir = create_orthogonal (space_part (p_em)) rot = rotation (y, sqrt(one - y**2), dir) p_soft = rot * p_soft if (.not. vanishes (phi)) then dir = space_part (p_em) / space_part_norm (p_em) rot = rotation (cos(phi), sin(phi), dir) p_soft = rot * p_soft end if if (requires_boost) p_soft = inverse (boost_to_rest_frame) * p_soft end associate end subroutine soft_subtraction_create_softvec_fsr @ %def soft_subtraction_create_softvec_fsr @ For initial-state emissions, the soft vector is just a unit vector with the same direction as the radiated particle. <>= procedure :: create_softvec_isr => soft_subtraction_create_softvec_isr <>= subroutine soft_subtraction_create_softvec_isr (sub_soft, y, phi) class(soft_subtraction_t), intent(inout) :: sub_soft real(default), intent(in) :: y, phi real(default) :: sin_theta sin_theta = sqrt(one - y**2) associate (p => sub_soft%p_soft%p) p(0) = one p(1) = sin_theta * sin(phi) p(2) = sin_theta * cos(phi) p(3) = y end associate end subroutine soft_subtraction_create_softvec_isr @ %def soft_subtraction_create_softvec_isr @ The soft vector for the real mismatch is basically the same as for usual FSR, except for the scaling with the total gluon energy. Moreover, the resulting vector is rotated into the frame where the 3-axis points along the direction of the emitter. This is necessary because in the collinear limit, the approximation \begin{equation*} k_i = \frac{k_i^0}{\bar{k}_j^0} \bar{k}_j = \frac{\xi\sqrt{s}}{2\bar{k}_j^0}\bar{k}_j \end{equation*} is used. The collinear limit is not included in the soft mismatch yet, but we keep the rotation for future usage here already (the performance loss is negligible). <>= procedure :: create_softvec_mismatch => & soft_subtraction_create_softvec_mismatch <>= subroutine soft_subtraction_create_softvec_mismatch (sub_soft, E, y, phi, p_em) class(soft_subtraction_t), intent(inout) :: sub_soft real(default), intent(in) :: E, phi, y type(vector4_t), intent(in) :: p_em real(default) :: sin_theta type(lorentz_transformation_t) :: rot_em_off_3_axis sin_theta = sqrt (one - y**2) associate (p => sub_soft%p_soft%p) p(0) = E p(1) = E * sin_theta * sin(phi) p(2) = E * sin_theta * cos(phi) p(3) = E * y end associate rot_em_off_3_axis = rotation_to_2nd (3, space_part (p_em)) sub_soft%p_soft = rot_em_off_3_axis * sub_soft%p_soft end subroutine soft_subtraction_create_softvec_mismatch @ %def soft_subtraction_create_softvec_mismatch @ Computation of the soft limit of $R_\alpha$. Note that what we are actually integrating (in the case of final-state radiation) is the quantity $f(0,y) / \xi$, where \begin{equation*} f(\xi,y) = \frac{J(\xi,y,\phi)}{\xi} \xi^2 R_\alpha. \end{equation*} $J/\xi$ is computed by the phase space generator. The additional factor of $\xi^{-1}$ is supplied in the [[evaluate_region_fsr]]-routine. Thus, we are left with a factor of $\xi^2$. A look on the expression for the soft limit of $R_\alpha$ below reveals that we are factoring out the gluon energy $E_i$ in the denominator. Therefore, we have a factor $\xi^2 / E_i^2 = q^2 / 4$.\\ Note that the same routine is used also for the computation of the soft mismatch. There, the gluon energy is not factored out from the soft vector, so that we are left with the $\xi^2$-factor, which will eventually be cancelled out again. So, we just multiply with 1. Both cases are distinguished by the flag [[xi2_expanded]]. <>= procedure :: compute => soft_subtraction_compute <>= function soft_subtraction_compute (sub_soft, p_born, & born_ij, y, q2, alpha_coupling, alr, emitter, i_res) result (sqme) real(default) :: sqme class(soft_subtraction_t), intent(inout) :: sub_soft type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in), dimension(:,:) :: born_ij real(default), intent(in) :: y real(default), intent(in) :: q2, alpha_coupling integer, intent(in) :: alr, emitter, i_res real(default) :: s_alpha_soft real(default) :: kb real(default) :: xi2_factor if (.not. vector_set_is_cms (p_born, sub_soft%reg_data%n_in)) then call vector4_write_set (p_born, show_mass = .true., & check_conservation = .true.) call msg_fatal ("Soft subtraction: phase space point must be in CMS") end if if (debug2_active (D_SUBTRACTION)) then associate (nlo_corr_type => sub_soft%reg_data%regions(alr)%nlo_correction_type) if (nlo_corr_type == "QCD") then print *, 'Compute soft subtraction using alpha_s = ', alpha_coupling else if (nlo_corr_type == "QED") then print *, 'Compute soft subtraction using alpha_qed = ', alpha_coupling end if end associate end if s_alpha_soft = sub_soft%reg_data%get_svalue_soft (p_born, & sub_soft%p_soft, alr, emitter, i_res) if (s_alpha_soft > one + tiny_07) call msg_fatal ("s_alpha_soft > 1!") if (debug2_active (D_SUBTRACTION)) & call msg_print_color ('s_alpha_soft', s_alpha_soft, COL_YELLOW) select case (sub_soft%factorization_mode) case (NO_FACTORIZATION) kb = sub_soft%evaluate_factorization_default (p_born, born_ij) case (FACTORIZATION_THRESHOLD) kb = sub_soft%evaluate_factorization_threshold (thr_leg(emitter), p_born, born_ij) end select call msg_debug2 (D_SUBTRACTION, 'KB', kb) sqme = four * pi * alpha_coupling * s_alpha_soft * kb if (sub_soft%xi2_expanded) then xi2_factor = four / q2 else xi2_factor = one end if if (emitter <= sub_soft%reg_data%n_in) then sqme = xi2_factor * (one - y**2) * sqme else sqme = xi2_factor * (one - y) * sqme end if end function soft_subtraction_compute @ %def soft_subtraction_compute @ We loop over all external legs and do not take care to leave out non-colored ones because [[born_ij]] is constructed in such a way that it is only non-zero for colored entries. <>= procedure :: evaluate_factorization_default => & soft_subtraction_evaluate_factorization_default <>= function soft_subtraction_evaluate_factorization_default & (sub_soft, p, born_ij) result (kb) real(default) :: kb class(soft_subtraction_t), intent(inout) :: sub_soft type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in), dimension(:,:) :: born_ij integer :: i, j kb = zero call sub_soft%compute_momentum_matrix (p) do i = 1, size (p) do j = 1, size (p) kb = kb + sub_soft%momentum_matrix (i, j) * born_ij (i, j) end do end do end function soft_subtraction_evaluate_factorization_default @ %def soft_subtraction_evaluate_factorization_default @ We have to multiply this with $\xi^2(1-y)$. Further, when applying the soft $\mathcal{S}$-function, the energy of the radiated particle is factored out. Thus we have $\xi^2/E_{em}^2(1-y) = 4/q_0^2(1-y)$. Computes the quantity $\mathcal{K}_{ij} = \frac{k_i \cdot k_j}{(k_i\cdot k)(k_j\cdot k)}$. <>= procedure :: compute_momentum_matrix => & soft_subtraction_compute_momentum_matrix <>= subroutine soft_subtraction_compute_momentum_matrix & (sub_soft, p_born) class(soft_subtraction_t), intent(inout) :: sub_soft type(vector4_t), intent(in), dimension(:) :: p_born real(default) :: num, deno1, deno2 integer :: i, j do i = 1, sub_soft%reg_data%n_legs_born do j = 1, sub_soft%reg_data%n_legs_born if (i <= j) then num = p_born(i) * p_born(j) deno1 = p_born(i) * sub_soft%p_soft deno2 = p_born(j) * sub_soft%p_soft sub_soft%momentum_matrix(i, j) = num / (deno1 * deno2) else !!! momentum matrix is symmetric. sub_soft%momentum_matrix(i, j) = sub_soft%momentum_matrix(j, i) end if end do end do end subroutine soft_subtraction_compute_momentum_matrix @ %def soft_subtraction_compute_momentum_matrx @ <>= procedure :: evaluate_factorization_threshold => & soft_subtraction_evaluate_factorization_threshold <>= function soft_subtraction_evaluate_factorization_threshold & (sub_soft, leg, p_born, born_ij) result (kb) real(default) :: kb class(soft_subtraction_t), intent(inout) :: sub_soft integer, intent(in) :: leg type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in), dimension(:,:) :: born_ij type(vector4_t), dimension(4) :: p p = get_threshold_momenta (p_born) kb = evaluate_leg_pair (ASSOCIATED_LEG_PAIR (leg)) if (debug2_active (D_SUBTRACTION)) call show_debug () contains function evaluate_leg_pair (i_start) result (kbb) real(default) :: kbb integer, intent(in) :: i_start integer :: i1, i2 real(default) :: numerator, deno1, deno2 kbb = zero do i1 = i_start, i_start + 1 do i2 = i_start, i_start + 1 numerator = p(i1) * p(i2) deno1 = p(i1) * sub_soft%p_soft deno2 = p(i2) * sub_soft%p_soft kbb = kbb + numerator * born_ij (i1, i2) / deno1 / deno2 end do end do if (debug2_active (D_SUBTRACTION)) then do i1 = i_start, i_start + 1 do i2 = i_start, i_start + 1 call msg_print_color('i1', i1, COL_PEACH) call msg_print_color('i2', i2, COL_PEACH) call msg_print_color('born_ij (i1,i2)', born_ij (i1,i2), COL_PINK) print *, 'Top momentum: ', p(1)%p end do end do end if end function evaluate_leg_pair subroutine show_debug () integer :: i call msg_print_color ('soft_subtraction_evaluate_factorization_threshold', COL_GREEN) do i = 1, 4 print *, 'sqrt(p(i)**2) = ', sqrt(p(i)**2) end do end subroutine show_debug end function soft_subtraction_evaluate_factorization_threshold @ %def soft_subtraction_evaluate_factorization_threshold @ <>= procedure :: i_xi_ref => soft_subtraction_i_xi_ref <>= function soft_subtraction_i_xi_ref (sub_soft, alr, i_phs) result (i_xi_ref) integer :: i_xi_ref class(soft_subtraction_t), intent(in) :: sub_soft integer, intent(in) :: alr, i_phs if (sub_soft%use_resonance_mappings) then i_xi_ref = sub_soft%reg_data%alr_to_i_contributor (alr) else if (sub_soft%factorization_mode == FACTORIZATION_THRESHOLD) then i_xi_ref = i_phs else i_xi_ref = 1 end if end function soft_subtraction_i_xi_ref @ %def soft_subtraction_i_xi_ref @ <>= procedure :: final => soft_subtraction_final <>= subroutine soft_subtraction_final (sub_soft) class(soft_subtraction_t), intent(inout) :: sub_soft if (associated (sub_soft%reg_data)) nullify (sub_soft%reg_data) if (allocated (sub_soft%momentum_matrix)) deallocate (sub_soft%momentum_matrix) end subroutine soft_subtraction_final @ %def soft_subtraction_final @ \subsection{Soft mismatch} <>= public :: soft_mismatch_t <>= type :: soft_mismatch_t type(region_data_t), pointer :: reg_data => null () real(default), dimension(:), allocatable :: sqme_born real(default), dimension(:,:,:), allocatable :: sqme_born_color_c real(default), dimension(:,:,:), allocatable :: sqme_born_charge_c type(real_kinematics_t), pointer :: real_kinematics => null () type(soft_subtraction_t) :: sub_soft contains <> end type soft_mismatch_t @ %def soft_mismatch_t @ <>= procedure :: init => soft_mismatch_init <>= subroutine soft_mismatch_init (soft_mismatch, reg_data, & real_kinematics, factorization_mode) class(soft_mismatch_t), intent(inout) :: soft_mismatch type(region_data_t), intent(in), target :: reg_data type(real_kinematics_t), intent(in), target :: real_kinematics integer, intent(in) :: factorization_mode soft_mismatch%reg_data => reg_data allocate (soft_mismatch%sqme_born (reg_data%n_flv_born)) allocate (soft_mismatch%sqme_born_color_c (reg_data%n_legs_born, & reg_data%n_legs_born, reg_data%n_flv_born)) allocate (soft_mismatch%sqme_born_charge_c (reg_data%n_legs_born, & reg_data%n_legs_born, reg_data%n_flv_born)) call soft_mismatch%sub_soft%init (reg_data) soft_mismatch%sub_soft%xi2_expanded = .false. soft_mismatch%real_kinematics => real_kinematics soft_mismatch%sub_soft%factorization_mode = factorization_mode end subroutine soft_mismatch_init @ %def soft_mismatch_init @ Main routine to compute the soft mismatch. Loops over all singular regions. There, it first creates the soft vector, then the necessary soft real matrix element. These inputs are then used to get the numerical value of the soft mismatch. <>= procedure :: evaluate => soft_mismatch_evaluate <>= function soft_mismatch_evaluate (soft_mismatch, alpha_s) result (sqme_mismatch) real(default) :: sqme_mismatch class(soft_mismatch_t), intent(inout) :: soft_mismatch real(default), intent(in) :: alpha_s integer :: alr, i_born, emitter, i_res, i_phs, i_con real(default) :: xi, y, q2, s real(default) :: E_gluon type(vector4_t) :: p_em real(default) :: sqme_alr, sqme_soft type(vector4_t), dimension(:), allocatable :: p_born sqme_mismatch = zero associate (real_kinematics => soft_mismatch%real_kinematics) xi = real_kinematics%xi_mismatch y = real_kinematics%y_mismatch s = real_kinematics%cms_energy2 E_gluon = sqrt (s) * xi / two if (debug_active (D_MISMATCH)) then print *, 'Evaluating soft mismatch: ' print *, 'Phase space: ' call vector4_write_set (real_kinematics%p_born_cms%get_momenta(1), & show_mass = .true.) print *, 'xi: ', xi, 'y: ', y, 's: ', s, 'E_gluon: ', E_gluon end if allocate (p_born (soft_mismatch%reg_data%n_legs_born)) do alr = 1, soft_mismatch%reg_data%n_regions i_phs = real_kinematics%alr_to_i_phs (alr) if (soft_mismatch%reg_data%has_pseudo_isr ()) then i_con = 1 p_born = soft_mismatch%real_kinematics%p_born_onshell%get_momenta(1) else i_con = soft_mismatch%reg_data%alr_to_i_contributor (alr) p_born = soft_mismatch%real_kinematics%p_born_cms%get_momenta(1) end if q2 = real_kinematics%xi_ref_momenta(i_con)**2 emitter = soft_mismatch%reg_data%regions(alr)%emitter p_em = p_born (emitter) i_res = soft_mismatch%reg_data%regions(alr)%i_res i_born = soft_mismatch%reg_data%regions(alr)%uborn_index call print_debug_alr () call soft_mismatch%sub_soft%create_softvec_mismatch & (E_gluon, y, real_kinematics%phi, p_em) if (debug_active (D_MISMATCH)) & print *, 'Created soft vector: ', soft_mismatch%sub_soft%p_soft%p select type (fks_mapping => soft_mismatch%reg_data%fks_mapping) type is (fks_mapping_resonances_t) call fks_mapping%set_resonance_momentum & (real_kinematics%xi_ref_momenta(i_con)) end select sqme_soft = soft_mismatch%sub_soft%compute & (p_born, soft_mismatch%sqme_born_color_c(:,:,i_born), y, & q2, alpha_s, alr, emitter, i_res) sqme_alr = soft_mismatch%compute (alr, xi, y, p_em, & real_kinematics%xi_ref_momenta(i_con), soft_mismatch%sub_soft%p_soft, & soft_mismatch%sqme_born(i_born), sqme_soft, & alpha_s, s) call msg_debug (D_MISMATCH, 'sqme_alr: ', sqme_alr) sqme_mismatch = sqme_mismatch + sqme_alr end do end associate contains subroutine print_debug_alr () if (debug_active (D_MISMATCH)) then print *, 'alr: ', alr print *, 'i_phs: ', i_phs, 'i_con: ', i_con, 'i_res: ', i_res print *, 'emitter: ', emitter, 'i_born: ', i_born print *, 'emitter momentum: ', p_em%p print *, 'resonance momentum: ', & soft_mismatch%real_kinematics%xi_ref_momenta(i_con)%p print *, 'q2: ', q2 end if end subroutine print_debug_alr end function soft_mismatch_evaluate @ %def soft_mismatch_evaluate @ Computes the soft mismatch in a given $\alpha_r$, \begin{align*} I_{s+,\alpha_r} &= \int d\Phi_B \int_0^\infty d\xi \int_{-1}^1 dy \int_0^{2\pi} d\phi \frac{s\xi}{(4\pi)^3} \\ &\times \left\lbrace\tilde{R}_{\alpha_r} \left(e^{-\frac{2k_\gamma \cdot k_{res}}{k_{res}}^2} - e^{-\xi}\right) - \frac{32 \pi \alpha_s C_{em}}{s\xi^2} B_{f_b(\alpha_r)} (1-y)^{-1} \left[e^{-\frac{2\bar{k}_{em} \cdot k_{res}}{k_{res}^2} \frac{k_\gamma^0}{k_{em}^0}} - e^{-\xi}\right]\right\rbrace. \end{align*} <>= procedure :: compute => soft_mismatch_compute <>= function soft_mismatch_compute (soft_mismatch, alr, xi, y, p_em, p_res, p_soft, & sqme_born, sqme_soft, alpha_s, s) result (sqme_mismatch) real(default) :: sqme_mismatch class(soft_mismatch_t), intent(in) :: soft_mismatch integer, intent(in) :: alr real(default), intent(in) :: xi, y type(vector4_t), intent(in) :: p_em, p_res, p_soft real(default), intent(in) :: sqme_born, sqme_soft real(default), intent(in) :: alpha_s, s real(default) :: q2, expo, sm1, sm2, jacobian q2 = p_res**2 expo = - two * p_soft * p_res / q2 !!! Divide by 1 - y to factor out the corresponding !!! factor in the soft matrix element sm1 = sqme_soft / (one - y) * ( exp(expo) - exp(- xi) ) call msg_debug2 (D_MISMATCH, 'sqme_soft in mismatch ', sqme_soft) sm2 = zero if (soft_mismatch%reg_data%regions(alr)%has_collinear_divergence ()) then expo = - two * p_em * p_res / q2 * & p_soft%p(0) / p_em%p(0) sm2 = 32 * pi * alpha_s * cf / (s * xi**2) * sqme_born * & ( exp(expo) - exp(- xi) ) / (one - y) end if jacobian = soft_mismatch%real_kinematics%jac_mismatch * s * xi / (8 * twopi3) sqme_mismatch = (sm1 - sm2) * jacobian end function soft_mismatch_compute @ %def soft_mismatch_compute @ <>= procedure :: final => soft_mismatch_final <>= subroutine soft_mismatch_final (soft_mismatch) class(soft_mismatch_t), intent(inout) :: soft_mismatch call soft_mismatch%sub_soft%final () if (associated (soft_mismatch%reg_data)) nullify (soft_mismatch%reg_data) if (allocated (soft_mismatch%sqme_born)) deallocate (soft_mismatch%sqme_born) if (allocated (soft_mismatch%sqme_born_color_c)) deallocate (soft_mismatch%sqme_born_color_c) if (allocated (soft_mismatch%sqme_born_charge_c)) deallocate (soft_mismatch%sqme_born_charge_c) if (associated (soft_mismatch%real_kinematics)) nullify (soft_mismatch%real_kinematics) end subroutine soft_mismatch_final @ %def soft_mismatch_final @ \subsection{Collinear and soft-collinear subtraction terms} This data type deals with the calculation of the collinear and soft-collinear contribution to the cross section. <>= public :: coll_subtraction_t <>= type :: coll_subtraction_t integer :: n_in, n_alr logical :: use_resonance_mappings = .false. real(default) :: CA = 0, CF = 0, TR = 0 contains <> end type coll_subtraction_t @ %def coll_subtraction_t @ <>= procedure :: init => coll_subtraction_init <>= subroutine coll_subtraction_init (coll_sub, n_alr, n_in) class(coll_subtraction_t), intent(inout) :: coll_sub integer, intent(in) :: n_alr, n_in coll_sub%n_in = n_in coll_sub%n_alr = n_alr end subroutine coll_subtraction_init @ %def coll_subtraction_init @ Set the corresponding algebra parameters of the underlying gauge group of the correction. <>= procedure :: set_parameters => coll_subtraction_set_parameters <>= subroutine coll_subtraction_set_parameters (coll_sub, CA, CF, TR) class(coll_subtraction_t), intent(inout) :: coll_sub real(default), intent(in) :: CA, CF, TR coll_sub%CA = CA coll_sub%CF = CF coll_sub%TR = TR end subroutine coll_subtraction_set_parameters @ %def coll_subtraction_set_parameters @ This subroutine computes the collinear limit of $g^\alpha(\xi,y)$ introduced in eq.~\ref{fks: sub: real}. Care is given to also enable the usage for the soft-collinear limit. This, we write all formulas in terms of soft-finite quantities. We have to compute \begin{equation*} \frac{J(\Phi_n,\xi,y,\phi)}{\xi} \left[(1-y)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]|_{y = 1}. \end{equation*} The Jacobian $j$ is proportional to $\xi$, due to the $d^3 k_{n+1} / k_{n+1}^0$ factor in the integration measure. It cancels the factor of $\xi$ in the denominator. The remaining part of the Jacobian is multiplied in [[evaluate_region_fsr]] and is not relevant here. Inserting the splitting functions exemplarily for $q \to qg$ yields \begin{equation*} g^\alpha = \frac{8\pi\alpha_s}{k_{\mathrm{em}}^2} C_F (1-y) \xi^2 \frac{1+(1-z)^2}{z} \mathcal{B}, \end{equation*} where we have chosen $z = E_\mathrm{rad} / \bar{E}_\mathrm{em}$ and $\bar{E}_\mathrm{em}$ denotes the emitter energy in the Born frame. The collinear final state imposes $\bar{k}_n = k_{n} + k_{k + 1}$ for the connection between $\Phi_n$- and $\Phi_{n+1}$-phasepace and we get $1 - z = E_\mathrm{em} / \bar{E}_\mathrm{em}$. The denominator can be rewritten by the constraint $\bar{k}_n^2 = (k_n + k_{n+1})^2 = 0$ to \begin{equation*} k_{\mathrm{em}}^2 = 2 E_\mathrm{rad} E_\mathrm{em} (1-y) \end{equation*} which cancels the $(1-y)$ factor in the numerator, thus showing that the whole expression is indeed collinear-finite. We can further transform \begin{equation*} E_\mathrm{rad} E_\mathrm{em} = z (1-z) \bar{E}_\mathrm{em}^2 \end{equation*} so that in total we have \begin{equation*} g^\alpha = \frac{4\pi\alpha_s}{1-z} \frac{1}{\bar{k}_{\text{em}}^2} C_F \left(\frac{\xi}{z}\right)^2 (1 + (1-z)^2) \mathcal{B} \end{equation*} Follow up calculations give us \begin{align*} g^{\alpha, g \rightarrow gg} & = \frac{4\pi\alpha_s}{1-z}\frac{1}{\bar{k}_{\text{em}}^2} C_{\mathrm{A}} \frac{\xi}{z} \left\lbrace 2 \left( \frac{z}{1 - z} \xi + \frac{1 - z}{\frac{z}{\xi}} \right) \mathcal{B} + 4\xi z(1 - z) \hat{k}_{\perp}^{\mu} \hat{k}_{\perp}^{\nu} \mathcal{B}_{\mu\nu} \right\rbrace, \\ g^{\alpha, g \rightarrow qq} & = \frac{4\pi\alpha_s}{1-z} \frac{1}{\bar{k}_{\text{em}}^2} T_{\mathrm{R}} \frac{\xi}{z} \left\lbrace \xi \mathcal{B} - 4\xi z(1 - z) \hat{k}_{\perp}^{\mu} \hat{k}_{\perp}^{\nu} \mathcal{B}_{\mu\nu} \right\rbrace. \end{align*} The ratio $z / \xi$ is finite in the soft limit \begin{equation*} \frac{z}{\xi} = \frac{q^0}{2\bar{E}_\mathrm{em}} \end{equation*} so that $\xi$ does not appear explicitly in the computation. The argumentation above is valid for $q \to qg$--splittings, but the general factorization is valid for general splittings, also for those involving spin correlations and QED splittings. Note that care has to be given to the definition of $z$. Further, we have factored out a factor of $z$ to include in the ratio $z/\xi$, which has to be taken into account in the implementation of the splitting functions. <>= procedure :: compute_fsr => coll_subtraction_compute_fsr <>= function coll_subtraction_compute_fsr & (coll_sub, emitter, flst, p_res, p_born, sqme_born, mom_times_sqme_spin_c, & xi, alpha_coupling, double_fsr) result (sqme) real(default) :: sqme class(coll_subtraction_t), intent(in) :: coll_sub integer, intent(in) :: emitter integer, dimension(:), intent(in) :: flst type(vector4_t), intent(in) :: p_res type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in) :: sqme_born, mom_times_sqme_spin_c real(default), intent(in) :: xi, alpha_coupling logical, intent(in) :: double_fsr real(default) :: q0, z, p0, z_o_xi, onemz integer :: nlegs, flv_em, flv_rad nlegs = size (flst) flv_rad = flst(nlegs); flv_em = flst(emitter) q0 = p_res**1 p0 = p_res * p_born(emitter) / q0 !!! Here, z corresponds to 1-z in the formulas of arXiv:1002.2581; !!! the integrand is symmetric under this variable change z_o_xi = q0 / (two * p0) z = xi * z_o_xi; onemz = one - z if (is_gluon (flv_em) .and. is_gluon (flv_rad)) then sqme = coll_sub%CA * ( two * ( z / onemz * xi + onemz / z_o_xi ) * sqme_born & + four * xi * z * onemz * mom_times_sqme_spin_c ) else if (is_fermion (flv_em) .and. is_fermion (flv_rad)) then sqme = coll_sub%TR * xi * (sqme_born - four * z * onemz * mom_times_sqme_spin_c) else if (is_fermion (flv_em) .and. is_massless_vector (flv_rad)) then sqme = sqme_born * coll_sub%CF * (one + onemz**2) / z_o_xi else sqme = zero end if sqme = sqme / (p0**2 * onemz * z_o_xi) sqme = sqme * four * pi * alpha_coupling if (double_fsr) sqme = sqme * onemz end function coll_subtraction_compute_fsr @ %def coll_subtraction_compute_fsr @ Like in the context of [[coll_subtraction_compute_fsr]] we compute the quantity \begin{equation*} \frac{J(\Phi_n,\xi,y,\phi)}{\xi} \left[(1-y)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]|_{y = 1}, \end{equation*} and, additionally the anti-collinear case with $y = +1$, which, however, is completely analogous. Again, the Jacobian is proportional to $\xi$, so we drop the $J / \xi$ factor. Note that it is important to take into account this missing factor of $\xi$ in the computation of the Jacobian during phase-space generation both for fixed-beam and structure ISR. We consider only a $q \to qg$ splitting arguing that other splittings are identical in terms of the factors which cancel. It is given by \begin{equation*} g^\alpha = \frac{8\pi\alpha_s}{-k_{\mathrm{em}}^2} C_F (1-y) \xi^2 \frac{1+z^2}{1-z} \mathcal{B}. \end{equation*} Note the negative sign of $k_\mathrm{em}^2$ to compensate the negative virtuality of the initial-state emitter. For ISR, $z$ is defined with respect to the emitter energy entering the hard interaction, i.e. \begin{equation*} z = \frac{E_\mathrm{beam} - E_\mathrm{rad}}{E_\mathrm{beam}} = 1 - \frac{E_\mathrm{rad}}{E_\mathrm{beam}}. \end{equation*} Because $E_\mathrm{rad} = E_\mathrm{beam} \cdot \xi$, it is $z = 1 - \xi$. The factor $k_\mathrm{em}^2$ in the denonimator is rewritten as \begin{equation*} k_\mathrm{em}^2 = \left(p_\mathrm{beam} - p_\mathrm{rad}\right)^2 = - 2 p_\mathrm{beam} \cdot p_\mathrm{rad} = - 2 E_\mathrm{beam} E_\mathrm{rad} (1-y) = -2 E_\mathrm{beam}^2 (1-z) (1-y). \end{equation*} This leads to the cancellation of the $(1-y)$ factors and one of the two factors of $xi$ in the numerator. Further rewriting to \begin{equation*} E_\mathrm{beam} E_\mathrm{rad} = E_\mathrm{beam}^2 (1-z) \end{equation*} cancels another factor of $\xi$. We thus end up with \begin{equation*} g^\alpha = \frac{4\pi\alpha_s}{E_\mathrm{beam}^2} C_F \left(1 + z^2\right)\mathcal{B}, \end{equation*} which is soft-finite. Now what about this boosting to the other beam? <>= procedure :: compute_isr => coll_subtraction_compute_isr <>= function coll_subtraction_compute_isr & (coll_sub, emitter, flst, p_born, sqme_born, mom_times_sqme_spin_c, & xi, alpha_coupling, isr_mode) result (sqme) real(default) :: sqme class(coll_subtraction_t), intent(in) :: coll_sub integer, intent(in) :: emitter integer, dimension(:), intent(in) :: flst type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in) :: sqme_born real(default), intent(in) :: mom_times_sqme_spin_c real(default), intent(in) :: xi, alpha_coupling integer, intent(in) :: isr_mode real(default) :: z, onemz, p02 integer :: nlegs, flv_em, flv_rad if (isr_mode == SQRTS_VAR .and. vector_set_is_cms (p_born, coll_sub%n_in)) then call vector4_write_set (p_born, show_mass = .true., & check_conservation = .true.) call msg_fatal ("Collinear subtraction, ISR: Phase space point & &must be in lab frame") end if nlegs = size (flst) flv_rad = flst(nlegs); flv_em = flst(emitter) !!! No need to pay attention to n_in = 1, because this case always has a !!! massive initial-state particle and thus no collinear divergence. p02 = p_born(1)%p(0) * p_born(2)%p(0) / two z = one - xi; onemz = xi if (is_massless_vector (flv_em) .and. is_massless_vector (flv_rad)) then sqme = coll_sub%CA * (two * (z + z * onemz**2) * sqme_born + four * onemz**2 & / z * mom_times_sqme_spin_c) else if (is_fermion (flv_em) .and. is_massless_vector (flv_rad)) then sqme = coll_sub%CF * (one + z**2) * sqme_born else if (is_fermion (flv_em) .and. is_fermion (flv_rad)) then sqme = coll_sub%CF * (z * onemz * sqme_born + four * onemz**2 / z * mom_times_sqme_spin_c) else if (is_massless_vector (flv_em) .and. is_fermion (flv_rad)) then sqme = coll_sub%TR * (z**2 + onemz**2) * onemz * sqme_born else sqme = zero end if if (isr_mode == SQRTS_VAR) then sqme = sqme / p02 * z else !!! We have no idea why this seems to work as there should be no factor !!! of z for the fixed-beam settings. This should definitely be understood in the !!! future! sqme = sqme / p02 / z end if sqme = sqme * four * pi * alpha_coupling end function coll_subtraction_compute_isr @ %def coll_subtraction_compute_isr @ <>= procedure :: final => coll_subtraction_final <>= subroutine coll_subtraction_final (sub_coll) class(coll_subtraction_t), intent(inout) :: sub_coll sub_coll%use_resonance_mappings = .false. end subroutine coll_subtraction_final @ %def coll_subtraction_final @ \subsection{Real Subtraction} We store a pointer to the a [[nlo_settings_t]] object which holds tuning parameters, e.g. cutoffs for the subtraction terms. <>= public :: real_subtraction_t <>= type :: real_subtraction_t type(nlo_settings_t), pointer :: settings => null () type(region_data_t), pointer :: reg_data => null () type(real_kinematics_t), pointer :: real_kinematics => null () type(isr_kinematics_t), pointer :: isr_kinematics => null () type(real_scales_t) :: scales real(default), dimension(:,:), allocatable :: sqme_real_non_sub real(default), dimension(:), allocatable :: sqme_born real(default), dimension(:,:,:), allocatable :: sqme_coll_isr real(default), dimension(:,:,:), allocatable :: sqme_born_color_c real(default), dimension(:,:,:), allocatable :: sqme_born_charge_c complex(default), dimension(:,:,:,:), allocatable :: sqme_born_spin_c type(soft_subtraction_t) :: sub_soft type(coll_subtraction_t) :: sub_coll logical, dimension(:), allocatable :: sc_required logical :: subtraction_deactivated = .false. integer :: purpose = INTEGRATION logical :: radiation_event = .true. logical :: subtraction_event = .false. integer, dimension(:), allocatable :: selected_alr contains <> end type real_subtraction_t @ %def real_subtraction_t @ Initializer <>= procedure :: init => real_subtraction_init <>= subroutine real_subtraction_init (rsub, reg_data, settings) class(real_subtraction_t), intent(inout), target :: rsub type(region_data_t), intent(in), target :: reg_data type(nlo_settings_t), intent(in), target :: settings integer :: alr call msg_debug (D_SUBTRACTION, "real_subtraction_init") call msg_debug (D_SUBTRACTION, "n_in", reg_data%n_in) call msg_debug (D_SUBTRACTION, "nlegs_born", reg_data%n_legs_born) call msg_debug (D_SUBTRACTION, "nlegs_real", reg_data%n_legs_real) call msg_debug (D_SUBTRACTION, "reg_data%n_regions", reg_data%n_regions) if (debug2_active (D_SUBTRACTION)) call reg_data%write () rsub%reg_data => reg_data allocate (rsub%sqme_born (reg_data%n_flv_born)) rsub%sqme_born = zero allocate (rsub%sqme_born_color_c (reg_data%n_legs_born, reg_data%n_legs_born, & reg_data%n_flv_born)) rsub%sqme_born_color_c = zero allocate (rsub%sqme_born_charge_c (reg_data%n_legs_born, reg_data%n_legs_born, & reg_data%n_flv_born)) rsub%sqme_born_charge_c = zero allocate (rsub%sqme_real_non_sub (reg_data%n_flv_real, reg_data%n_phs)) rsub%sqme_real_non_sub = zero allocate (rsub%sc_required (reg_data%n_regions)) do alr = 1, reg_data%n_regions rsub%sc_required(alr) = reg_data%regions(alr)%sc_required end do if (rsub%requires_spin_correlations ()) then allocate (rsub%sqme_born_spin_c (0:3, 0:3, reg_data%n_legs_born, reg_data%n_flv_born)) rsub%sqme_born_spin_c = zero end if call rsub%sub_soft%init (reg_data) call rsub%sub_coll%init (reg_data%n_regions, reg_data%n_in) allocate (rsub%sqme_coll_isr (2, 2, reg_data%n_flv_born)) rsub%sqme_coll_isr = zero rsub%settings => settings rsub%sub_soft%use_resonance_mappings = settings%use_resonance_mappings rsub%sub_coll%use_resonance_mappings = settings%use_resonance_mappings rsub%sub_soft%factorization_mode = settings%factorization_mode end subroutine real_subtraction_init @ %def real_subtraction_init @ <>= procedure :: set_real_kinematics => real_subtraction_set_real_kinematics <>= subroutine real_subtraction_set_real_kinematics (rsub, real_kinematics) class(real_subtraction_t), intent(inout) :: rsub type(real_kinematics_t), intent(in), target :: real_kinematics rsub%real_kinematics => real_kinematics end subroutine real_subtraction_set_real_kinematics @ %def real_subtraction_set_real_kinematics @ <>= procedure :: set_isr_kinematics => real_subtraction_set_isr_kinematics <>= subroutine real_subtraction_set_isr_kinematics (rsub, fractions) class(real_subtraction_t), intent(inout) :: rsub type(isr_kinematics_t), intent(in), target :: fractions rsub%isr_kinematics => fractions end subroutine real_subtraction_set_isr_kinematics @ %def real_subtraction_set_isr_kinematics @ <>= procedure :: get_i_res => real_subtraction_get_i_res <>= function real_subtraction_get_i_res (rsub, alr) result (i_res) integer :: i_res class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr select type (fks_mapping => rsub%reg_data%fks_mapping) type is (fks_mapping_resonances_t) i_res = fks_mapping%res_map%alr_to_i_res (alr) class default i_res = 0 end select end function real_subtraction_get_i_res @ %def real_subtraction_get_i_res @\subsection{The real contribution to the cross section} In each singular region $\alpha$, the real contribution to $\sigma$ is given by the second summand of eqn. \ref{fks: sub: complete}, \begin{equation} \label{fks: sub: real} \sigma^\alpha_{\text{real}} = \int d\Phi_n \int_0^{2\pi} d\phi \int_{-1}^1 dy \int_0^{\xi_{\text{max}}} d\xi \left(\frac{1}{\xi}\right)_+ \left(\frac{1}{1-y}\right)_+ \underbrace{\frac{J(\Phi_n, \xi, y, \phi)}{\xi} \left[(1-y)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]}_{g^\alpha(\xi,y)}. \end{equation} Writing out the plus-distribution and introducing $\tilde{\xi} = \xi/\xi_{\text{max}}$ to set the upper integration limit to 1, this turns out to be equal to \begin{equation} \begin{split} \sigma^\alpha_{\rm{real}} &= \int d\Phi_n \int_0^{2\pi}d\phi \int_{-1}^1 \frac{dy}{1-y} \Bigg\{\int_0^1 d\tilde{\xi}\Bigg[\frac{g^\alpha(\tilde{\xi}\xi_{\rm{max}},y)}{\tilde{\xi}} - \underbrace{\frac{g^\alpha(0,y)}{\tilde{\xi}}}_{\text{soft}} - \underbrace{\frac{g^\alpha(\tilde{\xi}\xi_{\rm{max}},1)}{\tilde{\xi}}}_{\text{coll.}} + \underbrace{\frac{g^\alpha(0,1)}{\tilde{\xi}}}_{\text{coll.+soft}}\Bigg] \\ &+ \left[\log\xi_{\rm{max}}(y)g^\alpha(0,y) - \log\xi_{\rm{max}}(1)g^\alpha(0,1)\right]\Bigg\}. \end{split} \end{equation} This formula is implemented in \texttt{compute\_sqme\_real\_fin} <>= procedure :: compute => real_subtraction_compute <>= subroutine real_subtraction_compute (rsub, emitter, i_phs, alpha_s, & alpha_qed, separate_alrs, sqme) class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: emitter, i_phs logical, intent(in) :: separate_alrs real(default), intent(inout), dimension(:) :: sqme real(default), intent(in) :: alpha_s, alpha_qed real(default) :: sqme_alr, alpha_coupling integer :: alr, i_con, i_res, this_emitter logical :: same_emitter do alr = 1, rsub%reg_data%n_regions if (allocated (rsub%selected_alr)) then if (.not. any (rsub%selected_alr == alr)) cycle end if sqme_alr = zero if (emitter > rsub%isr_kinematics%n_in) then same_emitter = emitter == rsub%reg_data%regions(alr)%emitter else same_emitter = rsub%reg_data%regions(alr)%emitter <= rsub%isr_kinematics%n_in end if associate (nlo_corr_type => rsub%reg_data%regions(alr)%nlo_correction_type) if (nlo_corr_type == "QCD") then alpha_coupling = alpha_s else if (nlo_corr_type == "QED") then alpha_coupling = alpha_qed end if end associate if (same_emitter .and. i_phs == rsub%real_kinematics%alr_to_i_phs (alr)) then i_res = rsub%get_i_res (alr) this_emitter = rsub%reg_data%regions(alr)%emitter sqme_alr = rsub%evaluate_emitter_region (alr, this_emitter, i_phs, i_res, & alpha_coupling) if (rsub%purpose == INTEGRATION .or. rsub%purpose == FIXED_ORDER_EVENTS) then i_con = rsub%get_i_contributor (alr) sqme_alr = sqme_alr * rsub%get_phs_factor (i_con) end if end if if (separate_alrs) then sqme(alr) = sqme(alr) + sqme_alr else sqme(1) = sqme(1) + sqme_alr end if end do if (debug2_active (D_SUBTRACTION)) call check_s_alpha_consistency () contains subroutine check_s_alpha_consistency () real(default) :: sum_s_alpha, sum_s_alpha_soft integer :: i_reg, i1, i2 call msg_debug2 (D_SUBTRACTION, "Check consistency of s_alpha: ") do i_reg = 1, rsub%reg_data%n_regions sum_s_alpha = zero; sum_s_alpha_soft = zero do alr = 1, rsub%reg_data%regions(i_reg)%nregions call rsub%reg_data%regions(i_reg)%ftuples(alr)%get (i1, i2) call rsub%evaluate_emitter_region_debug (i_reg, alr, i1, i2, i_phs, & sum_s_alpha, sum_s_alpha_soft) end do end do end subroutine check_s_alpha_consistency end subroutine real_subtraction_compute @ %def real_subtraction_compute @ The emitter is fixed. We now have to decide whether we evaluate in ISR or FSR region, and also if resonances are used. <>= procedure :: evaluate_emitter_region => real_subtraction_evaluate_emitter_region <>= function real_subtraction_evaluate_emitter_region (rsub, alr, emitter, & i_phs, i_res, alpha_coupling) result (sqme) real(default) :: sqme class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, emitter, i_phs, i_res real(default), intent(in) :: alpha_coupling if (emitter <= rsub%isr_kinematics%n_in) then sqme = rsub%evaluate_region_isr (alr, emitter, i_phs, i_res, alpha_coupling) else select type (fks_mapping => rsub%reg_data%fks_mapping) type is (fks_mapping_resonances_t) call fks_mapping%set_resonance_momenta & (rsub%real_kinematics%xi_ref_momenta) end select sqme = rsub%evaluate_region_fsr (alr, emitter, i_phs, i_res, alpha_coupling) end if end function real_subtraction_evaluate_emitter_region @ %def real_subtraction_evaluate_emitter_region @ <>= procedure :: evaluate_emitter_region_debug & => real_subtraction_evaluate_emitter_region_debug <>= subroutine real_subtraction_evaluate_emitter_region_debug (rsub, i_reg, alr, i1, i2, & i_phs, sum_s_alpha, sum_s_alpha_soft) class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: i_reg, alr, i1, i2, i_phs real(default), intent(inout) :: sum_s_alpha, sum_s_alpha_soft type(vector4_t), dimension(:), allocatable :: p_real, p_born integer :: i_res allocate (p_real (rsub%reg_data%n_legs_real)) allocate (p_born (rsub%reg_data%n_legs_born)) if (rsub%reg_data%has_pseudo_isr ()) then p_real = rsub%real_kinematics%p_real_onshell(i_phs)%get_momenta (i_phs) p_born = rsub%real_kinematics%p_born_onshell%get_momenta (1) else p_real = rsub%real_kinematics%p_real_cms%get_momenta (i_phs) p_born = rsub%real_kinematics%p_born_cms%get_momenta (1) end if i_res = rsub%get_i_res (i_reg) sum_s_alpha = sum_s_alpha + rsub%reg_data%get_svalue (p_real, i_reg, i1, i2, i_res) associate (r => rsub%real_kinematics) if (i1 > rsub%sub_soft%reg_data%n_in) then call rsub%sub_soft%create_softvec_fsr (p_born, r%y_soft(i_phs), r%phi, & i1, r%xi_ref_momenta(rsub%sub_soft%i_xi_ref (i_reg, i_phs))) else call rsub%sub_soft%create_softvec_isr (r%y_soft(i_phs), r%phi) end if end associate sum_s_alpha_soft = sum_s_alpha_soft + rsub%reg_data%get_svalue_soft & (p_born, rsub%sub_soft%p_soft, i_reg, i1, i_res) end subroutine real_subtraction_evaluate_emitter_region_debug @ %def real_subtraction_evaluate_emitter_region_debug @ This subroutine computes the finite part of the real matrix element in an individual singular region. First, the radiation variables are fetched and $\mathcal{R}$ is multiplied by the appropriate $S_\alpha$-factors, region multiplicities and double-FSR factors. Then, it computes the soft, collinear, soft-collinear and remnant matrix elements and supplies the corresponding factor $1/\xi/(1-y)$ as well as the corresponding jacobians. <>= procedure :: evaluate_region_fsr => real_subtraction_evaluate_region_fsr <>= function real_subtraction_evaluate_region_fsr (rsub, alr, emitter, i_phs, & i_res, alpha_coupling) result (sqme_tot) real(default) :: sqme_tot class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, emitter, i_phs, i_res real(default), intent(in) :: alpha_coupling real(default) :: sqme_rad, sqme_soft, sqme_coll, sqme_cs, sqme_remn sqme_rad = zero; sqme_soft = zero; sqme_coll = zero sqme_cs = zero; sqme_remn = zero associate (region => rsub%reg_data%regions(alr), template => rsub%settings%fks_template) if (rsub%radiation_event) then sqme_rad = rsub%sqme_real_non_sub (rsub%reg_data%get_matrix_element_index (alr), i_phs) call evaluate_fks_factors (sqme_rad, rsub%reg_data, rsub%real_kinematics, & alr, i_phs, emitter, i_res) call apply_kinematic_factors_radiation (sqme_rad, rsub%purpose, & rsub%real_kinematics, i_phs, .false., rsub%reg_data%has_pseudo_isr (), & emitter) end if if (rsub%subtraction_event .and. .not. rsub%subtraction_deactivated) then if (debug2_active (D_SUBTRACTION)) then print *, "[real_subtraction_evaluate_region_fsr]" print *, "xi: ", rsub%real_kinematics%xi_max(i_phs) * rsub%real_kinematics%xi_tilde print *, "y: ", rsub%real_kinematics%y(i_phs) end if call rsub%evaluate_subtraction_terms_fsr (alr, emitter, i_phs, i_res, alpha_coupling, & sqme_soft, sqme_coll, sqme_cs) call apply_kinematic_factors_subtraction_fsr (sqme_soft, sqme_coll, sqme_cs, & rsub%real_kinematics, i_phs) sqme_remn = compute_sqme_remnant_fsr (sqme_soft, sqme_cs, & rsub%real_kinematics%xi_max(i_phs), template%xi_cut, rsub%real_kinematics%xi_tilde) select case (rsub%purpose) case (INTEGRATION) sqme_tot = sqme_rad - sqme_soft - sqme_coll + sqme_cs + sqme_remn case (FIXED_ORDER_EVENTS) sqme_tot = - sqme_soft - sqme_coll + sqme_cs + sqme_remn case default sqme_tot = zero call msg_bug ("real_subtraction_evaluate_region_fsr: " // & "Undefined rsub%purpose") end select else sqme_tot = sqme_rad end if sqme_tot = sqme_tot * rsub%real_kinematics%jac_rand(i_phs) end associate if (debug_active (D_SUBTRACTION) .and. .not. debug2_active (D_SUBTRACTION)) then call register_debug_sqme () else if (debug2_active (D_SUBTRACTION)) then call write_computation_status () end if contains <> subroutine register_debug_sqme () real(default), dimension(:), allocatable, save :: sqme_rad_store logical :: soft, collinear real(default), parameter :: soft_threshold = 0.01_default real(default), parameter :: coll_threshold = 0.01_default real(default) :: this_sqme_rad, s_alpha, E_gluon logical, dimension(:), allocatable, save :: count_alr - !!! TODO (cw-2017-02-18): Need to be able to set this (?) logical :: write_histo = .true. if (.not. allocated (sqme_rad_store)) then allocate (sqme_rad_store (rsub%reg_data%n_regions)) sqme_rad_store = zero end if if (rsub%radiation_event) then sqme_rad_store(alr) = sqme_rad else if (.not. allocated (count_alr)) then allocate (count_alr (rsub%reg_data%n_regions)) count_alr = .false. end if associate (p_real => rsub%real_kinematics%p_real_cms) E_gluon = p_real%get_energy (i_phs, rsub%reg_data%n_legs_real) s_alpha = rsub%reg_data%get_svalue (p_real%get_momenta(i_phs), alr, emitter, i_res) end associate soft = E_gluon < soft_threshold collinear = abs (s_alpha - one) < coll_threshold this_sqme_rad = sqme_rad_store(alr) if (soft) then !!! Do not write sqme_rad twice if (write_histo .and. .not. rsub%radiation_event) & call write_point_to_file (E_gluon, this_sqme_rad, sqme_soft) if ( .not. nearly_equal (this_sqme_rad, sqme_soft, & abs_smallness=tiny_13, rel_smallness=tiny_07*10000)) then call msg_print_color (char ("Soft MEs do not match in region " // str (alr)), COL_RED) else call msg_print_color (char ("sqme_soft OK in region " // str (alr)), COL_GREEN) end if print *, 'this_sqme_rad, sqme_soft = ', this_sqme_rad, sqme_soft end if if (collinear) then if ( .not. nearly_equal (this_sqme_rad, sqme_coll, & abs_smallness=tiny_13, rel_smallness=tiny_07*10000)) then call msg_print_color (char ("Collinear MEs do not match in region " // str (alr)), COL_RED) else call msg_print_color (char ("sqme_coll OK in region " // str (alr)), COL_GREEN) end if print *, 'this_sqme_rad, sqme_coll = ', this_sqme_rad, sqme_coll end if if (soft .and. collinear) then if ( .not. nearly_equal (this_sqme_rad, sqme_cs, & abs_smallness=tiny_13, rel_smallness=tiny_07*10000)) then call msg_print_color (char ("Soft-collinear MEs do not match in region " // str (alr)), COL_RED) else call msg_print_color (char ("sqme_cs OK in region " // str (alr)), COL_GREEN) end if print *, 'this_sqme_rad, sqme_cs = ', this_sqme_rad, sqme_cs end if count_alr (alr) = .true. if (all (count_alr)) then deallocate (count_alr) deallocate (sqme_rad_store) end if end if end subroutine register_debug_sqme subroutine write_computation_status (passed, total, region_type, full) integer, intent(in), optional :: passed, total character(*), intent(in), optional :: region_type integer :: i_born integer :: u real(default) :: xi logical :: yorn logical, intent(in), optional :: full yorn = .true. if (present (full)) yorn = full call msg_debug (D_SUBTRACTION, "real_subtraction_evaluate_region_fsr") u = given_output_unit (); if (u < 0) return i_born = rsub%reg_data%regions(alr)%uborn_index xi = rsub%real_kinematics%xi_max (i_phs) * rsub%real_kinematics%xi_tilde write (u,'(A,I2)') 'rsub%purpose: ', rsub%purpose write (u,'(A,I3)') 'alr: ', alr write (u,'(A,I3)') 'emitter: ', emitter write (u,'(A,I3)') 'i_phs: ', i_phs write (u,'(A,F6.4)') 'xi_max: ', rsub%real_kinematics%xi_max (i_phs) write (u,'(A,F6.4)') 'xi_cut: ', rsub%real_kinematics%xi_max(i_phs) * rsub%settings%fks_template%xi_cut write (u,'(A,F6.4,2X,A,F6.4)') 'xi: ', xi, 'y: ', rsub%real_kinematics%y (i_phs) if (yorn) then write (u,'(A,ES16.9)') 'sqme_born: ', rsub%sqme_born(i_born) write (u,'(A,ES16.9)') 'sqme_real: ', sqme_rad write (u,'(A,ES16.9)') 'sqme_soft: ', sqme_soft write (u,'(A,ES16.9)') 'sqme_coll: ', sqme_coll write (u,'(A,ES16.9)') 'sqme_coll-soft: ', sqme_cs write (u,'(A,ES16.9)') 'sqme_remn: ', sqme_remn write (u,'(A,ES16.9)') 'sqme_tot: ', sqme_tot if (present (passed) .and. present (total) .and. & present (region_type)) & write (u,'(A)') char (str (passed) // " of " // str (total) // & " " // region_type // " points passed in total") end if write (u,'(A,ES16.9)') 'jacobian - real: ', rsub%real_kinematics%jac(i_phs)%jac(1) write (u,'(A,ES16.9)') 'jacobian - soft: ', rsub%real_kinematics%jac(i_phs)%jac(2) write (u,'(A,ES16.9)') 'jacobian - coll: ', rsub%real_kinematics%jac(i_phs)%jac(3) end subroutine write_computation_status subroutine write_point_to_file (E_gluon, sqme_rad, sqme_soft) real(default), intent(in) :: E_gluon, sqme_rad, sqme_soft integer, save :: funit = 0 type(string_t) :: filename filename = var_str ("soft.log") if (funit == 0) then funit = free_unit () open (funit, file=char(filename), action = "write", status="replace") write (funit, "(A,5X,A,5X,A)") "# E_gluon", "Real", "Soft Approx" end if write (funit,'(3(ES16.9,1X))') E_gluon, sqme_rad, sqme_soft end subroutine write_point_to_file end function real_subtraction_evaluate_region_fsr @ %def real_subtraction_evalute_region_fsr @ For final state radiation, the subtraction remnant cross section is \begin{equation} \sigma_{\text{remn}} = \left(\sigma_{\text{soft}} - \sigma_{\text{soft-coll}}\right) \log (\xi_{\text{max}}\xi_{\text{cut}})) \cdot \tilde{\xi}. \end{equation} We use the already computed [[sqme_soft]] and [[sqme_cs]] with a factor of $\tilde{\xi}$ which we have to compensate. <>= function compute_sqme_remnant_fsr (sqme_soft, sqme_cs, xi_max, xi_cut, xi_tilde) result (sqme_remn) real(default) :: sqme_remn real(default), intent(in) :: sqme_soft, sqme_cs, xi_max, xi_cut, xi_tilde call msg_debug (D_SUBTRACTION, "compute_sqme_remnant_fsr") sqme_remn = zero sqme_remn = sqme_remn + (sqme_soft - sqme_cs) * log (xi_max * xi_cut) * xi_tilde end function compute_sqme_remnant_fsr @ %def compute_sqme_remnant_fsr @ <>= procedure :: evaluate_region_isr => real_subtraction_evaluate_region_isr <>= function real_subtraction_evaluate_region_isr (rsub, alr, emitter, i_phs, i_res, alpha_coupling) & result (sqme_tot) real(default) :: sqme_tot class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, emitter, i_phs, i_res real(default), intent(in) :: alpha_coupling real(default) :: sqme_rad, sqme_soft, sqme_coll_plus, sqme_coll_minus real(default) :: sqme_cs_plus, sqme_cs_minus real(default) :: sqme_remn sqme_rad = zero; sqme_soft = zero; sqme_coll_plus = zero; sqme_coll_minus = zero sqme_cs_plus = zero; sqme_cs_minus = zero sqme_remn = zero associate (region => rsub%reg_data%regions(alr), template => rsub%settings%fks_template) if (rsub%radiation_event) then sqme_rad = rsub%sqme_real_non_sub (rsub%reg_data%get_matrix_element_index (alr), i_phs) call evaluate_fks_factors (sqme_rad, rsub%reg_data, rsub%real_kinematics, & alr, i_phs, emitter, i_res) call apply_kinematic_factors_radiation (sqme_rad, rsub%purpose, rsub%real_kinematics, & i_phs, .true., .false.) end if if (rsub%subtraction_event .and. .not. rsub%subtraction_deactivated) then call rsub%evaluate_subtraction_terms_isr (alr, emitter, i_phs, i_res, alpha_coupling, & sqme_soft, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, sqme_cs_minus) call apply_kinematic_factors_subtraction_isr (sqme_soft, sqme_coll_plus, & sqme_coll_minus, sqme_cs_plus, sqme_cs_minus, rsub%real_kinematics, i_phs) sqme_remn = compute_sqme_remnant_isr (rsub%isr_kinematics%isr_mode, & sqme_soft, sqme_cs_plus, sqme_cs_minus, & rsub%isr_kinematics, rsub%real_kinematics, i_phs, template%xi_cut) sqme_tot = sqme_rad - sqme_soft - sqme_coll_plus - sqme_coll_minus & + sqme_cs_plus + sqme_cs_minus + sqme_remn else sqme_tot = sqme_rad end if end associate sqme_tot = sqme_tot * rsub%real_kinematics%jac_rand (i_phs) call debug_output () contains subroutine debug_output () logical :: soft type(vector4_t) :: p_gluon if (debug_active (D_SUBTRACTION)) then call msg_debug (D_SUBTRACTION, "real_subtraction_evaluate_region_isr") if (debug2_active (D_SUBTRACTION)) then call write_computation_status () else associate (p_real => rsub%real_kinematics%p_real_cms) p_gluon = p_real%get_momentum (i_phs, p_real%get_n_momenta (i_phs)) soft = p_gluon%p(0) < 2.0_default end associate if (soft) then if (abs (sqme_rad - sqme_soft) > sqme_rad .and. sqme_soft > tiny_10) then call msg_warning ("Soft MEs do not match in soft region") call write_computation_status () end if end if end if end if end subroutine debug_output subroutine write_computation_status (unit) integer, intent(in), optional :: unit integer :: i_born integer :: u real(default) :: xi u = given_output_unit (unit); if (u < 0) return i_born = rsub%reg_data%regions(alr)%uborn_index xi = rsub%real_kinematics%xi_max (i_phs) * rsub%real_kinematics%xi_tilde write (u,'(A,I2)') 'alr: ', alr write (u,'(A,I2)') 'emitter: ', emitter write (u,'(A,F4.2)') 'xi_max: ', rsub%real_kinematics%xi_max (i_phs) print *, 'xi: ', xi, 'y: ', rsub%real_kinematics%y (i_phs) print *, 'xb1: ', rsub%isr_kinematics%x(1), 'xb2: ', rsub%isr_kinematics%x(2) print *, 'random jacobian: ', rsub%real_kinematics%jac_rand (i_phs) write (u,'(A,ES16.9)') 'sqme_born: ', rsub%sqme_born(i_born) write (u,'(A,ES16.9)') 'sqme_real: ', sqme_rad write (u,'(A,ES16.9)') 'sqme_soft: ', sqme_soft write (u,'(A,ES16.9)') 'sqme_coll_plus: ', sqme_coll_plus write (u,'(A,ES16.9)') 'sqme_coll_minus: ', sqme_coll_minus write (u,'(A,ES16.9)') 'sqme_cs_plus: ', sqme_cs_plus write (u,'(A,ES16.9)') 'sqme_cs_minus: ', sqme_cs_minus write (u,'(A,ES16.9)') 'sqme_remn: ', sqme_remn write (u,'(A,ES16.9)') 'sqme_tot: ', sqme_tot write (u,'(A,ES16.9)') 'jacobian - real: ', rsub%real_kinematics%jac(i_phs)%jac(1) write (u,'(A,ES16.9)') 'jacobian - soft: ', rsub%real_kinematics%jac(i_phs)%jac(2) write (u,'(A,ES16.9)') 'jacobian - collplus: ', rsub%real_kinematics%jac(i_phs)%jac(3) write (u,'(A,ES16.9)') 'jacobian - collminus: ', rsub%real_kinematics%jac(i_phs)%jac(4) end subroutine write_computation_status <> end function real_subtraction_evaluate_region_isr @ %def real_subtraction_evaluate_region_isr @ <>= function compute_sqme_remnant_isr (isr_mode, sqme_soft, sqme_cs_plus, sqme_cs_minus, & isr_kinematics, real_kinematics, i_phs, xi_cut) result (sqme_remn) real(default) :: sqme_remn integer, intent(in) :: isr_mode real(default), intent(in) :: sqme_soft, sqme_cs_plus, sqme_cs_minus type(isr_kinematics_t), intent(in) :: isr_kinematics type(real_kinematics_t), intent(in) :: real_kinematics integer, intent(in) :: i_phs real(default), intent(in) :: xi_cut real(default) :: xi_tilde, xi_max, xi_max_plus, xi_max_minus xi_max = real_kinematics%xi_max (i_phs) select case (isr_mode) case (SQRTS_VAR) xi_max_plus = one - isr_kinematics%x(I_PLUS) xi_max_minus = one - isr_kinematics%x(I_MINUS) case (SQRTS_FIXED) xi_max_plus = real_kinematics%xi_max (i_phs) xi_max_minus = real_kinematics%xi_max (i_phs) end select xi_tilde = real_kinematics%xi_tilde sqme_remn = log(xi_max * xi_cut) * xi_tilde * sqme_soft sqme_remn = sqme_remn - log (xi_max_plus * xi_cut) * xi_tilde * sqme_cs_plus & - log (xi_max_minus * xi_cut) * xi_tilde * sqme_cs_minus end function compute_sqme_remnant_isr @ %def compute_sqme_remnant_isr @ <>= procedure :: evaluate_subtraction_terms_fsr => & real_subtraction_evaluate_subtraction_terms_fsr <>= subroutine real_subtraction_evaluate_subtraction_terms_fsr (rsub, & alr, emitter, i_phs, i_res, alpha_coupling, sqme_soft, sqme_coll, sqme_cs) class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, emitter, i_phs, i_res real(default), intent(in) :: alpha_coupling real(default), intent(out) :: sqme_soft, sqme_coll, sqme_cs call msg_debug (D_SUBTRACTION, "real_subtraction_evaluate_subtraction_terms_fsr") sqme_soft = zero; sqme_coll = zero; sqme_cs = zero associate (xi_tilde => rsub%real_kinematics%xi_tilde, & y => rsub%real_kinematics%y(i_phs), template => rsub%settings%fks_template) if (template%xi_cut > xi_tilde) & sqme_soft = rsub%compute_sub_soft (alr, emitter, i_phs, i_res, alpha_coupling) if (y - 1 + template%delta_zero > 0) & sqme_coll = rsub%compute_sub_coll (alr, emitter, i_phs, alpha_coupling) if (template%xi_cut > xi_tilde .and. y - 1 + template%delta_zero > 0) & sqme_cs = rsub%compute_sub_coll_soft (alr, emitter, i_phs, alpha_coupling) if (debug2_active (D_SUBTRACTION)) then print *, "FSR Cutoff:" print *, "sub_soft: ", template%xi_cut > xi_tilde, "(ME: ", sqme_soft, ")" print *, "sub_coll: ", (y - 1 + template%delta_zero) > 0, "(ME: ", sqme_coll, ")" print *, "sub_coll_soft: ", template%xi_cut > xi_tilde .and. (y - 1 + template%delta_zero) > 0, & "(ME: ", sqme_cs, ")" end if end associate end subroutine real_subtraction_evaluate_subtraction_terms_fsr @ %def real_subtraction_evaluate_subtraction_terms_fsr @ <>= subroutine evaluate_fks_factors (sqme, reg_data, real_kinematics, & alr, i_phs, emitter, i_res) real(default), intent(inout) :: sqme type(region_data_t), intent(inout) :: reg_data type(real_kinematics_t), intent(in), target :: real_kinematics integer, intent(in) :: alr, i_phs, emitter, i_res real(default) :: s_alpha type(phs_point_set_t), pointer :: p_real => null () if (reg_data%has_pseudo_isr ()) then p_real => real_kinematics%p_real_onshell (i_phs) else p_real => real_kinematics%p_real_cms end if s_alpha = reg_data%get_svalue (p_real%get_momenta(i_phs), alr, emitter, i_res) if (debug2_active (D_SUBTRACTION)) call msg_print_color('s_alpha', s_alpha, COL_YELLOW) if (s_alpha > one + tiny_07) call msg_fatal ("s_alpha > 1!") sqme = sqme * s_alpha associate (region => reg_data%regions(alr)) sqme = sqme * region%mult if (emitter > reg_data%n_in) then if (debug2_active (D_SUBTRACTION)) & print *, 'Double FSR: ', region%double_fsr_factor (p_real%get_momenta(i_phs)) sqme = sqme * region%double_fsr_factor (p_real%get_momenta(i_phs)) end if end associate end subroutine evaluate_fks_factors @ %def evaluate_fks_factors @ <>= subroutine apply_kinematic_factors_radiation (sqme, purpose, real_kinematics, & i_phs, isr, threshold, emitter) real(default), intent(inout) :: sqme integer, intent(in) :: purpose type(real_kinematics_t), intent(in) :: real_kinematics integer, intent(in) :: i_phs logical, intent(in) :: isr, threshold integer, intent(in), optional :: emitter real(default) :: xi, xi_tilde, s xi_tilde = real_kinematics%xi_tilde xi = xi_tilde * real_kinematics%xi_max (i_phs) select case (purpose) case (INTEGRATION, FIXED_ORDER_EVENTS) sqme = sqme * xi**2 / xi_tilde * real_kinematics%jac(i_phs)%jac(1) case (POWHEG) if (.not. isr) then s = real_kinematics%cms_energy2 sqme = sqme * real_kinematics%jac(i_phs)%jac(1) * s / (8 * twopi3) * xi else call msg_fatal ("POWHEG with initial-state radiation not implemented yet") end if end select end subroutine apply_kinematic_factors_radiation @ %def apply_kinematics_factors_radiation @ <>= subroutine apply_kinematic_factors_subtraction_fsr & (sqme_soft, sqme_coll, sqme_cs, real_kinematics, i_phs) real(default), intent(inout) :: sqme_soft, sqme_coll, sqme_cs type(real_kinematics_t), intent(in) :: real_kinematics integer, intent(in) :: i_phs real(default) :: xi_tilde, onemy xi_tilde = real_kinematics%xi_tilde onemy = one - real_kinematics%y(i_phs) sqme_soft = sqme_soft / onemy / xi_tilde sqme_coll = sqme_coll / onemy / xi_tilde sqme_cs = sqme_cs / onemy / xi_tilde associate (jac => real_kinematics%jac(i_phs)%jac) sqme_soft = sqme_soft * jac(2) sqme_coll = sqme_coll * jac(3) sqme_cs = sqme_cs * jac(2) end associate end subroutine apply_kinematic_factors_subtraction_fsr @ %def apply_kinematic_factors_subtraction_fsr @ <>= subroutine apply_kinematic_factors_subtraction_isr & (sqme_soft, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, & sqme_cs_minus, real_kinematics, i_phs) real(default), intent(inout) :: sqme_soft, sqme_coll_plus, sqme_coll_minus real(default), intent(inout) :: sqme_cs_plus, sqme_cs_minus type(real_kinematics_t), intent(in) :: real_kinematics integer, intent(in) :: i_phs real(default) :: xi_tilde, y, onemy, onepy xi_tilde = real_kinematics%xi_tilde y = real_kinematics%y (i_phs) onemy = one - y; onepy = one + y associate (jac => real_kinematics%jac(i_phs)%jac) sqme_soft = sqme_soft / (one - y**2) / xi_tilde * jac(2) sqme_coll_plus = sqme_coll_plus / onemy / xi_tilde / two * jac(3) sqme_coll_minus = sqme_coll_minus / onepy / xi_tilde / two * jac(4) sqme_cs_plus = sqme_cs_plus / onemy / xi_tilde / two * jac(2) sqme_cs_minus = sqme_cs_minus / onepy / xi_tilde / two * jac(2) end associate end subroutine apply_kinematic_factors_subtraction_isr @ %def apply_kinematic_factors_subtraction_isr @ <>= procedure :: evaluate_subtraction_terms_isr => & real_subtraction_evaluate_subtraction_terms_isr <>= subroutine real_subtraction_evaluate_subtraction_terms_isr (rsub, & alr, emitter, i_phs, i_res, alpha_coupling, sqme_soft, sqme_coll_plus, & sqme_coll_minus, sqme_cs_plus, sqme_cs_minus) class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, emitter, i_phs, i_res real(default), intent(in) :: alpha_coupling real(default), intent(out) :: sqme_soft real(default), intent(out) :: sqme_coll_plus, sqme_coll_minus real(default), intent(out) :: sqme_cs_plus, sqme_cs_minus sqme_coll_plus = zero; sqme_cs_plus = zero sqme_coll_minus = zero; sqme_cs_minus = zero associate (xi_tilde => rsub%real_kinematics%xi_tilde, & y => rsub%real_kinematics%y(i_phs), template => rsub%settings%fks_template) if (template%xi_cut > xi_tilde) & sqme_soft = rsub%compute_sub_soft (alr, emitter, i_phs, i_res, alpha_coupling) if (emitter /= 2) then ! Cut symmetrically for the limits y = +1 or y = -1 if (abs (y) - 1 + template%delta_i > 0) & sqme_coll_plus = rsub%compute_sub_coll (alr, 1, i_phs, alpha_coupling) if (template%xi_cut > xi_tilde .and. abs (y) - 1 + template%delta_i > 0) & sqme_cs_plus = rsub%compute_sub_coll_soft (alr, 1, i_phs, alpha_coupling) end if if (emitter /= 1) then ! Cut symmetrically for the limits y = +1 or y = -1 if (abs (y) - 1 + template%delta_i > 0) & sqme_coll_minus = rsub%compute_sub_coll (alr, 2, i_phs, alpha_coupling) if (template%xi_cut > xi_tilde .and. abs (y) - 1 + template%delta_i > 0) & sqme_cs_minus = rsub%compute_sub_coll_soft (alr, 2, i_phs, alpha_coupling) end if if (debug2_active (D_SUBTRACTION)) then print *, "ISR Cutoff:" print *, "sub_soft: ", template%xi_cut > xi_tilde, "(ME: ", sqme_soft, ")" print *, "sub_coll: ", (abs (y) - 1 + template%delta_zero) > 0, "(ME: ", sqme_coll_plus, sqme_coll_minus, ")" print *, "sub_coll_soft: ", template%xi_cut > xi_tilde .and. (abs (y) - 1 + template%delta_zero) > 0, & "(ME: ", sqme_cs_plus, sqme_cs_minus, ")" end if end associate end subroutine real_subtraction_evaluate_subtraction_terms_isr @ %def real_subtraction_evaluate_subtraction_terms_isr @ This is basically the part of the real jacobian corresponding to \begin{equation*} \frac{q^2}{8 (2\pi)^3}. \end{equation*} We interpret it as the additional phase space factor of the real component, to be more consistent with the evaluation of the Born phase space. <>= procedure :: get_phs_factor => real_subtraction_get_phs_factor <>= function real_subtraction_get_phs_factor (rsub, i_con) result (factor) real(default) :: factor class(real_subtraction_t), intent(in) :: rsub integer, intent(in) :: i_con real(default) :: s s = rsub%real_kinematics%xi_ref_momenta (i_con)**2 factor = s / (8 * twopi3) end function real_subtraction_get_phs_factor @ %def real_subtraction_get_phs_factor @ <>= procedure :: get_i_contributor => real_subtraction_get_i_contributor <>= function real_subtraction_get_i_contributor (rsub, alr) result (i_con) integer :: i_con class(real_subtraction_t), intent(in) :: rsub integer, intent(in) :: alr if (allocated (rsub%reg_data%alr_to_i_contributor)) then i_con = rsub%reg_data%alr_to_i_contributor (alr) else i_con = 1 end if end function real_subtraction_get_i_contributor @ %def real_subtraction_get_i_contributor @ <>= procedure :: compute_sub_soft => real_subtraction_compute_sub_soft <>= function real_subtraction_compute_sub_soft (rsub, alr, emitter, & i_phs, i_res, alpha_coupling) result (sqme_soft) real(default) :: sqme_soft class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, emitter, i_phs, i_res real(default), intent(in) :: alpha_coupling integer :: i_xi_ref, i_born real(default) :: q2 type(vector4_t), dimension(:), allocatable :: p_born associate (real_kinematics => rsub%real_kinematics, & nlo_corr_type => rsub%reg_data%regions(alr)%nlo_correction_type) sqme_soft = zero if (rsub%reg_data%regions(alr)%has_soft_divergence ()) then i_xi_ref = rsub%sub_soft%i_xi_ref (alr, i_phs) q2 = real_kinematics%xi_ref_momenta (i_xi_ref)**2 allocate (p_born (rsub%reg_data%n_legs_born)) if (rsub%reg_data%has_pseudo_isr ()) then p_born = real_kinematics%p_born_onshell%get_momenta(1) else p_born = real_kinematics%p_born_cms%get_momenta(1) end if if (emitter > rsub%sub_soft%reg_data%n_in) then call rsub%sub_soft%create_softvec_fsr & (p_born, real_kinematics%y_soft(i_phs), & real_kinematics%phi, emitter, & real_kinematics%xi_ref_momenta(i_xi_ref)) else call rsub%sub_soft%create_softvec_isr & (real_kinematics%y_soft(i_phs), real_kinematics%phi) end if i_born = rsub%reg_data%regions(alr)%uborn_index if (nlo_corr_type == "QCD") then sqme_soft = rsub%sub_soft%compute & (p_born, rsub%sqme_born_color_c(:,:,i_born), & real_kinematics%y(i_phs), & q2, alpha_coupling, alr, emitter, i_res) else if (nlo_corr_type == "QED") then sqme_soft = rsub%sub_soft%compute & (p_born, rsub%sqme_born_charge_c(:,:,i_born), & real_kinematics%y(i_phs), & q2, alpha_coupling, alr, emitter, i_res) end if end if end associate if (debug2_active (D_SUBTRACTION)) call check_soft_vector () contains subroutine check_soft_vector () type(vector4_t) :: p_gluon call msg_debug2 (D_SUBTRACTION, "Compare soft vector: ") print *, 'p_soft: ', rsub%sub_soft%p_soft%p print *, 'Normalized gluon momentum: ' if (rsub%reg_data%has_pseudo_isr ()) then p_gluon = rsub%real_kinematics%p_real_onshell(thr_leg(emitter))%get_momentum & (i_phs, rsub%reg_data%n_legs_real) else p_gluon = rsub%real_kinematics%p_real_cms%get_momentum & (i_phs, rsub%reg_data%n_legs_real) end if call vector4_write (p_gluon / p_gluon%p(0), show_mass = .true.) end subroutine check_soft_vector end function real_subtraction_compute_sub_soft @ %def real_subtraction_compute_sub_soft @ <>= procedure :: get_spin_correlation_term => real_subtraction_get_spin_correlation_term <>= function real_subtraction_get_spin_correlation_term (rsub, alr, i_born, emitter) & result (mom_times_sqme) real(default) :: mom_times_sqme class(real_subtraction_t), intent(in) :: rsub integer, intent(in) :: alr, i_born, emitter real(default), dimension(0:3) :: k_perp integer :: mu, nu if (rsub%sc_required(alr)) then if (debug2_active(D_SUBTRACTION)) call check_me_consistency () associate (real_kin => rsub%real_kinematics) if (emitter > rsub%reg_data%n_in) then k_perp = real_subtraction_compute_k_perp_fsr ( & real_kin%p_born_lab%get_momentum(1, emitter), & rsub%real_kinematics%phi) else k_perp = real_subtraction_compute_k_perp_isr ( & real_kin%p_born_lab%get_momentum(1, emitter), & rsub%real_kinematics%phi) end if end associate mom_times_sqme = zero do mu = 0, 3 do nu = 0, 3 mom_times_sqme = mom_times_sqme + & k_perp(mu) * k_perp(nu) * rsub%sqme_born_spin_c (mu, nu, emitter, i_born) end do end do else mom_times_sqme = zero end if contains subroutine check_me_consistency () real(default) :: sqme_sum call msg_debug2 (D_SUBTRACTION, "Spin-correlation: Consistency check") sqme_sum = rsub%sqme_born_spin_c(0,0,emitter,i_born) & - rsub%sqme_born_spin_c(1,1,emitter,i_born) & - rsub%sqme_born_spin_c(2,2,emitter,i_born) & - rsub%sqme_born_spin_c(3,3,emitter,i_born) if (.not. nearly_equal (sqme_sum, -rsub%sqme_born(i_born), 0.0001_default)) then print *, 'Spin-correlated matrix elements are not consistent: ' print *, 'emitter: ', emitter print *, 'g^{mu,nu} B_{mu,nu}: ', -sqme_sum print *, 'all Born matrix elements: ', rsub%sqme_born call msg_fatal ("FAIL") else call msg_print_color ("Success", COL_GREEN) end if end subroutine check_me_consistency end function real_subtraction_get_spin_correlation_term @ %def real_subtraction_get_spin_correlation_term @ Construct a normalised momentum perpendicular to momentum [[p]] and rotate by an arbitrary angle [[phi]]. <>= public :: real_subtraction_compute_k_perp_fsr, & real_subtraction_compute_k_perp_isr <>= function real_subtraction_compute_k_perp_fsr (p, phi) result (k_perp_fsr) real(default), dimension(0:3) :: k_perp_fsr type(vector4_t), intent(in) :: p real(default), intent(in) :: phi type(vector4_t) :: k type(vector3_t) :: vec type(lorentz_transformation_t) :: rot vec = p%p(1:3) / p%p(0) k%p(0) = zero k%p(1) = p%p(1); k%p(2) = p%p(2) k%p(3) = - (p%p(1)**2 + p%p(2)**2) / p%p(3) rot = rotation (cos(phi), sin(phi), vec) k = rot * k k%p(1:3) = k%p(1:3) / space_part_norm (k) k_perp_fsr = k%p end function real_subtraction_compute_k_perp_fsr function real_subtraction_compute_k_perp_isr (p, phi) result (k_perp_isr) real(default), dimension(0:3) :: k_perp_isr type(vector4_t), intent(in) :: p real(default), intent(in) :: phi k_perp_isr(0) = zero k_perp_isr(1) = cos(phi) k_perp_isr(2) = sin(phi) k_perp_isr(3) = zero end function real_subtraction_compute_k_perp_isr @ %def real_subtraction_compute_k_perp_fsr, real_subtraction_compute_k_perp_isr @ <>= procedure :: compute_sub_coll => real_subtraction_compute_sub_coll <>= function real_subtraction_compute_sub_coll (rsub, alr, em, i_phs, alpha_coupling) & result (sqme_coll) real(default) :: sqme_coll class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, em, i_phs real(default), intent(in) :: alpha_coupling real(default) :: xi, xi_max real(default) :: mom_times_sqme_spin_c integer :: i_con, pdf_type real(default) :: pfr associate (sregion => rsub%reg_data%regions(alr)) sqme_coll = zero if (sregion%has_collinear_divergence ()) then xi = rsub%real_kinematics%xi_tilde * rsub%real_kinematics%xi_max(i_phs) if (rsub%sub_coll%use_resonance_mappings) then i_con = rsub%reg_data%alr_to_i_contributor (alr) else i_con = 1 end if mom_times_sqme_spin_c = rsub%get_spin_correlation_term (alr, sregion%uborn_index, em) if (em <= rsub%sub_coll%n_in) then select case (rsub%isr_kinematics%isr_mode) case (SQRTS_FIXED) xi_max = rsub%real_kinematics%xi_max(i_phs) case (SQRTS_VAR) xi_max = one - rsub%isr_kinematics%x(em) end select xi = rsub%real_kinematics%xi_tilde * xi_max ! TODO sbrass introduce overall PDF/PDF_SINGLET parameter - ! TODO sbrass use is_gluon instead of magic number - if (rsub%reg_data%regions(alr)%flst_real%flst(em) == 21) then + if (rsub%reg_data%regions(alr)%flst_real%flst(em) == GLUON) then pdf_type = 2 else pdf_type = 1 end if if (sregion%nlo_correction_type == "QCD") then call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR) else if (sregion%nlo_correction_type == "QED") then call rsub%sub_coll%set_parameters (CA = zero, & CF = sregion%flst_real%charge(em)**2, & TR = sregion%flst_real%charge(size(sregion%flst_real%flst))**2) end if sqme_coll = rsub%sub_coll%compute_isr (em, sregion%flst_real%flst, & rsub%real_kinematics%p_born_lab%phs_point(1)%p, & rsub%sqme_coll_isr(em, pdf_type, sregion%uborn_index), & mom_times_sqme_spin_c, & xi, alpha_coupling, rsub%isr_kinematics%isr_mode) else if (sregion%nlo_correction_type == "QCD") then call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR) else if (sregion%nlo_correction_type == "QED") then call rsub%sub_coll%set_parameters (CA = zero, & CF = sregion%flst_real%charge(sregion%emitter)**2, & TR = sregion%flst_real%charge(sregion%emitter)**2) end if sqme_coll = rsub%sub_coll%compute_fsr (sregion%emitter, sregion%flst_real%flst, & rsub%real_kinematics%xi_ref_momenta (i_con), & rsub%real_kinematics%p_born_lab%get_momenta(1), & rsub%sqme_born(sregion%uborn_index), mom_times_sqme_spin_c, & xi, alpha_coupling, sregion%double_fsr) if (rsub%sub_coll%use_resonance_mappings) then select type (fks_mapping => rsub%reg_data%fks_mapping) type is (fks_mapping_resonances_t) pfr = fks_mapping%get_resonance_weight (alr, & rsub%real_kinematics%p_born_cms%get_momenta(1)) end select sqme_coll = sqme_coll * pfr end if end if end if end associate end function real_subtraction_compute_sub_coll @ %def real_subtraction_compute_sub_coll @ <>= procedure :: compute_sub_coll_soft => real_subtraction_compute_sub_coll_soft <>= function real_subtraction_compute_sub_coll_soft (rsub, alr, em, i_phs, alpha_coupling) & result (sqme_cs) real(default) :: sqme_cs class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, em, i_phs real(default), intent(in) :: alpha_coupling real(default) :: mom_times_sqme_spin_c integer :: i_con associate (sregion => rsub%reg_data%regions(alr)) sqme_cs = zero if (sregion%has_collinear_divergence ()) then if (rsub%sub_coll%use_resonance_mappings) then i_con = rsub%reg_data%alr_to_i_contributor (alr) else i_con = 1 end if mom_times_sqme_spin_c = rsub%get_spin_correlation_term (alr, sregion%uborn_index, em) if (em <= rsub%sub_coll%n_in) then if (sregion%nlo_correction_type == "QCD") then call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR) else if (sregion%nlo_correction_type == "QED") then call rsub%sub_coll%set_parameters (CA = zero, & CF = sregion%flst_real%charge(em)**2, & TR = sregion%flst_real%charge(size(sregion%flst_real%flst))**2) end if sqme_cs = rsub%sub_coll%compute_isr (em, sregion%flst_real%flst, & rsub%real_kinematics%p_born_lab%phs_point(1)%p, & rsub%sqme_born(sregion%uborn_index), mom_times_sqme_spin_c, & zero, alpha_coupling, rsub%isr_kinematics%isr_mode) else if (sregion%nlo_correction_type == "QCD") then call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR) else if (sregion%nlo_correction_type == "QED") then call rsub%sub_coll%set_parameters (CA = zero, & CF = sregion%flst_real%charge(sregion%emitter)**2, & TR = sregion%flst_real%charge(sregion%emitter)**2) end if sqme_cs = rsub%sub_coll%compute_fsr (sregion%emitter, sregion%flst_real%flst, & rsub%real_kinematics%xi_ref_momenta(i_con), & rsub%real_kinematics%p_born_lab%phs_point(1)%p, & rsub%sqme_born(sregion%uborn_index), mom_times_sqme_spin_c, & zero, alpha_coupling, sregion%double_fsr) end if end if end associate end function real_subtraction_compute_sub_coll_soft @ %def real_subtraction_compute_sub_coll_soft <>= procedure :: requires_spin_correlations => & real_subtraction_requires_spin_correlations <>= function real_subtraction_requires_spin_correlations (rsub) result (val) logical :: val class(real_subtraction_t), intent(in) :: rsub val = any (rsub%sc_required) end function real_subtraction_requires_spin_correlations @ %def real_subtraction_requires_spin_correlations @ <>= procedure :: final => real_subtraction_final <>= subroutine real_subtraction_final (rsub) class(real_subtraction_t), intent(inout) :: rsub call rsub%sub_soft%final () call rsub%sub_coll%final () !!! Finalization of region data is done in pcm_nlo_final if (associated (rsub%reg_data)) nullify (rsub%reg_data) !!! Finalization of real kinematics is done in pcm_instance_nlo_final if (associated (rsub%real_kinematics)) nullify (rsub%real_kinematics) if (associated (rsub%isr_kinematics)) nullify (rsub%isr_kinematics) if (allocated (rsub%sqme_real_non_sub)) deallocate (rsub%sqme_real_non_sub) if (allocated (rsub%sqme_born)) deallocate (rsub%sqme_born) if (allocated (rsub%sqme_born_color_c)) deallocate (rsub%sqme_born_color_c) if (allocated (rsub%sqme_born_charge_c)) deallocate (rsub%sqme_born_charge_c) if (allocated (rsub%sc_required)) deallocate (rsub%sc_required) if (allocated (rsub%selected_alr)) deallocate (rsub%selected_alr) end subroutine real_subtraction_final @ %def real_subtraction_final @ \subsubsection{Partitions of the real matrix element and Powheg damping} <>= public :: real_partition_t <>= type, abstract :: real_partition_t contains <> end type real_partition_t @ %def real partition_t @ <>= procedure (real_partition_init), deferred :: init <>= abstract interface subroutine real_partition_init (partition, scale, reg_data) import class(real_partition_t), intent(out) :: partition real(default), intent(in) :: scale type(region_data_t), intent(in) :: reg_data end subroutine real_partition_init end interface @ %def real_partition_init @ <>= procedure (real_partition_write), deferred :: write <>= abstract interface subroutine real_partition_write (partition, unit) import class(real_partition_t), intent(in) :: partition integer, intent(in), optional :: unit end subroutine real_partition_write end interface @ %def real_partition_write @ To allow really arbitrary damping functions, [[get_f]] should get the full real phase space as argument and not just some [[pt2]] that is extracted higher up. <>= procedure (real_partition_get_f), deferred :: get_f <>= abstract interface function real_partition_get_f (partition, p) result (f) import real(default) :: f class(real_partition_t), intent(in) :: partition type(vector4_t), intent(in), dimension(:) :: p end function real_partition_get_f end interface @ %def real_partition_get_f @ <>= public :: powheg_damping_simple_t <>= type, extends (real_partition_t) :: powheg_damping_simple_t real(default) :: h2 = 5._default integer :: emitter contains <> end type powheg_damping_simple_t @ %def powheg_damping_simple_t @ <>= procedure :: get_f => powheg_damping_simple_get_f <>= function powheg_damping_simple_get_f (partition, p) result (f) real(default) :: f class(powheg_damping_simple_t), intent(in) :: partition type(vector4_t), intent(in), dimension(:) :: p !!! real(default) :: pt2 f = 1 call msg_bug ("Simple damping currently not available") !!! TODO (cw-2017-03-01) Compute pt2 from emitter) !!! f = partition%h2 / (pt2 + partition%h2) end function powheg_damping_simple_get_f @ %def powheg_damping_simple_get_f @ <>= procedure :: init => powheg_damping_simple_init <>= subroutine powheg_damping_simple_init (partition, scale, reg_data) class(powheg_damping_simple_t), intent(out) :: partition real(default), intent(in) :: scale type(region_data_t), intent(in) :: reg_data partition%h2 = scale**2 end subroutine powheg_damping_simple_init @ %def powheg_damping_simple_init @ <>= procedure :: write => powheg_damping_simple_write <>= subroutine powheg_damping_simple_write (partition, unit) class(powheg_damping_simple_t), intent(in) :: partition integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Powheg damping simple: " write (u, "(1x,A, "// FMT_15 // ")") "scale h2: ", partition%h2 end subroutine powheg_damping_simple_write @ %def powheg_damping_simple_write @ <>= public :: real_partition_fixed_order_t <>= type, extends (real_partition_t) :: real_partition_fixed_order_t real(default) :: scale type(ftuple_t), dimension(:), allocatable :: fks_pairs contains <> end type real_partition_fixed_order_t @ %def real_partition_fixed_order_t @ <>= procedure :: init => real_partition_fixed_order_init <>= subroutine real_partition_fixed_order_init (partition, scale, reg_data) class(real_partition_fixed_order_t), intent(out) :: partition real(default), intent(in) :: scale type(region_data_t), intent(in) :: reg_data end subroutine real_partition_fixed_order_init @ %def real_partition_fixed_order_init @ <>= procedure :: write => real_partition_fixed_order_write <>= subroutine real_partition_fixed_order_write (partition, unit) class(real_partition_fixed_order_t), intent(in) :: partition integer, intent(in), optional :: unit end subroutine real_partition_fixed_order_write @ %def real_partition_fixed_order_write @ <>= procedure :: get_f => real_partition_fixed_order_get_f <>= function real_partition_fixed_order_get_f (partition, p) result (f) real(default) :: f class(real_partition_fixed_order_t), intent(in) :: partition type(vector4_t), intent(in), dimension(:) :: p integer :: i f = zero do i = 1, size (partition%fks_pairs) associate (ii => partition%fks_pairs(i)%ireg) if ((p(ii(1)) + p(ii(2)))**1 < p(ii(1))**1 + p(ii(2))**1 + partition%scale) then f = one exit end if end associate end do end function real_partition_fixed_order_get_f @ %def real_partition_fixed_order_get_f @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[real_subtraction_ut.f90]]>>= <> module real_subtraction_ut use unit_tests use real_subtraction_uti <> <> contains <> end module real_subtraction_ut @ %def real_subtraction_ut @ <<[[real_subtraction_uti.f90]]>>= <> module real_subtraction_uti <> use physics_defs use lorentz use numeric_utils use real_subtraction <> <> contains <> end module real_subtraction_uti @ %def real_subtraction_ut @ API: driver for the unit tests below. <>= public :: real_subtraction_test <>= subroutine real_subtraction_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine real_subtraction_test @ %def real_subtraction_test @ Test the final-state collinear subtraction. <>= call test (real_subtraction_1, "real_subtraction_1", & "final-state collinear subtraction", & u, results) <>= public :: real_subtraction_1 <>= subroutine real_subtraction_1 (u) integer, intent(in) :: u type(coll_subtraction_t) :: coll_sub real(default) :: sqme_coll type(vector4_t) :: p_res type(vector4_t), dimension(5) :: p_born real(default), dimension(4) :: k_perp real(default), dimension(4,4) :: b_munu integer :: mu, nu real(default) :: born, born_c integer, dimension(6) :: flst p_born(1)%p = [500, 0, 0, 500] p_born(2)%p = [500, 0, 0, -500] p_born(3)%p = [3.7755E+02, 2.2716E+02, -95.4172, 2.8608E+02] p_born(4)%p = [4.9529E+02, -2.739E+02, 84.8535, -4.0385E+02] p_born(5)%p = [1.2715E+02, 46.7375, 10.5637, 1.1778E+02] p_res = p_born(1) + p_born(2) flst = [11, -11 , -2, 2, -2, 2] b_munu(1, :) = [0., 0., 0., 0.] b_munu(2, :) = [0., 1., 1., 1.] b_munu(3, :) = [0., 1., 1., 1.] b_munu(4, :) = [0., 1., 1., 1.] k_perp = real_subtraction_compute_k_perp_fsr (p = p_born(5), phi = 0.5_default) born = - b_munu(1, 1) + b_munu(2, 2) + b_munu(3, 3) + b_munu(4, 4) born_c = 0. do mu = 1, 4 do nu = 1, 4 born_c = born_c + k_perp(mu) * k_perp(nu) * b_munu(mu, nu) end do end do write (u, "(A)") "* Test output: real_subtraction_1" write (u, "(A)") "* Purpose: final-state collinear subtraction" write (u, "(A)") write (u, "(A, L1)") "* vanishing scalar-product of 3-momenta k_perp and p_born(emitter): ", & nearly_equal (dot_product (p_born(5)%p(1:3), k_perp(2:4)), 0._default) call coll_sub%init (n_alr = 1, n_in = 2) call coll_sub%set_parameters (CA, CF, TR) write (u, "(A)") write (u, "(A)") "* g -> qq splitting" write (u, "(A)") sqme_coll = coll_sub%compute_fsr(5, flst, p_res, p_born, & born, born_c, 0.5_default, 0.25_default, .false.) write (u, "(A,F15.12)") "ME: ", sqme_coll write (u, "(A)") write (u, "(A)") "* g -> gg splitting" write (u, "(A)") b_munu(1, :) = [0., 0., 0., 0.] b_munu(2, :) = [0., 0., 0., 1.] b_munu(3, :) = [0., 0., 1., 1.] b_munu(4, :) = [0., 0., 1., 1.] k_perp = real_subtraction_compute_k_perp_fsr (p = p_born(5), phi = 0.5_default) born = - b_munu(1, 1) + b_munu(2, 2) + b_munu(3, 3) + b_munu(4, 4) born_c = 0. do mu = 1, 4 do nu = 1, 4 born_c = born_c + k_perp(mu) * k_perp(nu) * b_munu(mu, nu) end do end do flst = [11, -11, 2, -2, 21, 21] sqme_coll = coll_sub%compute_fsr(5, flst, p_res, p_born, & born, born_c, 0.5_default, 0.25_default, .true.) write (u, "(A,F15.12)") "ME: ", sqme_coll write (u, "(A)") write (u, "(A)") "* Test output end: real_subtraction_1" write (u, "(A)") end subroutine real_subtraction_1 @ %def real_subtraction_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Combining the FKS Pieces} <<[[nlo_data.f90]]>>= <> module nlo_data <> <> use diagnostics use constants, only: zero use string_utils, only: split_string, read_ival, string_contains_word use io_units use lorentz use variables, only: var_list_t use format_defs, only: FMT_15 use physics_defs, only: THR_POS_WP, THR_POS_WM use physics_defs, only: THR_POS_B, THR_POS_BBAR use physics_defs, only: NO_FACTORIZATION, FACTORIZATION_THRESHOLD <> <> <> <> <> contains <> end module nlo_data @ %def nlo_data @ <>= integer, parameter, public :: FKS_DEFAULT = 1 integer, parameter, public :: FKS_RESONANCES = 2 integer, dimension(2), parameter, public :: ASSOCIATED_LEG_PAIR = [1, 3] @ %def parameters @ <>= public :: fks_template_t <>= type :: fks_template_t logical :: subtraction_disabled = .false. integer :: mapping_type = FKS_DEFAULT logical :: count_kinematics = .false. real(default) :: fks_dij_exp1 real(default) :: fks_dij_exp2 real(default) :: xi_min real(default) :: y_max real(default) :: xi_cut, delta_zero, delta_i type(string_t), dimension(:), allocatable :: excluded_resonances integer :: n_f contains <> end type fks_template_t @ %def fks_template_t @ <>= procedure :: write => fks_template_write <>= subroutine fks_template_write (template, unit) class(fks_template_t), intent(in) :: template integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u,'(1x,A)') 'FKS Template: ' write (u,'(1x,A)', advance = 'no') 'Mapping Type: ' select case (template%mapping_type) case (FKS_DEFAULT) write (u,'(A)') 'Default' case (FKS_RESONANCES) write (u,'(A)') 'Resonances' case default write (u,'(A)') 'Unkown' end select write (u,'(1x,A,ES4.3,ES4.3)') 'd_ij exponentials: ', & template%fks_dij_exp1, template%fks_dij_exp2 write (u, '(1x,A,ES4.3,ES4.3)') 'xi_cut: ', & template%xi_cut write (u, '(1x,A,ES4.3,ES4.3)') 'delta_zero: ', & template%delta_zero write (u, '(1x,A,ES4.3,ES4.3)') 'delta_i: ', & template%delta_i end subroutine fks_template_write @ %def fks_template_write @ Set FKS parameters. $\xi_{\text{cut}}, \delta_0$ and $\delta_{\mathrm{I}}$ steer the ratio of the integrated and real subtraction. <>= procedure :: set_parameters => fks_template_set_parameters <>= subroutine fks_template_set_parameters (template, exp1, exp2, xi_min, & y_max, xi_cut, delta_zero, delta_i) class(fks_template_t), intent(inout) :: template real(default), intent(in) :: exp1, exp2 real(default), intent(in) :: xi_min, y_max, & xi_cut, delta_zero, delta_i template%fks_dij_exp1 = exp1 template%fks_dij_exp2 = exp2 template%xi_min = xi_min template%y_max = y_max template%xi_cut = xi_cut template%delta_zero = delta_zero template%delta_i = delta_i end subroutine fks_template_set_parameters @ %def fks_template_set_parameters <>= procedure :: set_mapping_type => fks_template_set_mapping_type <>= subroutine fks_template_set_mapping_type (template, val) class(fks_template_t), intent(inout) :: template integer, intent(in) :: val template%mapping_type = val end subroutine fks_template_set_mapping_type @ %def fks_template_set_mapping_type @ <>= procedure :: set_counter => fks_template_set_counter <>= subroutine fks_template_set_counter (template) class(fks_template_t), intent(inout) :: template template%count_kinematics = .true. end subroutine fks_template_set_counter @ %def fks_template_set_counter @ <>= public :: real_scales_t <>= type :: real_scales_t real(default) :: scale real(default) :: ren_scale real(default) :: fac_scale real(default) :: scale_born real(default) :: fac_scale_born real(default) :: ren_scale_born end type real_scales_t @ %def real_scales_t @ <>= public :: get_threshold_momenta <>= function get_threshold_momenta (p) result (p_thr) type(vector4_t), dimension(4) :: p_thr type(vector4_t), intent(in), dimension(:) :: p p_thr(1) = p(THR_POS_WP) + p(THR_POS_B) p_thr(2) = p(THR_POS_B) p_thr(3) = p(THR_POS_WM) + p(THR_POS_BBAR) p_thr(4) = p(THR_POS_BBAR) end function get_threshold_momenta @ %def get_threshold_momenta @ \subsection{Putting it together} <>= public :: nlo_settings_t <>= type :: nlo_settings_t logical :: use_internal_color_correlations = .true. logical :: use_internal_spin_correlations = .false. logical :: use_resonance_mappings = .false. logical :: combined_integration = .false. logical :: fixed_order_nlo = .false. logical :: test_soft_limit = .false. logical :: test_coll_limit = .false. logical :: test_anti_coll_limit = .false. integer, dimension(:), allocatable :: selected_alr integer :: factorization_mode = NO_FACTORIZATION !!! Probably not the right place for this. Revisit after refactoring real(default) :: powheg_damping_scale = zero type(fks_template_t) :: fks_template type(string_t) :: virtual_selection logical :: virtual_resonance_aware_collinear = .true. logical :: use_born_scale = .true. logical :: cut_all_sqmes = .true. type(string_t) :: nlo_correction_type contains <> end type nlo_settings_t @ %def nlo_settings_t @ <>= procedure :: init => nlo_settings_init <>= subroutine nlo_settings_init (nlo_settings, var_list, fks_template) class(nlo_settings_t), intent(inout) :: nlo_settings type(var_list_t), intent(in) :: var_list type(fks_template_t), intent(in), optional :: fks_template type(string_t) :: color_method if (present (fks_template)) nlo_settings%fks_template = fks_template color_method = var_list%get_sval (var_str ('$correlation_me_method')) if (color_method == "") color_method = var_list%get_sval (var_str ('$method')) nlo_settings%use_internal_color_correlations = color_method == 'omega' & .or. color_method == 'threshold' nlo_settings%combined_integration = var_list%get_lval & (var_str ("?combined_nlo_integration")) nlo_settings%fixed_order_nlo = var_list%get_lval & (var_str ("?fixed_order_nlo_events")) nlo_settings%test_soft_limit = var_list%get_lval (var_str ('?test_soft_limit')) nlo_settings%test_coll_limit = var_list%get_lval (var_str ('?test_coll_limit')) nlo_settings%test_anti_coll_limit = var_list%get_lval (var_str ('?test_anti_coll_limit')) call setup_alr_selection () nlo_settings%virtual_selection = var_list%get_sval (var_str ('$virtual_selection')) nlo_settings%virtual_resonance_aware_collinear = & var_list%get_lval (var_str ('?virtual_collinear_resonance_aware')) nlo_settings%powheg_damping_scale = & var_list%get_rval (var_str ('powheg_damping_scale')) nlo_settings%use_born_scale = & var_list%get_lval (var_str ("?nlo_use_born_scale")) nlo_settings%cut_all_sqmes = & var_list%get_lval (var_str ("?nlo_cut_all_sqmes")) nlo_settings%nlo_correction_type = var_list%get_sval (var_str ('$nlo_correction_type')) contains subroutine setup_alr_selection () type(string_t) :: alr_selection type(string_t), dimension(:), allocatable :: alr_split integer :: i, i1, i2 alr_selection = var_list%get_sval (var_str ('$select_alpha_regions')) if (string_contains_word (alr_selection, var_str (","))) then call split_string (alr_selection, var_str (","), alr_split) allocate (nlo_settings%selected_alr (size (alr_split))) do i = 1, size (alr_split) nlo_settings%selected_alr(i) = read_ival(alr_split(i)) end do else if (string_contains_word (alr_selection, var_str (":"))) then call split_string (alr_selection, var_str (":"), alr_split) if (size (alr_split) == 2) then i1 = read_ival (alr_split(1)) i2 = read_ival (alr_split(2)) allocate (nlo_settings%selected_alr (i2 - i1 + 1)) do i = 1, i2 - i1 + 1 nlo_settings%selected_alr(i) = read_ival (alr_split(i)) end do else call msg_fatal ("select_alpha_regions: ':' specifies a range!") end if else if (len(alr_selection) == 1) then allocate (nlo_settings%selected_alr (1)) nlo_settings%selected_alr(1) = read_ival (alr_selection) end if if (allocated (alr_split)) deallocate (alr_split) end subroutine setup_alr_selection end subroutine nlo_settings_init @ %def nlo_settings_init @ <>= procedure :: write => nlo_settings_write <>= subroutine nlo_settings_write (nlo_settings, unit) class(nlo_settings_t), intent(in) :: nlo_settings integer, intent(in), optional :: unit integer :: i, u u = given_output_unit (unit); if (u < 0) return write (u, '(A)') 'nlo_settings:' write (u, '(3X,A,L1)') 'internal_color_correlations = ', & nlo_settings%use_internal_color_correlations write (u, '(3X,A,L1)') 'internal_spin_correlations = ', & nlo_settings%use_internal_spin_correlations write (u, '(3X,A,L1)') 'use_resonance_mappings = ', & nlo_settings%use_resonance_mappings write (u, '(3X,A,L1)') 'combined_integration = ', & nlo_settings%combined_integration write (u, '(3X,A,L1)') 'test_soft_limit = ', & nlo_settings%test_soft_limit write (u, '(3X,A,L1)') 'test_coll_limit = ', & nlo_settings%test_coll_limit write (u, '(3X,A,L1)') 'test_anti_coll_limit = ', & nlo_settings%test_anti_coll_limit if (allocated (nlo_settings%selected_alr)) then write (u, '(3x,A)', advance = "no") 'selected alpha regions = [' do i = 1, size (nlo_settings%selected_alr) write (u, '(A,I0)', advance = "no") ",", nlo_settings%selected_alr(i) end do write (u, '(A)') "]" end if write (u, '(3X,A,' // FMT_15 // ')') 'powheg_damping_scale = ', & nlo_settings%powheg_damping_scale write (u, '(3X,A,A)') 'virtual_selection = ', & char (nlo_settings%virtual_selection) write (u, '(3X,A,A)') 'Real factorization mode = ', & char (factorization_mode (nlo_settings%factorization_mode)) contains function factorization_mode (fm) type(string_t) :: factorization_mode integer, intent(in) :: fm select case (fm) case (NO_FACTORIZATION) factorization_mode = var_str ("None") case (FACTORIZATION_THRESHOLD) factorization_mode = var_str ("Threshold") case default factorization_mode = var_str ("Undefined!") end select end function factorization_mode end subroutine nlo_settings_write @ %def nlo_settings_write @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Contribution of divergencies due to PDF Evolution} \begin{itemize} \item arXiv:hep-ph/9512328, (2.1)-(2.5), (4.29)-(4.53) \item arXiv:0709.2092, (2.102)-(2.106) \end{itemize} The parton distrubition densities have to be evaluated at NLO, too. The NLO PDF evolution is given by \begin{equation} \label{eqn:pdf_nlo} f (\bar{x}) = \int_0^1 \int_0^1 dx dz f(x) \Gamma(z) \delta (\bar{x} - x z), \end{equation} where $\Gamma$ are the DGLAP evolution kernels for an $a \to d$ splitting, \begin{equation} \label{eqn:dglap} \Gamma_a^{(d)} = \delta_{ad}\delta(1-x) - \frac{\alpha_s}{2\pi} \left(\frac{1}{\epsilon} P_{ad}(x,0) - K_{ad}(x)\right) + \mathcal{O}(\alpha_s). \end{equation} $K_{ad}$ is a renormalization scheme matching factor, which is exactly zero in $\bar{MS}$. Let the leading-order hadronic cross section be given by \begin{equation} \label{eqn:xsec_hadro_lo} d\sigma^{(0)}(s) = \int dx_\oplus dx_\ominus f_\oplus (x_\oplus) f_\ominus (x_\ominus) d\tilde{\sigma}^{(0)} (x_\oplus x_\ominus s), \end{equation} then the NLO hadronic cross section is \begin{equation} \label{eqn:xsec_hadro_nlo} d\sigma^{(1)}(s) = \int dx_\oplus dx_\ominus dz_\oplus dz_\ominus f_\oplus (x_\oplus) f_\ominus (x_\ominus) \underbrace{\Gamma_\oplus (z_\oplus) \Gamma_\ominus (z_\ominus) d\tilde{\sigma}^{(1)} (z_\oplus z_\ominus s)}_{d\hat{\sigma}^{(1)}}. \end{equation} $d\hat{\sigma}$ is called the subtracted partonic cross section. Expanding in $\alpha_s$ we find \begin{align} d\hat{\sigma}^{(0)}_{ab}(k_1, k_2) &= d\tilde{\sigma}_{ab}^{(0)} (k_1, k_2), \\ d\hat{\sigma}^{(1)}_{ab}(k_1, k_2) &= d\tilde{\sigma}_{ab}^{(1)} (k_1, k_2) \\ &+ \frac{\alpha_s}{2\pi} \sum_d \int dx \left (\frac{1}{\epsilon} P_{da}(x,0) - K_{da}(x)\right) d\tilde{\sigma}_{db}^{(0)}(xk_1, k_2)\\ &+ \frac{\alpha_s}{2\pi} \sum_d \int \left (\frac{1}{\epsilon} P_{db} (x, 0) - K_{db}(x)\right) d\tilde{\sigma}_{ad}^{(0)}(k_1, xk_2).\\ &= d\tilde{\sigma}_{ab}^{(1)} + d\tilde{\sigma}_{ab}^{(cnt,+)} + d\tilde{\sigma}_{ab}^{(cnt,-)} \end{align} Let us now turn the soft-subtracted real part of the cross section. For ease of notation, it is constrained to one singular region, \begin{align*} \label{eqn:R-in} d\sigma^{(in)}_\alpha &= \left[\left(\frac{1}{\xi}\right)_{c} - 2\epsilon\left(\frac{\log \xi}{\xi}\right)_{c}\right] (1-y^2)\xi^2 \mathcal{R}_\alpha \mathcal{S}_\alpha \\ &\times \frac{1}{2(2\pi)^{3-2\epsilon}} \left(\frac{\sqrt{s}}{2}\right)^{2-2\epsilon} \left( 1 - y^2\right)^{-1-\epsilon} d\phi d\xi dy d\Omega^{2-2\epsilon}, \end{align*} where we regularize collinear divergencies using the identity \begin{equation*} \left (1 - y^2 \right)^{-1-\epsilon} = -\frac{2^{-\epsilon}}{\epsilon} \left (\delta(1-y) + \delta(1+y)\right) + \underbrace{\frac{1}{2} \left[ \left (\frac {1}{1-y}\right)_{c} + \left (\frac{1}{1+y}\right)_{c} \right]}_{\mathcal{P}(y)}. \end{equation*} This enables us to split the cross section into a finite and a singular part. The latter can further be separated into a contribution of the incoming and of the outgoing particles, \begin{equation*} d\sigma^{(in)}_\alpha = d\sigma^{(in,+)}_\alpha + d\sigma^{(in,-)}_\alpha + d\sigma^{(in,f)}_\alpha. \end{equation*} They are given by \begin{align} \label{eqn:sigma-f} d\sigma^{(in,f)}_\alpha = & \mathcal{P}(y) \left[\left(\frac{1}{\xi}\right)_{c} - 2\epsilon \left(\frac{\log\xi}{\xi}\right)_{c}\right] \frac{1}{2(2\pi)^{3-2\epsilon}} \left(\frac{\sqrt{s}}{2}\right)^{2-2\epsilon} \\ & \times (1-y^2)\xi^2 \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy d\Omega^{2-2\epsilon} \end{align} and \begin{align} \label{eqn:sigma-pm} d\sigma^{(in,\pm)}_\alpha &= -\frac{2^{-\epsilon}}{\epsilon} \delta (1 \mp y) \left[ \left( \frac{1}{\xi}\right)_{c} - 2\epsilon \left(\frac{\log\xi}{\xi}\right)_{c}\right] \\ & \times \frac{1}{2(2\pi)^{3-2\epsilon}} \left( \frac{\sqrt{s}}{2}\right)^{2-2\epsilon} (1-y^2)\xi^2 \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy d\Omega^{2-2\epsilon}. \end{align} Equation \ref{eqn:sigma-f} is the contribution to the real cross section which is computed in [[evaluate_region_isr]]. It is regularized both in the soft and collinear limit via the plus distributions. Equation \ref{eqn:sigma-pm} is a different contribution. It is only present exactly in the collinear limit, due to the delta function. The divergences present in this term do not completely cancel out divergences in the virtual matrix element, because the beam axis is distinguished. Thus, the conditions in which the KLM theorem applies are not met. To see this, we carry out the collinear limit, obtaining \begin{equation*} \lim_{y \to 1} (1-y^2)\xi^2\mathcal{R}_\alpha = 8\pi\alpha_s \mu^{2\epsilon} \left(\frac{2}{\sqrt{s}}\right)^2 \xi P^<(1-\xi, \epsilon) \mathcal{R}_\alpha, \end{equation*} with the Altarelli-Parisi splitting kernel for $z < 1$, $P^<(z,\epsilon)$. Moreover, $\lim_{\vec{k} \parallel \vec{k}_1} d\phi = d\phi_3$ violates spatial averaging. The integration over the spherical angle $d\Omega$ can be carried out easily, yielding a factor of $2\pi^{1-\epsilon} / \Gamma(1-\epsilon)$. This allows us to redefine $\epsilon$, \begin{equation} \frac{1}{\epsilon} - \gamma_E + \log(4\pi) \to \frac{1}{\epsilon}. \end{equation} In order to make a connection to $d\tilde{\sigma}^{(cnt,\pm)}$, we relate $P_{ab}(z,0)$ to $P^<_{ab}(z,0)$ via the equation \begin{equation*} P_{ab}(z,0) = (1-z)P_{ab}^<(z,0)\left(\frac{1}{1-z}\right)_+ + \gamma(a)\delta_{ab}\delta(1-z), \end{equation*} which yields \begin{equation} d\tilde{\sigma}^{(cnt,+)} = \frac{\alpha_s}{2\pi} \sum_d \left\lbrace -K_{da}(1-\xi) + \frac{1}{\epsilon} \left[\left(\frac{1}{\xi}\right)_+ \xi P_{da}^<(1-\xi,0) + \delta_{da}\delta(\xi)\gamma(d)\right]\right\rbrace \mathcal{R}_\alpha \mathcal{S}_\alpha. \end{equation} This term has the same pole structure as eqn. \ref{eqn:sigma-pm}. This makes clear that the quantity \begin{equation} d\hat{\sigma}^{(in,+)} = d\tilde{\sigma}^{(in,+)} + \frac{1}{4} d\tilde{\sigma}^{(cnt,+)} \end{equation} has no collinear poles. Therefore, our task is to add up eqns. \ref{eqn:sigma-pm} and \ref{???} in order to compute the finite remainder. This is the integrand which is evaluated in the [[dglap_remnant]] component.\\ So, we have to perform an expansion of $d\hat{\sigma}^{(in,+)}$ in $\epsilon$. Hereby, we must not neglect the implicit $\epsilon$-dependence of $P^<$, which leads to additional terms involving the first derivative, \begin{equation*} P_{ab}^<(z,\epsilon) = P_{ab}^<(z,0) + \epsilon \frac{\partial P_{ab}^<(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} + \mathcal{O}(\alpha_s^2). \end{equation*} This finally gives us the equation for the collinear remnant. Note that there is still one soft $1/\epsilon$-pole, which cancels out with the corresponding expression in the soft-virtual terms. \begin{align} d\hat{\sigma}^{(in,+)} &= \frac{\alpha_s}{2\pi} \frac{1}{\epsilon} \gamma(a) \mathcal{R}_\alpha \mathcal{S}_\alpha \\ &+ \frac{\alpha_s}{2\pi} \sum_d \left\lbrace (1-z) P_{da}^<(z,0)\left[\left(\frac{1}{1-z}\right)_{c} \log\frac{s\delta_{\mathrm{I}}}{\mu^2} + 2 \left(\frac{\log(1-z)}{1-z}\right)_{c}\right] \right .\\ &\left . -(1-z)\frac{\partial P_{da}^<(z,\epsilon)}{\partial \epsilon} \left(\frac{1}{1-z}\right)_{c} - K_{da}(z)\right\rbrace \mathcal{R}_\alpha \mathcal{S}_\alpha \end{align} <<[[dglap_remnant.f90]]>>= <> module dglap_remnant <> <> use numeric_utils use diagnostics use constants use physics_defs use pdg_arrays use phs_fks, only: isr_kinematics_t use nlo_data <> <> <> contains <> end module dglap_remnant @ %def module dglap_remnant @ <>= public :: dglap_remnant_t <>= type :: dglap_remnant_t type(nlo_settings_t), pointer :: settings => null () type(isr_kinematics_t), pointer :: isr_kinematics => null () integer, dimension(:), allocatable :: light_quark_flv integer, dimension(:,:), allocatable :: flv_in real(default), dimension(:), allocatable :: sqme_born real(default), dimension(:,:,:), allocatable :: sqme_coll_isr integer :: n_flv contains <> end type dglap_remnant_t @ %def dglap_remnant_t @ <>= procedure :: init => dglap_remnant_init <>= subroutine dglap_remnant_init (dglap, settings, n_flv_born, isr_kinematics, flv, n_alr) class(dglap_remnant_t), intent(inout) :: dglap type(nlo_settings_t), intent(in), target :: settings integer, intent(in) :: n_flv_born type(isr_kinematics_t), intent(in), target :: isr_kinematics integer, dimension(:,:), intent(in) :: flv integer, intent(in) :: n_alr integer :: i, j, n_quarks logical, dimension(-6:6) :: quark_checked dglap%settings => settings quark_checked = .false. allocate (dglap%sqme_born(n_flv_born)) dglap%sqme_born = zero allocate (dglap%sqme_coll_isr(2, 2, n_flv_born)) dglap%sqme_coll_isr = zero dglap%isr_kinematics => isr_kinematics dglap%n_flv = size (flv, dim=2) allocate (dglap%flv_in (2, dglap%n_flv)) dglap%flv_in = flv n_quarks = 0 do i = 1, size (flv, dim = 1) if (is_quark(flv(i,1))) then n_quarks = n_quarks + 1 quark_checked(flv(i, 1)) = .true. end if end do allocate (dglap%light_quark_flv (n_quarks)) j = 1 do i = -6, 6 if (quark_checked(i)) then dglap%light_quark_flv(j) = i j = j + 1 end if end do end subroutine dglap_remnant_init @ %def dglap_remnant_init @ <>= procedure :: get_pdf_singlet => dglap_remnant_get_pdf_singlet <>= function dglap_remnant_get_pdf_singlet (dglap, emitter) result (sum_sqme) real(default) :: sum_sqme class(dglap_remnant_t), intent(in) :: dglap integer, intent(in) :: emitter integer :: i_flv integer, parameter :: PDF_SINGLET = 2 sum_sqme = zero do i_flv = 1, size (dglap%sqme_coll_isr, dim=3) if (any (dglap%flv_in(emitter, i_flv) == dglap%light_quark_flv)) & sum_sqme = sum_sqme + dglap%sqme_coll_isr (emitter, PDF_SINGLET, i_flv) end do end function dglap_remnant_get_pdf_singlet @ %def dglap_remnant_get_summed_quark_sqmes @ Evaluates formula (...). Note that, as also is the case for the real subtraction, we have to take into account an additional term, occuring because the integral the plus distribution is evaluated over is not constrained on the interval $[0,1]$. Explicitly, this means (see JHEP 06(2010)043, (4.11)-(4.12)) \begin{align} \int_{\bar{x}_\oplus}^1 dz \left( \frac{1}{1-z} \right)_{\xi_{\text{cut}}} & = \log \frac{1-\bar{x}_\oplus}{\xi_{\text{cut}}} f(1) + \int_{\bar{x}_\oplus}^1 \frac{f(z) - f(1)}{1-z}, \\ \int_{\bar{x}_\oplus}^1 dz \left(\frac{\log(1-z)}{1-z}\right)_{\xi_{\text{cut}}} f(z) & = \frac{1}{2}\left( \log^2(1-\bar{x}_\oplus) - \log^2 (\xi_{\text{cut}}) \right)f(1) + \int_{\bar{x}_\oplus}^1 \frac{\log(1-z)[f(z) - f(1)]}{1-z}, \end{align} and the same of course for $\bar{x}_\ominus$. These two terms are stored in the [[plus_dist_remnant]] variable below. <>= procedure :: evaluate => dglap_remnant_evaluate <>= subroutine dglap_remnant_evaluate (dglap, alpha_s, separate_alrs, sqme_dglap) class(dglap_remnant_t), intent(inout) :: dglap real(default), intent(in) :: alpha_s logical, intent(in) :: separate_alrs real(default), intent(inout), dimension(:) :: sqme_dglap real(default) :: factor, factor_soft, plus_dist_remnant integer :: i_flv, ii_flv, emitter real(default), dimension(2) :: tmp real(default) :: sb, xb, onemz real(default) :: fac_scale2, jac real(default) :: sqme_scaled integer, parameter :: PDF = 1, PDF_SINGLET = 2 sb = dglap%isr_kinematics%sqrts_born**2 fac_scale2 = dglap%isr_kinematics%fac_scale**2 do i_flv = 1, dglap%n_flv if (separate_alrs) then ii_flv = i_flv else ii_flv = 1 end if tmp = zero do emitter = 1, 2 associate (z => dglap%isr_kinematics%z(emitter), template => dglap%settings%fks_template) jac = dglap%isr_kinematics%jacobian(emitter) onemz = one - z factor = log (sb * template%delta_i / two / z / fac_scale2) / & onemz + two * log (onemz) / onemz factor_soft = log (sb * template%delta_i / two / fac_scale2) / & onemz + two * log (onemz) / onemz xb = dglap%isr_kinematics%x(emitter) - ! TODO sbrass rescale xi_cut to [0, xi_max] plus_dist_remnant = log ((one - xb) / template%xi_cut) * log (sb * template%delta_i / & two / fac_scale2) + (log (one - xb)**2 - log (template%xi_cut)**2) if (is_gluon(dglap%flv_in(emitter, i_flv))) then sqme_scaled = dglap%sqme_coll_isr(emitter, PDF, i_flv) tmp(emitter) = p_hat_gg(z) * factor / z * sqme_scaled * jac & - p_hat_gg(one) * factor_soft * dglap%sqme_born(i_flv) * jac & + p_hat_gg(one) * plus_dist_remnant * dglap%sqme_born(i_flv) tmp(emitter) = tmp(emitter) + & (p_hat_qg(z) * factor - p_derived_qg(z)) / z * jac * & dglap%get_pdf_singlet (emitter) else if (is_quark(dglap%flv_in(emitter, i_flv))) then sqme_scaled = dglap%sqme_coll_isr(emitter, PDF, i_flv) tmp(emitter) = p_hat_qq(z) * factor / z * sqme_scaled * jac & - p_derived_qq(z) / z * sqme_scaled * jac & - p_hat_qq(one) * factor_soft * dglap%sqme_born(i_flv) * jac & + p_hat_qq(one) * plus_dist_remnant * dglap%sqme_born(i_flv) sqme_scaled = dglap%sqme_coll_isr(emitter, PDF_SINGLET, i_flv) tmp(emitter) = tmp(emitter) + & (p_hat_gq(z) * factor - p_derived_gq(z)) / z * sqme_scaled * jac end if end associate end do sqme_dglap(ii_flv) = sqme_dglap(ii_flv) + alpha_s / twopi * (tmp(1) + tmp(2)) end do contains <> end subroutine dglap_remnant_evaluate @ %def dglap_remnant_evaluate @ We introduce $\hat{P}(z, \epsilon) = (1 - z) P(z, \epsilon)$ and have \begin{align} \hat{P}^{gg}(z) & = 2C_A \left[z + \frac{(1-z)^2}{z} + z(1-z)^2\right], \\ \hat{P}^{qg}(z) & = C_F (1-z) \frac{1 + (1-z)^2}{z}, \\ \hat{P}^{gq}(z) & = T_F (1 - z - 2z(1-z)^2), \\ \hat{P}^{qq}(z) & = C_F (1 + z^2). \end{align} <>= function p_hat_gg (z) real(default) :: p_hat_gg <

> p_hat_gg = two * CA * (z + onemz**2 / z + z * onemz**2) end function p_hat_gg function p_hat_qg (z) real(default) :: p_hat_qg <

> p_hat_qg = CF * onemz / z * (one + onemz**2) end function p_hat_qg function p_hat_gq (z) real(default) :: p_hat_gq <

> p_hat_gq = TR * (onemz - two * z * onemz**2) end function p_hat_gq function p_hat_qq (z) real(default) :: p_hat_qq real(default), intent(in) :: z p_hat_qq = CF * (one + z**2) end function p_hat_qq @ %def p_hat_qq, p_hat_gq, p_hat_qg, p_hat_gg @ \begin{align} \frac{\partial P^{gg}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = 0, \\ \frac{\partial P^{qg}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -C_F z, \\ \frac{\partial P^{gq}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = - 2 T_F z (1-z), \\ \frac{\partial P^{gq}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -C_F (1-z).\\ \end{align} <>= function p_derived_gg (z) real(default) :: p_derived_gg real(default), intent(in) :: z p_derived_gg = zero end function p_derived_gg function p_derived_qg (z) real(default) :: p_derived_qg real(default), intent(in) :: z p_derived_qg = -CF * z end function p_derived_qg function p_derived_gq (z) real(default) :: p_derived_gq <

> p_derived_gq = -two * TR * z * onemz end function p_derived_gq function p_derived_qq (z) real(default) :: p_derived_qq <

> p_derived_qq = -CF * onemz end function p_derived_qq @ %def p_derived_gg, p_derived_qg, p_derived_gq, p_derived_qq @ <

>= real(default), intent(in) :: z real(default) :: onemz onemz = one - z @ %def variables @ <>= procedure :: final => dglap_remnant_final <>= subroutine dglap_remnant_final (dglap) class(dglap_remnant_t), intent(inout) :: dglap if (associated (dglap%isr_kinematics)) nullify (dglap%isr_kinematics) if (allocated (dglap%light_quark_flv)) deallocate (dglap%light_quark_flv) if (allocated (dglap%sqme_born)) deallocate (dglap%sqme_born) if (allocated (dglap%sqme_coll_isr)) deallocate (dglap%sqme_coll_isr) end subroutine dglap_remnant_final @ %def dglap_remnant_final @ \subsection{Rescaling function} NLO applications require that the beam energy fractions can be recomputed flexibly for different components of the calculation, e.g. in the collinear subtraction. To deal with this, we use a rescaling function which is given to [[sf_int_apply]] as an optional argument to use a different set of [[x]] values. <<[[isr_collinear.f90]]>>= <> module isr_collinear <> <> use diagnostics use constants, only: one, two use physics_defs, only: n_beam_structure_int use sf_base, only: sf_rescale_t <> <> <> contains <> end module isr_collinear @ %def module isr_collinear <>= public :: sf_rescale_collinear_t <>= type, extends (sf_rescale_t) :: sf_rescale_collinear_t real(default) :: xi_tilde contains <> end type sf_rescale_collinear_t @ %def sf_rescale_collinear_t @ <>= procedure :: apply => sf_rescale_collinear_apply <>= subroutine sf_rescale_collinear_apply (func, x) class(sf_rescale_collinear_t), intent(in) :: func real(default), intent(inout) :: x real(default) :: xi if (debug2_active (D_BEAMS)) then print *, 'Rescaling function - Collinear: ' print *, 'Input: ', x print *, 'xi_tilde: ', func%xi_tilde end if xi = func%xi_tilde * (one - x) x = x / (one - xi) if (debug2_active (D_BEAMS)) print *, 'scaled x: ', x end subroutine sf_rescale_collinear_apply @ %def sf_rescale_collinear_apply @ <>= procedure :: set => sf_rescale_collinear_set <>= subroutine sf_rescale_collinear_set (func, xi_tilde) class(sf_rescale_collinear_t), intent(inout) :: func real(default), intent(in) :: xi_tilde func%xi_tilde = xi_tilde end subroutine sf_rescale_collinear_set @ %def sf_rescale_collinear_set @ <>= public :: sf_rescale_real_t <>= type, extends (sf_rescale_t) :: sf_rescale_real_t real(default) :: xi, y contains <> end type sf_rescale_real_t @ %def sf_rescale_real_t @ <>= procedure :: apply => sf_rescale_real_apply <>= subroutine sf_rescale_real_apply (func, x) class(sf_rescale_real_t), intent(in) :: func real(default), intent(inout) :: x real(default) :: onepy, onemy if (debug2_active (D_BEAMS)) then print *, 'Rescaling function - Real: ' print *, 'Input: ', x print *, 'Beam index: ', func%i_beam print *, 'xi: ', func%xi, 'y: ', func%y end if x = x / sqrt (one - func%xi) onepy = one + func%y; onemy = one - func%y if (func%i_beam == 1) then x = x * sqrt ((two - func%xi * onemy) / (two - func%xi * onepy)) else if (func%i_beam == 2) then x = x * sqrt ((two - func%xi * onepy) / (two - func%xi * onemy)) else call msg_fatal ("sf_rescale_real_apply - invalid beam index") end if if (debug2_active (D_BEAMS)) print *, 'scaled x: ', x end subroutine sf_rescale_real_apply @ %def sf_rescale_real_apply @ <>= procedure :: set => sf_rescale_real_set <>= subroutine sf_rescale_real_set (func, xi, y) class(sf_rescale_real_t), intent(inout) :: func real(default), intent(in) :: xi, y func%xi = xi; func%y = y end subroutine sf_rescale_real_set @ %def sf_rescale_real_set <>= public :: sf_rescale_dglap_t <>= type, extends(sf_rescale_t) :: sf_rescale_dglap_t real(default), dimension(:), allocatable :: z contains <> end type sf_rescale_dglap_t @ %def sf_rescale_dglap_t @ <>= procedure :: apply => sf_rescale_dglap_apply <>= subroutine sf_rescale_dglap_apply (func, x) class(sf_rescale_dglap_t), intent(in) :: func real(default), intent(inout) :: x if (debug2_active (D_BEAMS)) then print *, "Rescaling function - DGLAP:" print *, "Input: ", x print *, "Beam index: ", func%i_beam print *, "z: ", func%z end if x = x / func%z(func%i_beam) if (debug2_active (D_BEAMS)) print *, "scaled x: ", x end subroutine sf_rescale_dglap_apply @ %def sf_rescale_dglap_apply @ <>= procedure :: set => sf_rescale_dglap_set <>= subroutine sf_rescale_dglap_set (func, z) class(sf_rescale_dglap_t), intent(inout) :: func real(default), dimension(:), intent(in) :: z ! allocate-on-assginment func%z = z end subroutine sf_rescale_dglap_set @ %def sf_rescale_dglap_set @ \section{Dispatch} @ <<[[dispatch_fks.f90]]>>= <> module dispatch_fks <> <> use string_utils, only: split_string use variables, only: var_list_t use nlo_data, only: fks_template_t, FKS_DEFAULT, FKS_RESONANCES <> <> contains <> end module dispatch_fks @ %def dispatch_fks @ Initialize parameters used to optimize FKS calculations. <>= public :: dispatch_fks_s <>= subroutine dispatch_fks_s (fks_template, var_list) type(fks_template_t), intent(inout) :: fks_template type(var_list_t), intent(in) :: var_list real(default) :: fks_dij_exp1, fks_dij_exp2 type(string_t) :: fks_mapping_type logical :: subtraction_disabled type(string_t) :: exclude_from_resonance fks_dij_exp1 = & var_list%get_rval (var_str ("fks_dij_exp1")) fks_dij_exp2 = & var_list%get_rval (var_str ("fks_dij_exp2")) fks_mapping_type = & var_list%get_sval (var_str ("$fks_mapping_type")) subtraction_disabled = & var_list%get_lval (var_str ("?disable_subtraction")) exclude_from_resonance = & var_list%get_sval (var_str ("$resonances_exclude_particles")) if (exclude_from_resonance /= var_str ("default")) & call split_string (exclude_from_resonance, var_str (":"), & fks_template%excluded_resonances) call fks_template%set_parameters ( & exp1 = fks_dij_exp1, exp2 = fks_dij_exp2, & xi_min = var_list%get_rval (var_str ("fks_xi_min")), & y_max = var_list%get_rval (var_str ("fks_y_max")), & xi_cut = var_list%get_rval (var_str ("fks_xi_cut")), & delta_zero = var_list%get_rval (var_str ("fks_delta_zero")), & delta_i = var_list%get_rval (var_str ("fks_delta_i"))) select case (char (fks_mapping_type)) case ("default") call fks_template%set_mapping_type (FKS_DEFAULT) case ("resonances") call fks_template%set_mapping_type (FKS_RESONANCES) end select fks_template%subtraction_disabled = subtraction_disabled fks_template%n_f = var_list%get_ival (var_str ("alphas_nf")) end subroutine dispatch_fks_s @ %def dispatch_fks_s @ Index: trunk/src/particles/particles.nw =================================================================== --- trunk/src/particles/particles.nw (revision 8234) +++ trunk/src/particles/particles.nw (revision 8235) @@ -1,8385 +1,8377 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: particle objects %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Particles} \includemodulegraph{particles} This chapter collects modules that implement particle objects, for use in event records. While within interactions, all correlations are manifest, a particle array is derived by selecting a particular quantum number set. This involves tracing over all other particles, as far as polarization is concerned. Thus, a particle has definite flavor, color, and a single-particle density matrix for polarization. \begin{description} \item[su\_algebra] We make use of $su(N)$ generators as the basis for representing polarization matrices. This module defines the basis and provides the necessary transformation routines. \item[bloch\_vectors] This defines polarization objects in Bloch representation. The object describes the spin density matrix of a particle, currently restricted to spin $0\ldots 2$. \item[polarizations] This extends the basic polarization object such that it supports properties of physical particles and appropriate constructors. \item[particles] Particle objects and particle lists, as the base of event records. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{$su(N)$ Algebra} We need a specific choice of basis for a well-defined component representation. The matrix elements of $T^a$ are ordered as $m=\ell,\ell-1,\ldots -\ell$, i.e., from highest down to lowest weight, for both row and column. We list first the generators of the $su(2)$ subalgebras which leave $|m|$ invariant ($|m|\neq 0$): \begin{equation} T^{b+1,b+2,b+3} \equiv \sigma^{1,2,3} \end{equation} acting on the respective subspace $|m|=\ell,\ell-1,\ldots$ for $b=0,1,\ldots$. This defines generators $T^a$ for $a=1,\ldots 3N/2$ ($\ldots 3(N-1)/2$) for $N$ even (odd), respectively. The following generators successively extend this to $su(4)$, $su(6)$, \ldots until $su(N)$ by adding first the missing off-diagonal and then diagonal generators. The phase conventions are analogous. (It should be possible to code these conventions for generic spin, but in the current implementation we restrict ourselves to $s\leq 2$, i.e., $N\leq 5$.) <<[[su_algebra.f90]]>>= <> module su_algebra <> use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR <> <> contains <> end module su_algebra @ %def su_algebra @ \subsection{$su(N)$ fundamental representation} The dimension of the basis for a given spin type. consecutively, starting at [[SCALAR=1]]. <>= public :: algebra_dimension <>= function algebra_dimension (s) result (n) integer :: n integer, intent(in) :: s n = fundamental_dimension (s) ** 2 - 1 end function algebra_dimension @ %def algebra_dimension @ The dimension of the fundamental (defining) representation that we use. This implementation assumes that the spin type is numerically equal to the fundamental dimension. <>= public :: fundamental_dimension <>= function fundamental_dimension (s) result (d) integer :: d integer, intent(in) :: s d = s end function fundamental_dimension @ %def fundamental_dimension @ \subsection{Mapping between helicity and matrix index} Return the helicity that corresponds to a particular entry in the polarization matrix representation. Helicities are counted downwards, in integers, and zero helicity is included (omitted) for odd (even) spin, respectively. <>= public :: helicity_value <>= function helicity_value (s, i) result (h) integer :: h integer, intent(in) :: s, i integer, dimension(1), parameter :: hh1 = [0] integer, dimension(2), parameter :: hh2 = [1, -1] integer, dimension(3), parameter :: hh3 = [1, 0, -1] integer, dimension(4), parameter :: hh4 = [2, 1, -1, -2] integer, dimension(5), parameter :: hh5 = [2, 1, 0, -1, -2] h = 0 select case (s) case (SCALAR) select case (i) case (1:1); h = hh1(i) end select case (SPINOR) select case (i) case (1:2); h = hh2(i) end select case (VECTOR) select case (i) case (1:3); h = hh3(i) end select case (VECTORSPINOR) select case (i) case (1:4); h = hh4(i) end select case (TENSOR) select case (i) case (1:5); h = hh5(i) end select end select end function helicity_value @ %def helicity_value @ Inverse: return the index that corresponds to a certain helicity value in the chosen representation. <>= public :: helicity_index <>= function helicity_index (s, h) result (i) integer, intent(in) :: s, h integer :: i integer, dimension(0:0), parameter :: hi1 = [1] integer, dimension(-1:1), parameter :: hi2 = [2, 0, 1] integer, dimension(-1:1), parameter :: hi3 = [3, 2, 1] integer, dimension(-2:2), parameter :: hi4 = [4, 3, 0, 2, 1] integer, dimension(-2:2), parameter :: hi5 = [5, 4, 3, 2, 1] select case (s) case (SCALAR) i = hi1(h) case (SPINOR) i = hi2(h) case (VECTOR) i = hi3(h) case (VECTORSPINOR) i = hi4(h) case (TENSOR) i = hi5(h) end select end function helicity_index @ %def helicity_index @ \subsection{Generator Basis: Cartan Generators} For each supported spin type, we return specific properties of the set of generators via inquiry functions. This is equivalent to using explicit representations of the generators. For easy access, the properties are hard-coded and selected via case expressions. Return true if the generator \#[[i]] is in the Cartan subalgebra, i.e., a diagonal matrix for spin type [[s]]. <>= public :: is_cartan_generator <>= elemental function is_cartan_generator (s, i) result (cartan) logical :: cartan integer, intent(in) :: s, i select case (s) case (SCALAR) case (SPINOR) select case (i) case (3); cartan = .true. case default cartan = .false. end select case (VECTOR) select case (i) case (3,8); cartan = .true. case default cartan = .false. end select case (VECTORSPINOR) select case (i) case (3,6,15); cartan = .true. case default cartan = .false. end select case (TENSOR) select case (i) case (3,6,15,24); cartan = .true. case default cartan = .false. end select case default cartan = .false. end select end function is_cartan_generator @ %def is_cartan_generator @ Return the index of Cartan generator \#[[k]] in the chosen representation. This has to conform to [[cartan]] above. <>= public :: cartan_index <>= elemental function cartan_index (s, k) result (ci) integer :: ci integer, intent(in) :: s, k integer, dimension(1), parameter :: ci2 = [3] integer, dimension(2), parameter :: ci3 = [3,8] integer, dimension(3), parameter :: ci4 = [3,6,15] integer, dimension(4), parameter :: ci5 = [3,6,15,24] select case (s) case (SPINOR) ci = ci2(k) case (VECTOR) ci = ci3(k) case (VECTORSPINOR) ci = ci4(k) case (TENSOR) ci = ci5(k) case default ci = 0 end select end function cartan_index @ %def cartan_index @ The element \#[[k]] of the result vector [[a]] is equal to the $(h,h)$ diagonal entry of the generator matrix $T^k$. That is, evaluating this for all allowed values of [[h]], we recover the set of Cartan generator matrices. <>= public :: cartan_element <>= function cartan_element (s, h) result (a) real(default), dimension(:), allocatable :: a integer, intent(in) :: s, h real(default), parameter :: sqrt2 = sqrt (2._default) real(default), parameter :: sqrt3 = sqrt (3._default) real(default), parameter :: sqrt10 = sqrt (10._default) allocate (a (algebra_dimension (s)), source = 0._default) select case (s) case (SCALAR) case (SPINOR) select case (h) case (1) a(3) = 1._default / 2 case (-1) a(3) = -1._default / 2 end select case (VECTOR) select case (h) case (1) a(3) = 1._default / 2 a(8) = 1._default / (2 * sqrt3) case (-1) a(3) = -1._default / 2 a(8) = 1._default / (2 * sqrt3) case (0) a(8) = -1._default / sqrt3 end select case (VECTORSPINOR) select case (h) case (2) a(3) = 1._default / 2 a(15) = 1._default / (2 * sqrt2) case (-2) a(3) = -1._default / 2 a(15) = 1._default / (2 * sqrt2) case (1) a(6) = 1._default / 2 a(15) = -1._default / (2 * sqrt2) case (-1) a(6) = -1._default / 2 a(15) = -1._default / (2 * sqrt2) end select case (TENSOR) select case (h) case (2) a(3) = 1._default / 2 a(15) = 1._default / (2 * sqrt2) a(24) = 1._default / (2 * sqrt10) case (-2) a(3) = -1._default / 2 a(15) = 1._default / (2 * sqrt2) a(24) = 1._default / (2 * sqrt10) case (1) a(6) = 1._default / 2 a(15) = -1._default / (2 * sqrt2) a(24) = 1._default / (2 * sqrt10) case (-1) a(6) = -1._default / 2 a(15) = -1._default / (2 * sqrt2) a(24) = 1._default / (2 * sqrt10) case (0) a(24) = -4._default / (2 * sqrt10) end select end select end function cartan_element @ %def cartan_element @ Given an array of diagonal matrix elements [[rd]] of a generator, compute the array [[a]] of basis coefficients. The array must be ordered as defined by [[helicity_value]], i.e., highest weight first. The calculation is organized such that the trace of the generator, i.e., the sum of [[rd]] values, drops out. The result array [[a]] has coefficients for all basis generators, but only Cartan generators can get a nonzero coefficient. <>= public :: cartan_coeff <>= function cartan_coeff (s, rd) result (a) real(default), dimension(:), allocatable :: a integer, intent(in) :: s real(default), dimension(:), intent(in) :: rd real(default), parameter :: sqrt2 = sqrt (2._default) real(default), parameter :: sqrt3 = sqrt (3._default) real(default), parameter :: sqrt10 = sqrt (10._default) integer :: n n = algebra_dimension (s) allocate (a (n), source = 0._default) select case (s) case (SPINOR) a(3) = rd(1) - rd(2) case (VECTOR) a(3) = rd(1) - rd(3) a(8) = (rd(1) - 2 * rd(2) + rd(3)) / sqrt3 case (VECTORSPINOR) a(3) = rd(1) - rd(4) a(6) = rd(2) - rd(3) a(15) = (rd(1) - rd(2) - rd(3) + rd(4)) / sqrt2 case (TENSOR) a(3) = rd(1) - rd(5) a(6) = rd(2) - rd(4) a(15) = (rd(1) - rd(2) - rd(4) + rd(5)) / sqrt2 a(24) = (rd(1) + rd(2) - 4 * rd(3) + rd(4) + rd(5)) / sqrt10 end select end function cartan_coeff @ %def cartan_coeff @ \subsection{Roots (Off-Diagonal Generators)} Return the appropriate generator index for a given off-diagonal helicity combination. We require $h_1>h_2$. We return the index of the appropriate real-valued generator if [[r]] is true, else the complex-valued one. This is separate from the [[cartan_coeff]] function above. The reason is that the off-diagonal generators have only a single nonzero matrix element, so there is a one-to-one correspondence of helicity and index. <>= public :: root_index <>= function root_index (s, h1, h2, r) result (ai) integer :: ai integer, intent(in) :: s, h1, h2 logical :: r ai = 0 select case (s) case (SCALAR) case (SPINOR) select case (h1) case (1) select case (h2) case (-1); ai = 1 end select end select case (VECTOR) select case (h1) case (1) select case (h2) case (-1); ai = 1 case (0); ai = 4 end select case (0) select case (h2) case (-1); ai = 6 end select end select case (VECTORSPINOR) select case (h1) case (2) select case (h2) case (-2); ai = 1 case (1); ai = 7 case (-1); ai = 11 end select case (1) select case (h2) case (-1); ai = 4 case (-2); ai = 13 end select case (-1) select case (h2) case (-2); ai = 9 end select end select case (TENSOR) select case (h1) case (2) select case (h2) case (-2); ai = 1 case (1); ai = 7 case (-1); ai = 11 case (0); ai = 16 end select case (1) select case (h2) case (-1); ai = 4 case (-2); ai = 13 case (0); ai = 20 end select case (-1) select case (h2) case (-2); ai = 9 end select case (0) select case (h2) case (-2); ai = 18 case (-1); ai = 22 end select end select end select if (ai /= 0 .and. .not. r) ai = ai + 1 end function root_index @ %def root_index @ Inverse: return the helicity values ($h_2>h_1$) for an off-diagonal generator. The flag [[r]] tells whether this is a real or diagonal generator. The others are Cartan generators. <>= public :: root_helicity <>= subroutine root_helicity (s, i, h1, h2, r) integer, intent(in) :: s, i integer, intent(out) :: h1, h2 logical, intent(out) :: r h1 = 0 h2 = 0 r = .false. select case (s) case (SCALAR) case (SPINOR) select case (i) case ( 1, 2); h1 = 1; h2 = -1; r = i == 1 end select case (VECTOR) select case (i) case ( 1, 2); h1 = 1; h2 = -1; r = i == 1 case ( 4, 5); h1 = 1; h2 = 0; r = i == 4 case ( 6, 7); h1 = 0; h2 = -1; r = i == 6 end select case (VECTORSPINOR) select case (i) case ( 1, 2); h1 = 2; h2 = -2; r = i == 1 case ( 4, 5); h1 = 1; h2 = -1; r = i == 4 case ( 7, 8); h1 = 2; h2 = 1; r = i == 7 case ( 9,10); h1 = -1; h2 = -2; r = i == 9 case (11,12); h1 = 2; h2 = -1; r = i ==11 case (13,14); h1 = 1; h2 = -2; r = i ==13 end select case (TENSOR) select case (i) case ( 1, 2); h1 = 2; h2 = -2; r = i == 1 case ( 4, 5); h1 = 1; h2 = -1; r = i == 4 case ( 7, 8); h1 = 2; h2 = 1; r = i == 7 case ( 9,10); h1 = -1; h2 = -2; r = i == 9 case (11,12); h1 = 2; h2 = -1; r = i ==11 case (13,14); h1 = 1; h2 = -2; r = i ==13 case (16,17); h1 = 2; h2 = 0; r = i ==16 case (18,19); h1 = 0; h2 = -2; r = i ==18 case (20,21); h1 = 1; h2 = 0; r = i ==20 case (22,23); h1 = 0; h2 = -1; r = i ==22 end select end select end subroutine root_helicity @ %def root_helicity @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[su_algebra_ut.f90]]>>= <> module su_algebra_ut use unit_tests use su_algebra_uti <> <> contains <> end module su_algebra_ut @ %def su_algebra_ut @ <<[[su_algebra_uti.f90]]>>= <> module su_algebra_uti <> use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR use su_algebra <> <> contains <> end module su_algebra_uti @ %def su_algebra_ut @ API: driver for the unit tests below. <>= public :: su_algebra_test <>= subroutine su_algebra_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine su_algebra_test @ %def su_algebra_test @ \subsubsection{Generator Ordering} Show the position of Cartan generators in the sequence of basis generators. <>= call test (su_algebra_1, "su_algebra_1", & "generator ordering", & u, results) <>= public :: su_algebra_1 <>= subroutine su_algebra_1 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: su_algebra_1" write (u, "(A)") "* Purpose: test su(N) algebra implementation" write (u, "(A)") write (u, "(A)") "* su(N) generators: & &list and mark Cartan subalgebra" write (u, "(A)") write (u, "(A)") "* s = 0" call cartan_check (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call cartan_check (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call cartan_check (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call cartan_check (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call cartan_check (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: su_algebra_1" contains subroutine cartan_check (s) integer, intent(in) :: s integer :: i write (u, *) do i = 1, algebra_dimension (s) write (u, "(1x,L1)", advance="no") is_cartan_generator (s, i) end do write (u, *) end subroutine cartan_check end subroutine su_algebra_1 @ %def su_algebra_1 @ \subsubsection{Cartan Generator Basis} Show the explicit matrix representation for all Cartan generators and check their traces and Killing products. Also test helicity index mappings. <>= call test (su_algebra_2, "su_algebra_2", & "Cartan generator representation", & u, results) <>= public :: su_algebra_2 <>= subroutine su_algebra_2 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: su_algebra_2" write (u, "(A)") "* Purpose: test su(N) algebra implementation" write (u, "(A)") write (u, "(A)") "* diagonal su(N) generators: & &show explicit representation" write (u, "(A)") "* and check trace and Killing form" write (u, "(A)") write (u, "(A)") "* s = 1/2" call cartan_show (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call cartan_show (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call cartan_show (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call cartan_show (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: su_algebra_2" contains subroutine cartan_show (s) integer, intent(in) :: s real(default), dimension(:,:), allocatable :: rd integer, dimension(:), allocatable :: ci integer :: n, d, h, i, j, k, l n = algebra_dimension (s) d = fundamental_dimension (s) write (u, *) write (u, "(A2,5X)", advance="no") "h:" do i = 1, d j = helicity_index (s, helicity_value (s, i)) write (u, "(1x,I2,5X)", advance="no") helicity_value (s, j) end do write (u, "(8X)", advance="no") write (u, "(1X,A)") "tr" allocate (rd (n,d), source = 0._default) do i = 1, d h = helicity_value (s, i) rd(:,i) = cartan_element (s, h) end do allocate (ci (d-1), source = 0) do k = 1, d-1 ci(k) = cartan_index (s, k) end do write (u, *) do k = 1, d-1 write (u, "('T',I2,':',1X)", advance="no") ci(k) do i = 1, d write (u, 1, advance="no") rd(ci(k),i) end do write (u, "(8X)", advance="no") write (u, 1) sum (rd(ci(k),:)) end do write (u, *) write (u, "(6X)", advance="no") do k = 1, d-1 write (u, "(2X,'T',I2,3X)", advance="no") ci(k) end do write (u, *) do k = 1, d-1 write (u, "('T',I2,2X)", advance="no") ci(k) do l = 1, d-1 write (u, 1, advance="no") dot_product (rd(ci(k),:), rd(ci(l),:)) end do write (u, *) end do 1 format (1x,F7.4) end subroutine cartan_show end subroutine su_algebra_2 @ %def su_algebra_2 @ \subsubsection{Bloch Representation: Cartan Generators} Transform from Bloch vectors to matrix and back, considering Cartan generators only. <>= call test (su_algebra_3, "su_algebra_3", & "Cartan generator mapping", & u, results) <>= public :: su_algebra_3 <>= subroutine su_algebra_3 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: su_algebra_3" write (u, "(A)") "* Purpose: test su(N) algebra implementation" write (u, "(A)") write (u, "(A)") "* diagonal su(N) generators: & &transform to matrix and back" write (u, "(A)") write (u, "(A)") "* s = 1/2" call cartan_expand (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call cartan_expand (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call cartan_expand (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call cartan_expand (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: su_algebra_3" contains subroutine cartan_expand (s) integer, intent(in) :: s real(default), dimension(:,:), allocatable :: rd integer, dimension(:), allocatable :: ci real(default), dimension(:), allocatable :: a logical, dimension(:), allocatable :: mask integer :: n, d, h, i, k, l n = algebra_dimension (s) d = fundamental_dimension (s) allocate (rd (n,d), source = 0._default) do i = 1, d h = helicity_value (s, i) rd(:,i) = cartan_element (s, h) end do allocate (ci (d-1), source = 0) do k = 1, d-1 ci(k) = cartan_index (s, k) end do allocate (a (n)) write (u, *) do k = 1, d-1 a(:) = cartan_coeff (s, rd(ci(k),:)) write (u, "('T',I2,':',1X)", advance="no") ci(k) do i = 1, n if (is_cartan_generator (s, i)) then write (u, 1, advance="no") a(i) else if (a(i) /= 0) then ! this should not happen (nonzero non-Cartan entry) write (u, "(1X,':',I2,':',3X)", advance="no") i end if end do write (u, *) end do 1 format (1X,F7.4) end subroutine cartan_expand end subroutine su_algebra_3 @ %def su_algebra_3 @ \subsubsection{Bloch Representation: Roots} List the mapping between helicity transitions and (real) off-diagonal generators. <>= call test (su_algebra_4, "su_algebra_4", & "Root-helicity mapping", & u, results) <>= public :: su_algebra_4 <>= subroutine su_algebra_4 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: su_algebra_4" write (u, "(A)") "* Purpose: test su(N) algebra implementation" write (u, "(A)") write (u, "(A)") "* off-diagonal su(N) generators: & &mapping from/to helicity pair" write (u, "(A)") write (u, "(A)") "* s = 1/2" call root_expand (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call root_expand (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call root_expand (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call root_expand (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: su_algebra_4" contains subroutine root_expand (s) integer, intent(in) :: s integer :: n, d, i, j, h1, h2 logical :: r n = algebra_dimension (s) write (u, *) do i = 1, n if (is_cartan_generator (s, i)) cycle call root_helicity (s, i, h1, h2, r) j = root_index (s, h1, h2, r) write (u, "('T',I2,':')", advance="no") j write (u, "(2(1x,I2))", advance="no") h1, h2 if (r) then write (u, *) else write (u, "('*')") end if end do end subroutine root_expand end subroutine su_algebra_4 @ %def su_algebra_4 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Bloch Representation} Particle polarization is determined by a particular quantum state which has just helicity information. Physically, this is the spin density matrix $\rho$, where we do not restrict ourselves to pure states. We adopt the phase convention for a spin-1/2 particle that \begin{equation} \rho = \tfrac12(1 + \vec\alpha\cdot\vec\sigma) \end{equation} with the polarization axis $\vec\alpha$. For a particle with arbitrary spin $s$, and thus $N=2s+1$ spin states, we extend the above definition to generalized Bloch form \begin{equation} \rho = \frac1N\left(1 + \sqrt{2N(N-1)}\alpha^aT^a\right) \end{equation} where the $T^a$ ($a=1,\ldots N^2-1$) are a basis of $su(N)$ algebra generators. These $N\times N$ matrices are hermitean, traceless, and orthogonal via \begin{equation} \mathop{\rm Tr}T^aT^b = \frac12 \delta^{ab} \end{equation} In the spin-1/2 case, this reduces to the above (standard Bloch) representation since $T^a = \sigma^a/2$, $a=1,2,3$. For the spin-1 case, we could use $T^a = \lambda^a/2$ with the Gell-Mann matrices, \begin{equation} \rho = \frac13\left(1 + \sqrt{3}\alpha^a\lambda^a\right), \end{equation} The normalization is chosen that $|alpha|\leq 1$ for allowed density matrix, where $|\alpha|=1$ is a necessary, but not sufficient, condition for a pure state. We need a specific choice of basis for a well-defined component representation. The matrix elements of $T^a$ are ordered as $m=\ell,\ell-1,\ldots -\ell$, i.e., from highest down to lowest weight, for both row and column. We list first the generators of the $su(2)$ subalgebras which leave $|m|$ invariant ($|m|\neq 0$): \begin{equation} T^{b+1,b+2,b+3} \equiv \sigma^{1,2,3} \end{equation} acting on the respective subspace $|m|=\ell,\ell-1,\ldots$ for $b=0,1,\ldots$. This defines generators $T^a$ for $a=1,\ldots 3N/2$ ($\ldots 3(N-1)/2$) for $N$ even (odd), respectively. The following generators successively extend this to $su(4)$, $su(6)$, \ldots until $su(N)$ by adding first the missing off-diagonal and then diagonal generators. The phase conventions are analogous. (It should be possible to code these conventions for generic spin, but in the current implementation we restrict ourselves to $s\leq 2$, i.e., $N\leq 5$.) Particle polarization is determined by a particular quantum state which has just helicity information. Physically, this is the spin density matrix $\rho$, where we do not restrict ourselves to pure states. We adopt the phase convention for a spin-1/2 particle that \begin{equation} \rho = \tfrac12(1 + \vec\alpha\cdot\vec\sigma) \end{equation} with the polarization axis $\vec\alpha$. For a particle with arbitrary spin $s$, and thus $N=2s+1$ spin states, we extend the above definition to generalized Bloch form \begin{equation} \rho = \frac1N\left(1 + \sqrt{2N(N-1)}\alpha^aT^a\right) \end{equation} where the $T^a$ ($a=1,\ldots N^2-1$) are a basis of $su(N)$ algebra generators. These $N\times N$ matrices are hermitean, traceless, and orthogonal via \begin{equation} \mathop{\rm Tr}T^aT^b = \frac12 \delta^{ab} \end{equation} In the spin-1/2 case, this reduces to the above (standard Bloch) representation since $T^a = \sigma^a/2$, $a=1,2,3$. For the spin-1 case, we could use $T^a = \lambda^a/2$ with the Gell-Mann matrices, \begin{equation} \rho = \frac13\left(1 + \sqrt{3}\alpha^a\lambda^a\right), \end{equation} The normalization is chosen that $|alpha|\leq 1$ for allowed density matrix, where $|\alpha|=1$ is a necessary, but not sufficient, condition for a pure state. <<[[bloch_vectors.f90]]>>= <> module bloch_vectors <> use physics_defs, only: UNKNOWN, SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR use su_algebra <> <> <> contains <> end module bloch_vectors @ %def bloch_vectors @ \subsection{Preliminaries} The normalization factor $\sqrt{2N(N-1)}/N$ that enters the Bloch representation. <>= function bloch_factor (s) result (f) real(default) :: f integer, intent(in) :: s select case (s) case (SCALAR) f = 0 case (SPINOR) f = 1 case (VECTOR) f = 2 * sqrt (3._default) / 3 case (VECTORSPINOR) f = 2 * sqrt (6._default) / 4 case (TENSOR) f = 2 * sqrt (10._default) / 5 case default f = 0 end select end function bloch_factor @ %def bloch_factor @ \subsection{The basic polarization type} The basic polarization object holds just the entries of the Bloch vector as an allocatable array. Bloch is active whenever the coefficient array is allocated. For convenience, we store the spin type ($2s$) and the multiplicity ($N$) together with the coefficient array ($\alpha$). We have to allow for the massless case where $s$ is arbitrary $>0$ but $N=2$, and furthermore the chiral massless case where $N=1$. In the latter case, the array remains deallocated but the chirality is set to $\pm 1$. In the Bloch vector implementation, we do not distinguish between particle and antiparticle. If the distinction applies, it must be made by the caller when transforming between density matrix and Bloch vector. <>= public :: bloch_vector_t <>= type :: bloch_vector_t private integer :: spin_type = UNKNOWN real(default), dimension(:), allocatable :: a contains <> end type bloch_vector_t @ %def bloch_vector_t @ \subsection{Direct Access} This basic initializer just sets the spin type, leaving the Bloch vector unallocated. The object therefore does not support nonzero polarization. <>= procedure :: init_unpolarized => bloch_vector_init_unpolarized <>= subroutine bloch_vector_init_unpolarized (pol, spin_type) class(bloch_vector_t), intent(out) :: pol integer, intent(in) :: spin_type pol%spin_type = spin_type end subroutine bloch_vector_init_unpolarized @ %def bloch_vector_init_unpolarized @ The standard initializer allocates the Bloch vector and initializes with zeros, so we can define a polarization later. We make sure that this works only for the supported spin type. Initializing with [[UNKNOWN]] spin type resets the Bloch vector to undefined, i.e., unpolarized state. <>= generic :: init => bloch_vector_init procedure, private :: bloch_vector_init <>= subroutine bloch_vector_init (pol, spin_type) class(bloch_vector_t), intent(out) :: pol integer, intent(in) :: spin_type pol%spin_type = spin_type select case (spin_type) case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR) allocate (pol%a (algebra_dimension (spin_type)), source = 0._default) end select end subroutine bloch_vector_init @ %def bloch_vector_init @ Fill the Bloch vector from an array, no change of normalization. No initialization and no check, we assume that the shapes do match. <>= procedure :: from_array => bloch_vector_from_array <>= subroutine bloch_vector_from_array (pol, a) class(bloch_vector_t), intent(inout) :: pol real(default), dimension(:), allocatable, intent(in) :: a pol%a(:) = a end subroutine bloch_vector_from_array @ %def bloch_vector_from_array @ Transform to an array of reals, i.e., extract the Bloch vector as-is. <>= procedure :: to_array => bloch_vector_to_array <>= subroutine bloch_vector_to_array (pol, a) class(bloch_vector_t), intent(in) :: pol real(default), dimension(:), allocatable, intent(out) :: a if (pol%is_defined ()) allocate (a (size (pol%a)), source = pol%a) end subroutine bloch_vector_to_array @ %def bloch_vector_to_array @ \subsection{Raw I/O} <>= procedure :: write_raw => bloch_vector_write_raw procedure :: read_raw => bloch_vector_read_raw <>= subroutine bloch_vector_write_raw (pol, u) class(bloch_vector_t), intent(in) :: pol integer, intent(in) :: u write (u) pol%spin_type write (u) allocated (pol%a) if (allocated (pol%a)) then write (u) pol%a end if end subroutine bloch_vector_write_raw subroutine bloch_vector_read_raw (pol, u, iostat) class(bloch_vector_t), intent(out) :: pol integer, intent(in) :: u integer, intent(out) :: iostat integer :: s logical :: polarized read (u, iostat=iostat) s read (u, iostat=iostat) polarized if (iostat /= 0) return if (polarized) then call pol%init (s) read (u, iostat=iostat) pol%a else call pol%init_unpolarized (s) end if end subroutine bloch_vector_read_raw @ %def bloch_vector_write_raw @ %def bloch_vector_read_raw @ \subsection{Properties} Re-export algebra functions that depend on the spin type. These functions do not depend on the Bloch vector being allocated. <>= procedure :: get_n_states procedure :: get_length procedure :: hel_index => bv_helicity_index procedure :: hel_value => bv_helicity_value procedure :: bloch_factor => bv_factor <>= function get_n_states (pol) result (n) class(bloch_vector_t), intent(in) :: pol integer :: n n = fundamental_dimension (pol%spin_type) end function get_n_states function get_length (pol) result (n) class(bloch_vector_t), intent(in) :: pol integer :: n n = algebra_dimension (pol%spin_type) end function get_length function bv_helicity_index (pol, h) result (i) class(bloch_vector_t), intent(in) :: pol integer, intent(in) :: h integer :: i i = helicity_index (pol%spin_type, h) end function bv_helicity_index function bv_helicity_value (pol, i) result (h) class(bloch_vector_t), intent(in) :: pol integer, intent(in) :: i integer :: h h = helicity_value (pol%spin_type, i) end function bv_helicity_value function bv_factor (pol) result (f) class(bloch_vector_t), intent(in) :: pol real(default) :: f f = bloch_factor (pol%spin_type) end function bv_factor @ %def get_n_states @ %def helicity_index @ %def helicity_value @ If the Bloch vector object is defined, the spin type is anything else but [[UNKNOWN]]. This allows us the provide the representation-specific functions above. <>= procedure :: is_defined => bloch_vector_is_defined <>= function bloch_vector_is_defined (pol) result (flag) class(bloch_vector_t), intent(in) :: pol logical :: flag flag = pol%spin_type /= UNKNOWN end function bloch_vector_is_defined @ %def bloch_vector_is_defined @ If the Bloch vector object is (technically) polarized, it is defined, and the vector coefficient array has been allocated. However, the vector value may be zero. <>= procedure :: is_polarized => bloch_vector_is_polarized <>= function bloch_vector_is_polarized (pol) result (flag) class(bloch_vector_t), intent(in) :: pol logical :: flag flag = allocated (pol%a) end function bloch_vector_is_polarized @ %def bloch_vector_is_polarized @ Return true if the polarization is diagonal, i.e., all entries in the density matrix are on the diagonal. This is equivalent to requiring that only Cartan generator coefficients are nonzero in the Bloch vector. <>= procedure :: is_diagonal => bloch_vector_is_diagonal <>= function bloch_vector_is_diagonal (pol) result (diagonal) class(bloch_vector_t), intent(in) :: pol logical :: diagonal integer :: s, i s = pol%spin_type diagonal = .true. if (pol%is_polarized ()) then do i = 1, size (pol%a) if (is_cartan_generator (s, i)) cycle if (pol%a(i) /= 0) then diagonal = .false. return end if end do end if end function bloch_vector_is_diagonal @ %def bloch_vector_is_diagonal @ Return the Euclidean norm of the Bloch vector. This is equal to the Killing form value of the corresponding algebra generator. We assume that the polarization object has been initialized. For a pure state, the norm is unity. All other allowed states have a norm less than unity. (For $s\geq 1$, this is a necessary but not sufficient condition.) <>= procedure :: get_norm => bloch_vector_get_norm <>= function bloch_vector_get_norm (pol) result (norm) class(bloch_vector_t), intent(in) :: pol real(default) :: norm select case (pol%spin_type) case (SPINOR,VECTOR,VECTORSPINOR,TENSOR) norm = sqrt (dot_product (pol%a, pol%a)) case default norm = 1 end select end function bloch_vector_get_norm @ %def bloch_vector_get_norm @ \subsection{Diagonal density matrix} This initializer takes a diagonal density matrix, represented by a real-valued array. We assume that the trace is unity, and that the array has the correct shape for the given [[spin_type]]. The [[bloch_factor]] renormalization is necessary such that a pure state maps to a Bloch vector with unit norm. <>= generic :: init => bloch_vector_init_diagonal procedure, private :: bloch_vector_init_diagonal <>= subroutine bloch_vector_init_diagonal (pol, spin_type, rd) class(bloch_vector_t), intent(out) :: pol integer, intent(in) :: spin_type real(default), dimension(:), intent(in) :: rd call pol%init (spin_type) call pol%set (rd) end subroutine bloch_vector_init_diagonal @ %def bloch_vector_init_diagonal @ Set a Bloch vector, given a diagonal density matrix as a real array. The Bloch vector must be initialized with correct characteristics. <>= generic :: set => bloch_vector_set_diagonal procedure, private :: bloch_vector_set_diagonal <>= subroutine bloch_vector_set_diagonal (pol, rd) class(bloch_vector_t), intent(inout) :: pol real(default), dimension(:), intent(in) :: rd integer :: s s = pol%spin_type select case (s) case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR) pol%a(:) = cartan_coeff (s, rd) / bloch_factor (s) end select end subroutine bloch_vector_set_diagonal @ %def bloch_vector_set_diagonal @ @ \subsection{Massless density matrix} This is a specific variant which initializes an equipartition for the maximum helicity, corresponding to an unpolarized massless particle. <>= procedure :: init_max_weight => bloch_vector_init_max_weight <>= subroutine bloch_vector_init_max_weight (pol, spin_type) class(bloch_vector_t), intent(out) :: pol integer, intent(in) :: spin_type call pol%init (spin_type) select case (spin_type) case (VECTOR) call pol%set ([0.5_default, 0._default, 0.5_default]) case (VECTORSPINOR) call pol%set ([0.5_default, 0._default, 0._default, 0.5_default]) case (TENSOR) call pol%set ([0.5_default, 0._default, 0._default, 0._default, 0.5_default]) end select end subroutine bloch_vector_init_max_weight @ %def bloch_vector_init_max_weight @ Initialize the maximum-weight submatrix with a three-component Bloch vector. This is not as trivial as it seems because we need the above initialization for the generalized Bloch in order to remove the lower weights from the density matrix. <>= procedure :: init_vector => bloch_vector_init_vector procedure :: to_vector => bloch_vector_to_vector <>= subroutine bloch_vector_init_vector (pol, s, a) class(bloch_vector_t), intent(out) :: pol integer, intent(in) :: s real(default), dimension(3), intent(in) :: a call pol%init_max_weight (s) select case (s) case (SPINOR, VECTOR, VECTORSPINOR, TENSOR) pol%a(1:3) = a / bloch_factor (s) end select end subroutine bloch_vector_init_vector subroutine bloch_vector_to_vector (pol, a) class(bloch_vector_t), intent(in) :: pol real(default), dimension(3), intent(out) :: a integer :: s s = pol%spin_type select case (s) case (SPINOR, VECTOR, VECTORSPINOR, TENSOR) a = pol%a(1:3) * bloch_factor (s) case default a = 0 end select end subroutine bloch_vector_to_vector @ %def bloch_vector_init_vector @ %def bloch_vector_to_vector @ \subsection{Arbitrary density matrix} Initialize the Bloch vector from a density matrix. We assume that the density is valid. In particular, the shape should match, the matrix should be hermitian, and the trace should be unity. We first fill the diagonal, then add the off-diagonal parts. <>= generic :: init => bloch_vector_init_matrix procedure, private :: bloch_vector_init_matrix <>= subroutine bloch_vector_init_matrix (pol, spin_type, r) class(bloch_vector_t), intent(out) :: pol integer, intent(in) :: spin_type complex(default), dimension(:,:), intent(in) :: r select case (spin_type) case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR) call pol%init (spin_type) call pol%set (r) case default call pol%init (UNKNOWN) end select end subroutine bloch_vector_init_matrix @ %def bloch_vector_init_matrix @ Set a Bloch vector, given an arbitrary density matrix as a real array. The Bloch vector must be initialized with correct characteristics. <>= generic :: set => bloch_vector_set_matrix procedure, private :: bloch_vector_set_matrix <>= subroutine bloch_vector_set_matrix (pol, r) class(bloch_vector_t), intent(inout) :: pol complex(default), dimension(:,:), intent(in) :: r real(default), dimension(:), allocatable :: rd integer :: s, d, i, j, h1, h2, ir, ii s = pol%spin_type select case (s) case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR) d = fundamental_dimension (s) allocate (rd (d)) do i = 1, d rd(i) = r(i,i) end do call pol%set (rd) do i = 1, d h1 = helicity_value (s, i) do j = i+1, d h2 = helicity_value (s, j) ir = root_index (s, h1, h2, .true.) ii = root_index (s, h1, h2, .false.) pol%a(ir) = real (r(j,i) + r(i,j)) / bloch_factor (s) pol%a(ii) = aimag (r(j,i) - r(i,j)) / bloch_factor (s) end do end do end select end subroutine bloch_vector_set_matrix @ %def bloch_vector_set_matrix @ Allocate and fill the density matrix [[r]] (with the index ordering as defined in [[su_algebra]]) that corresponds to a given Bloch vector. If the optional [[only_max_weight]] is set, the resulting matrix has entries only for $\pm h_\text{max}$, as appropriate for a massless particle (for spin $\geq 1$). Note that we always add the unit matrix, as this is part of the Bloch-vector definition. <>= procedure :: to_matrix => bloch_vector_to_matrix <>= subroutine bloch_vector_to_matrix (pol, r, only_max_weight) class(bloch_vector_t), intent(in) :: pol complex(default), dimension(:,:), intent(out), allocatable :: r logical, intent(in), optional :: only_max_weight integer :: d, s, h0, ng, ai, h, h1, h2, i, j logical :: is_real, only_max complex(default) :: val if (.not. pol%is_polarized ()) return s = pol%spin_type only_max = .false. select case (s) case (VECTOR, VECTORSPINOR, TENSOR) if (present (only_max_weight)) only_max = only_max_weight end select if (only_max) then ng = 2 h0 = helicity_value (s, 1) else ng = algebra_dimension (s) h0 = 0 end if d = fundamental_dimension (s) allocate (r (d, d), source = (0._default, 0._default)) do i = 1, d h = helicity_value (s, i) if (abs (h) < h0) cycle r(i,i) = 1._default / d & + dot_product (cartan_element (s, h), pol%a) * bloch_factor (s) end do do ai = 1, ng if (is_cartan_generator (s, ai)) cycle call root_helicity (s, ai, h1, h2, is_real) i = helicity_index (s, h1) j = helicity_index (s, h2) if (is_real) then val = cmplx (pol%a(ai) / 2 * bloch_factor (s), 0._default, & kind=default) r(i,j) = r(i,j) + val r(j,i) = r(j,i) + val else val = cmplx (0._default, pol%a(ai) / 2 * bloch_factor (s), & kind=default) r(i,j) = r(i,j) - val r(j,i) = r(j,i) + val end if end do end subroutine bloch_vector_to_matrix @ %def bloch_vector_to_matrix @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[bloch_vectors_ut.f90]]>>= <> module bloch_vectors_ut use unit_tests use bloch_vectors_uti <> <> contains <> end module bloch_vectors_ut @ %def bloch_vectors_ut @ <<[[bloch_vectors_uti.f90]]>>= <> module bloch_vectors_uti <> use physics_defs, only: UNKNOWN, SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR use su_algebra, only: algebra_dimension, fundamental_dimension, helicity_value use bloch_vectors <> <> contains <> end module bloch_vectors_uti @ %def bloch_vectors_ut @ API: driver for the unit tests below. <>= public :: bloch_vectors_test <>= subroutine bloch_vectors_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine bloch_vectors_test @ %def bloch_vectors_test @ \subsubsection{Initialization} Initialize the Bloch vector for any spin type. First as unpolarized (no array), then as polarized but with zero polarization. <>= call test (bloch_vectors_1, "bloch_vectors_1", & "initialization", & u, results) <>= public :: bloch_vectors_1 <>= subroutine bloch_vectors_1 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: bloch_vectors_1" write (u, "(A)") "* Purpose: test Bloch-vector & &polarization implementation" write (u, "(A)") write (u, "(A)") "* Initialization (unpolarized)" write (u, "(A)") write (u, "(A)") "* unknown" call bloch_init (UNKNOWN) write (u, "(A)") write (u, "(A)") "* s = 0" call bloch_init (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call bloch_init (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call bloch_init (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call bloch_init (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call bloch_init (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: bloch_vectors_1" contains subroutine bloch_init (s) integer, intent(in) :: s type(bloch_vector_t) :: pol real(default), dimension(:), allocatable :: a integer :: i write (u, *) write (u, "(1X,L1,L1)", advance="no") & pol%is_defined (), pol%is_polarized () call pol%init_unpolarized (s) write (u, "(1X,L1,L1)", advance="no") & pol%is_defined (), pol%is_polarized () call pol%init (s) write (u, "(1X,L1,L1)", advance="no") & pol%is_defined (), pol%is_polarized () write (u, *) call pol%to_array (a) if (allocated (a)) then write (u, "(*(F7.4))") a a(:) = [(real (mod (i, 10), kind=default), i = 1, size (a))] call pol%from_array (a) call pol%to_array (a) write (u, "(*(F7.4))") a else write (u, *) write (u, *) end if end subroutine bloch_init end subroutine bloch_vectors_1 @ %def bloch_vectors_1 @ \subsubsection{Pure state (diagonal)} Initialize the Bloch vector with a pure state of definite helicity and check the normalization. <>= call test (bloch_vectors_2, "bloch_vectors_2", & "pure state (diagonal)", & u, results) <>= public :: bloch_vectors_2 <>= subroutine bloch_vectors_2 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: bloch_vectors_2" write (u, "(A)") "* Purpose: test Bloch-vector & &polarization implementation" write (u, "(A)") write (u, "(A)") "* Initialization (polarized, diagonal): & &display vector and norm" write (u, "(A)") "* transform back" write (u, "(A)") write (u, "(A)") "* s = 0" call bloch_diagonal (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call bloch_diagonal (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call bloch_diagonal (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call bloch_diagonal (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call bloch_diagonal (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: bloch_vectors_2" contains subroutine bloch_diagonal (s) integer, intent(in) :: s type(bloch_vector_t) :: pol real(default), dimension(:), allocatable :: a real(default), dimension(:), allocatable :: rd complex(default), dimension(:,:), allocatable :: r integer :: i, j, d real(default) :: rj real, parameter :: tolerance = 1.E-14_default d = fundamental_dimension (s) do i = 1, d allocate (rd (d), source = 0._default) rd(i) = 1 call pol%init (s, rd) call pol%to_array (a) write (u, *) write (u, "(A,1X,I2)") "h:", helicity_value (s, i) write (u, 1, advance="no") a write (u, "(1X,L1)") pol%is_diagonal () write (u, 1) pol%get_norm () call pol%to_matrix (r) do j = 1, d rj = real (r(j,j)) if (abs (rj) < tolerance) rj = 0 write (u, 1, advance="no") rj end do write (u, "(1X,L1)") matrix_is_diagonal (r) deallocate (a, rd, r) end do 1 format (99(1X,F7.4,:)) end subroutine bloch_diagonal function matrix_is_diagonal (r) result (diagonal) complex(default), dimension(:,:), intent(in) :: r logical :: diagonal integer :: i, j diagonal = .true. do j = 1, size (r, 2) do i = 1, size (r, 1) if (i == j) cycle if (r(i,j) /= 0) then diagonal = .false. return end if end do end do end function matrix_is_diagonal end subroutine bloch_vectors_2 @ %def bloch_vectors_2 @ \subsubsection{Pure state (arbitrary)} Initialize the Bloch vector with an arbitrarily chosen pure state, check the normalization, and transform back to the density matrix. <>= call test (bloch_vectors_3, "bloch_vectors_3", & "pure state (arbitrary)", & u, results) <>= public :: bloch_vectors_3 <>= subroutine bloch_vectors_3 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: bloch_vectors_3" write (u, "(A)") "* Purpose: test Bloch-vector & &polarization implementation" write (u, "(A)") write (u, "(A)") "* Initialization (pure polarized, arbitrary):" write (u, "(A)") "* input matrix, transform, display norm, transform back" write (u, "(A)") write (u, "(A)") "* s = 0" call bloch_arbitrary (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call bloch_arbitrary (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call bloch_arbitrary (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call bloch_arbitrary (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call bloch_arbitrary (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: bloch_vectors_3" contains subroutine bloch_arbitrary (s) integer, intent(in) :: s type(bloch_vector_t) :: pol complex(default), dimension(:,:), allocatable :: r integer :: d d = fundamental_dimension (s) write (u, *) call init_matrix (d, r) call write_matrix (d, r) call pol%init (s, r) write (u, *) write (u, 2) pol%get_norm (), pol%is_diagonal () write (u, *) call pol%to_matrix (r) call write_matrix (d, r) 2 format (1X,F7.4,1X,L1) end subroutine bloch_arbitrary subroutine init_matrix (d, r) integer, intent(in) :: d complex(default), dimension(:,:), allocatable, intent(out) :: r complex(default), dimension(:), allocatable :: a real(default) :: norm integer :: i, j allocate (a (d)) norm = 0 do i = 1, d a(i) = cmplx (2*i-1, 2*i, kind=default) norm = norm + conjg (a(i)) * a(i) end do a = a / sqrt (norm) allocate (r (d,d)) do i = 1, d do j = 1, d r(i,j) = conjg (a(i)) * a(j) end do end do end subroutine init_matrix subroutine write_matrix (d, r) integer, intent(in) :: d complex(default), dimension(:,:), intent(in) :: r integer :: i, j do i = 1, d do j = 1, d write (u, 1, advance="no") r(i,j) end do write (u, *) end do 1 format (99(1X,'(',F7.4,',',F7.4,')',:)) end subroutine write_matrix end subroutine bloch_vectors_3 @ %def bloch_vectors_3 @ \subsubsection{Raw I/O} Check correct input/output in raw format. <>= call test (bloch_vectors_4, "bloch_vectors_4", & "raw I/O", & u, results) <>= public :: bloch_vectors_4 <>= subroutine bloch_vectors_4 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: bloch_vectors_4" write (u, "(A)") "* Purpose: test Bloch-vector & &polarization implementation" write (u, "(A)") write (u, "(A)") "* Raw I/O" write (u, "(A)") write (u, "(A)") "* s = 0" call bloch_io (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call bloch_io (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call bloch_io (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call bloch_io (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call bloch_io (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: bloch_vectors_4" contains subroutine bloch_io (s) integer, intent(in) :: s type(bloch_vector_t) :: pol real(default), dimension(:), allocatable :: a integer :: n, i, utmp, iostat n = algebra_dimension (s) allocate (a (n)) a(:) = [(real (mod (i, 10), kind=default), i = 1, size (a))] write (u, *) write (u, "(*(F7.4))") a call pol%init (s) call pol%from_array (a) open (newunit = utmp, status = "scratch", action = "readwrite", & form = "unformatted") call pol%write_raw (utmp) rewind (utmp) call pol%read_raw (utmp, iostat=iostat) close (utmp) call pol%to_array (a) write (u, "(*(F7.4))") a end subroutine bloch_io end subroutine bloch_vectors_4 @ %def bloch_vectors_4 @ \subsubsection{Convenience Methods} Check some further TBP that are called by the [[polarizations]] module. <>= call test (bloch_vectors_5, "bloch_vectors_5", & "massless state (unpolarized)", & u, results) <>= public :: bloch_vectors_5 <>= subroutine bloch_vectors_5 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: bloch_vectors_5" write (u, "(A)") "* Purpose: test Bloch-vector & &polarization implementation" write (u, "(A)") write (u, "(A)") "* Massless states: equipartition" write (u, "(A)") write (u, "(A)") "* s = 0" call bloch_massless_unpol (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call bloch_massless_unpol (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call bloch_massless_unpol (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call bloch_massless_unpol (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call bloch_massless_unpol (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: bloch_vectors_5" contains subroutine bloch_massless_unpol (s) integer, intent(in) :: s type(bloch_vector_t) :: pol complex(default), dimension(:,:), allocatable :: r real(default), dimension(:), allocatable :: a integer :: d d = fundamental_dimension (s) call pol%init_max_weight (s) call pol%to_matrix (r, only_max_weight = .false.) write (u, *) where (abs (r) < 1.e-14_default) r = 0 call write_matrix (d, r) call pol%to_matrix (r, only_max_weight = .true.) write (u, *) call write_matrix (d, r) end subroutine bloch_massless_unpol subroutine write_matrix (d, r) integer, intent(in) :: d complex(default), dimension(:,:), intent(in) :: r integer :: i, j do i = 1, d do j = 1, d write (u, 1, advance="no") r(i,j) end do write (u, *) end do 1 format (99(1X,'(',F7.4,',',F7.4,')',:)) end subroutine write_matrix end subroutine bloch_vectors_5 @ %def bloch_vectors_5 @ \subsubsection{Massless state (arbitrary)} Initialize the Bloch vector with an arbitrarily chosen pure state which consists only of highest-weight components. Transform back to the density matrix. <>= call test (bloch_vectors_6, "bloch_vectors_6", & "massless state (arbitrary)", & u, results) <>= public :: bloch_vectors_6 <>= subroutine bloch_vectors_6 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: bloch_vectors_6" write (u, "(A)") "* Purpose: test Bloch-vector & &polarization implementation" write (u, "(A)") write (u, "(A)") "* Initialization (pure polarized massless, arbitrary):" write (u, "(A)") "* input matrix, transform, display norm, transform back" write (u, "(A)") write (u, "(A)") "* s = 0" call bloch_massless (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call bloch_massless (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call bloch_massless (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call bloch_massless (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call bloch_massless (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: bloch_vectors_6" contains subroutine bloch_massless (s) integer, intent(in) :: s type(bloch_vector_t) :: pol complex(default), dimension(:,:), allocatable :: r integer :: d d = fundamental_dimension (s) write (u, *) call init_matrix (d, r) call write_matrix (d, r) call pol%init (s, r) write (u, *) write (u, 2) pol%get_norm (), pol%is_diagonal () write (u, *) call pol%to_matrix (r, only_max_weight = .true.) call write_matrix (d, r) 2 format (1X,F7.4,1X,L1) end subroutine bloch_massless subroutine init_matrix (d, r) integer, intent(in) :: d complex(default), dimension(:,:), allocatable, intent(out) :: r complex(default), dimension(:), allocatable :: a real(default) :: norm integer :: i, j allocate (a (d), source = (0._default, 0._default)) norm = 0 do i = 1, d, max (d-1, 1) a(i) = cmplx (2*i-1, 2*i, kind=default) norm = norm + conjg (a(i)) * a(i) end do a = a / sqrt (norm) allocate (r (d,d), source = (0._default, 0._default)) do i = 1, d, max (d-1, 1) do j = 1, d, max (d-1, 1) r(i,j) = conjg (a(i)) * a(j) end do end do end subroutine init_matrix subroutine write_matrix (d, r) integer, intent(in) :: d complex(default), dimension(:,:), intent(in) :: r integer :: i, j do i = 1, d do j = 1, d write (u, 1, advance="no") r(i,j) end do write (u, *) end do 1 format (99(1X,'(',F7.4,',',F7.4,')',:)) end subroutine write_matrix end subroutine bloch_vectors_6 @ %def bloch_vectors_6 @ \subsubsection{Massless state (Bloch vector)} Initialize the (generalized) Bloch vector with an ordinary three-component Bloch vector that applies to the highest-weight part only. <>= call test (bloch_vectors_7, "bloch_vectors_7", & "massless state (vector)", & u, results) <>= public :: bloch_vectors_7 <>= subroutine bloch_vectors_7 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: bloch_vectors_7" write (u, "(A)") "* Purpose: test Bloch-vector & &polarization implementation" write (u, "(A)") write (u, "(A)") "* Initialization & &(pure polarized massless, arbitrary Bloch vector):" write (u, "(A)") "* input vector, transform, display norm, & &transform back" write (u, "(A)") write (u, "(A)") "* s = 0" call bloch_massless_vector (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call bloch_massless_vector (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call bloch_massless_vector (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call bloch_massless_vector (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call bloch_massless_vector (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: bloch_vectors_7" contains subroutine bloch_massless_vector (s) integer, intent(in) :: s type(bloch_vector_t) :: pol real(default), dimension(3) :: a complex(default), dimension(:,:), allocatable :: r write (u, *) a = [1._default, 2._default, 4._default] a = a / sqrt (sum (a ** 2)) write (u, 2) a call pol%init_vector (s, a) write (u, 2) pol%get_norm () call pol%to_vector (a) write (u, 2) a call pol%to_matrix (r, only_max_weight = .false.) write (u, *) where (abs (r) < 1.e-14_default) r = 0 call write_matrix (r) call pol%to_matrix (r, only_max_weight = .true.) write (u, *) call write_matrix (r) 2 format (99(1X,F7.4,:)) end subroutine bloch_massless_vector subroutine write_matrix (r) complex(default), dimension(:,:), intent(in) :: r integer :: i, j do i = 1, size (r, 1) do j = 1, size (r, 2) write (u, 1, advance="no") r(i,j) end do write (u, *) end do 1 format (99(1X,'(',F7.4,',',F7.4,')',:)) end subroutine write_matrix end subroutine bloch_vectors_7 @ %def bloch_vectors_7 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Polarization} Using generalized Bloch vectors and the $su(N)$ algebra (see above) for the internal representation, we can define various modes of polarization. For spin-1/2, and analogously for massless spin-$s$ particles, we introduce \begin{enumerate} \item Trivial polarization: $\vec\alpha=0$. [This is unpolarized, but distinct from the particular undefined polarization matrix which has the same meaning.] \item Circular polarization: $\vec\alpha$ points in $\pm z$ direction. \item Transversal polarization: $\vec\alpha$ points orthogonal to the $z$ direction, with a phase $\phi$ that is $0$ for the $x$ axis, and $\pi/2=90^\circ$ for the $y$ axis. For antiparticles, the phase switches sign, corresponding to complex conjugation. \item Axis polarization, where we explicitly give $\vec\alpha$. \end{enumerate} For higher spin, we retain this definition, but apply it to the two components with maximum and minimum weight. In effect, we concentrate on the first three entries in the $\alpha^a$ array. For massless particles, this is sufficient. For massive particles, we then add the possibilities: \begin{enumerate}\setcounter{enumi}{4} \item Longitudinal polarization: Only the 0-component is set. This is possible only for bosons. \item Diagonal polarization: Explicitly specify all components in the helicity basis. The $su(N)$ representation consists of diagonal generators only, the Cartan subalgebra. \end{enumerate} Obviously, this does not exhaust the possible density matrices for higher spin, but it should cover practical applications. <<[[polarizations.f90]]>>= <> module polarizations <> use io_units use format_defs, only: FMT_19 use diagnostics use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR use flavors use helicities use quantum_numbers use state_matrices use bloch_vectors <> <> <> <> contains <> end module polarizations @ %def polarizations @ \subsection{The polarization type} Polarization is active whenever the coefficient array is allocated. For convenience, we store the spin type ($2s$) and the multiplicity ($N$) together with the coefficient array ($\alpha$). We have to allow for the massless case where $s$ is arbitrary $>0$ but $N=2$, and furthermore the chiral massless case where $N=1$. In the latter case, the array remains deallocated but the chirality is set to $\pm 1$. There is a convention that an antiparticle transforms according to the complex conjugate representation. We apply this only when transforming from/to polarization defined by a three-vector. For antiparticles, the two-component flips sign in that case. When transforming from/to a state matrix or [[pmatrix]] representation, we do not apply this sign flip. - -TODO: Check these conventions for consistency. <>= public :: polarization_t <>= type :: polarization_t private integer :: spin_type = SCALAR integer :: multiplicity = 1 integer :: chirality = 0 logical :: anti = .false. type(bloch_vector_t) :: bv contains <> end type polarization_t @ %def polarization_t @ \subsection{Basic initializer and finalizer} We need the particle flavor for determining the allowed helicity values. The Bloch vector is left undefined, so this initializer (in two versions) creates an unpolarized particle. Exception: a chiral particle is always polarized with definite helicity, it doesn't need a Bloch vector. This is private. <>= generic, private :: init => polarization_init, polarization_init_flv procedure, private :: polarization_init procedure, private :: polarization_init_flv <>= subroutine polarization_init (pol, spin_type, multiplicity, & anti, left_handed, right_handed) class(polarization_t), intent(out) :: pol integer, intent(in) :: spin_type integer, intent(in) :: multiplicity logical, intent(in) :: anti logical, intent(in) :: left_handed logical, intent(in) :: right_handed pol%spin_type = spin_type pol%multiplicity = multiplicity pol%anti = anti select case (pol%multiplicity) case (1) if (left_handed) then pol%chirality = -1 else if (right_handed) then pol%chirality = 1 end if end select select case (pol%chirality) case (0) call pol%bv%init_unpolarized (spin_type) end select end subroutine polarization_init subroutine polarization_init_flv (pol, flv) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv call pol%init ( & spin_type = flv%get_spin_type (), & multiplicity = flv%get_multiplicity (), & anti = flv%is_antiparticle (), & left_handed = flv%is_left_handed (), & right_handed = flv%is_right_handed ()) end subroutine polarization_init_flv @ %def polarization_init polarization_init_flv @ Generic polarization: as before, but create a polarized particle (Bloch vector defined) with initial polarization zero. <>= generic :: init_generic => & polarization_init_generic, & polarization_init_generic_flv procedure, private :: polarization_init_generic procedure, private :: polarization_init_generic_flv <>= subroutine polarization_init_generic (pol, spin_type, multiplicity, & anti, left_handed, right_handed) class(polarization_t), intent(out) :: pol integer, intent(in) :: spin_type integer, intent(in) :: multiplicity logical, intent(in) :: anti logical, intent(in) :: left_handed logical, intent(in) :: right_handed call pol%init (spin_type, multiplicity, & anti, left_handed, right_handed) select case (pol%chirality) case (0) if (pol%multiplicity == pol%bv%get_n_states ()) then call pol%bv%init (spin_type) else call pol%bv%init_max_weight (spin_type) end if end select end subroutine polarization_init_generic subroutine polarization_init_generic_flv (pol, flv) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv call pol%init_generic ( & spin_type = flv%get_spin_type (), & multiplicity = flv%get_multiplicity (), & anti = flv%is_antiparticle (), & left_handed = flv%is_left_handed (), & right_handed = flv%is_right_handed ()) end subroutine polarization_init_generic_flv @ %def polarization_init_generic @ A finalizer is no longer necessary. \subsection{I/O} The default setting produces a tabular output of the polarization vector entries. Optionally, we can create a state matrix and write its contents, emulating the obsolete original implementation. If [[all_states]] is true (default), we generate all helity combinations regardless of the matrix-element value. Otherwise, skip helicities with zero entry, or absolute value less than [[tolerance]], if also given. <>= procedure :: write => polarization_write <>= subroutine polarization_write (pol, unit, state_matrix, all_states, tolerance) class(polarization_t), intent(in) :: pol integer, intent(in), optional :: unit logical, intent(in), optional :: state_matrix, all_states real(default), intent(in), optional :: tolerance logical :: state_m type(state_matrix_t) :: state real(default), dimension(:), allocatable :: a integer :: u, i u = given_output_unit (unit); if (u < 0) return state_m = .false.; if (present (state_matrix)) state_m = state_matrix if (pol%anti) then write (u, "(1x,A,I1,A,I1,A,L1,A)") & "Polarization: [spin_type = ", pol%spin_type, & ", mult = ", pol%multiplicity, ", anti = ", pol%anti, "]" else write (u, "(1x,A,I1,A,I1,A)") & "Polarization: [spin_type = ", pol%spin_type, & ", mult = ", pol%multiplicity, "]" end if if (state_m) then call pol%to_state (state, all_states, tolerance) call state%write (unit=unit) call state%final () else if (pol%chirality == 1) then write (u, "(1x,A)") "chirality = +" else if (pol%chirality == -1) then write (u, "(1x,A)") "chirality = -" else if (pol%bv%is_polarized ()) then call pol%bv%to_array (a) do i = 1, size (a) write (u, "(1x,I2,':',1x,F10.7)") i, a(i) end do else write (u, "(1x,A)") "[unpolarized]" end if end subroutine polarization_write @ %def polarization_write @ Binary I/O. <>= procedure :: write_raw => polarization_write_raw procedure :: read_raw => polarization_read_raw <>= subroutine polarization_write_raw (pol, u) class(polarization_t), intent(in) :: pol integer, intent(in) :: u write (u) pol%spin_type write (u) pol%multiplicity write (u) pol%chirality write (u) pol%anti call pol%bv%write_raw (u) end subroutine polarization_write_raw subroutine polarization_read_raw (pol, u, iostat) class(polarization_t), intent(out) :: pol integer, intent(in) :: u integer, intent(out), optional :: iostat read (u, iostat=iostat) pol%spin_type read (u, iostat=iostat) pol%multiplicity read (u, iostat=iostat) pol%chirality read (u, iostat=iostat) pol%anti call pol%bv%read_raw (u, iostat) end subroutine polarization_read_raw @ %def polarization_read_raw @ \subsection{Accessing contents} Return true if the particle is technically polarized. The particle is either chiral, or its Bloch vector has been defined. The function returns true even if the Bloch vector is zero or the particle is scalar. <>= procedure :: is_polarized => polarization_is_polarized <>= function polarization_is_polarized (pol) result (polarized) class(polarization_t), intent(in) :: pol logical :: polarized polarized = pol%chirality /= 0 .or. pol%bv%is_polarized () end function polarization_is_polarized @ %def polarization_is_polarized @ Return true if the polarization is diagonal, i.e., all entries in the density matrix are diagonal. For an unpolarized particle, we also return [[.true.]] since the density matrix is proportional to the unit matrix. <>= procedure :: is_diagonal => polarization_is_diagonal <>= function polarization_is_diagonal (pol) result (diagonal) class(polarization_t), intent(in) :: pol logical :: diagonal select case (pol%chirality) case (0) diagonal = pol%bv%is_diagonal () case default diagonal = .true. end select end function polarization_is_diagonal @ %def polarization_is_diagonal @ \subsection{Mapping between polarization and state matrix} Create the polarization object that corresponds to a state matrix. The state matrix is not necessarily normalized. The result will be either unpolarized, or a generalized Bloch vector that we compute in terms of the appropriate spin generator basis. To this end, we first construct the complete density matrix, then set the Bloch vector with this input. For a naturally chiral particle (i.e., neutrino), we do not set the polarization vector, it is implied. -TODO: The state matrix does not support an antiparticle flag. Therefore, we cannot account for any sign flip and transform as-is. <>= procedure :: init_state_matrix => polarization_init_state_matrix <>= subroutine polarization_init_state_matrix (pol, state) class(polarization_t), intent(out) :: pol type(state_matrix_t), intent(in), target :: state type(state_iterator_t) :: it type(flavor_t) :: flv type(helicity_t) :: hel integer :: d, h1, h2, i, j complex(default), dimension(:,:), allocatable :: r complex(default) :: me real(default) :: trace call it%init (state) flv = it%get_flavor (1) hel = it%get_helicity (1) if (hel%is_defined ()) then call pol%init_generic (flv) select case (pol%chirality) case (0) trace = 0 d = pol%bv%get_n_states () allocate (r (d, d), source = (0._default, 0._default)) do while (it%is_valid ()) hel = it%get_helicity (1) call hel%get_indices (h1, h2) i = pol%bv%hel_index (h1) j = pol%bv%hel_index (h2) me = it%get_matrix_element () r(i,j) = me if (i == j) trace = trace + real (me) call it%advance () end do if (trace /= 0) call pol%bv%set (r / trace) end select else call pol%init (flv) end if end subroutine polarization_init_state_matrix @ %def polarization_init_state_matrix @ Create the state matrix that corresponds to a given polarization. We make use of the polarization iterator as defined below, which should iterate according to the canonical helicity ordering. <>= procedure :: to_state => polarization_to_state_matrix <>= subroutine polarization_to_state_matrix (pol, state, all_states, tolerance) class(polarization_t), intent(in), target :: pol type(state_matrix_t), intent(out) :: state logical, intent(in), optional :: all_states real(default), intent(in), optional :: tolerance type(polarization_iterator_t) :: it type(quantum_numbers_t), dimension(1) :: qn complex(default) :: value call it%init (pol, all_states, tolerance) call state%init (store_values = .true.) do while (it%is_valid ()) value = it%get_value () qn(1) = it%get_quantum_numbers () call state%add_state (qn, value = value) call it%advance () end do call state%freeze () end subroutine polarization_to_state_matrix @ %def polarization_to_state_matrix @ \subsection{Specific initializers} Unpolarized particle, no nontrivial entries in the density matrix. This is the default initialization mode. <>= procedure :: init_unpolarized => polarization_init_unpolarized <>= subroutine polarization_init_unpolarized (pol, flv) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv call pol%init (flv) end subroutine polarization_init_unpolarized @ %def polarization_init_unpolarized @ The following three modes are useful mainly for spin-1/2 particle and massless particles of any nonzero spin. Only the highest-weight components are filled. Circular polarization: The density matrix of the two highest-weight states is \begin{equation*} \rho(f) = \frac{1-|f|}{2}\mathbf{1} + |f| \times \begin{cases} \begin{pmatrix} 1 & 0 \\ 0 & 0 \end{pmatrix}, & f > 0; \\[6pt] \begin{pmatrix} 0 & 0 \\ 0 & 1 \end{pmatrix}, & f < 0, \end{cases} \end{equation*} In the generalized Bloch representation, this is an entry for the $T^3$ generator only, regardless of the spin representation. A chiral particle is not affected. <>= procedure :: init_circular => polarization_init_circular <>= subroutine polarization_init_circular (pol, flv, f) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv real(default), intent(in) :: f call pol%init (flv) select case (pol%chirality) case (0) call pol%bv%init_vector (pol%spin_type, & [0._default, 0._default, f]) end select end subroutine polarization_init_circular @ %def polarization_init_circular @ Transversal polarization is analogous to circular, but we get a density matrix \begin{equation*} \rho(f,\phi) = \frac{1-|f|}{2}\mathbf{1} + \frac{|f|}{2} \begin{pmatrix} 1 & e^{-i\phi} \\ e^{i\phi} & 1 \end{pmatrix}. \end{equation*} for the highest-weight subspace. The lower weights are unaffected. The phase is $\phi=0$ for the $x$-axis, $\phi=90^\circ$ for the $y$ axis as polarization vector. For an antiparticle, the phase switches sign, and for $f<0$, the off-diagonal elements switch sign. A chiral particle is not affected. <>= procedure :: init_transversal => polarization_init_transversal <>= subroutine polarization_init_transversal (pol, flv, phi, f) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv real(default), intent(in) :: phi, f call pol%init (flv) select case (pol%chirality) case (0) if (pol%anti) then call pol%bv%init_vector (pol%spin_type, & [f * cos (phi), f * sin (phi), 0._default]) else call pol%bv%init_vector (pol%spin_type, & [f * cos (phi),-f * sin (phi), 0._default]) end if end select end subroutine polarization_init_transversal @ %def polarization_init_transversal @ For axis polarization, we again set only the entries with maximum weight, which for spin $1/2$ means \begin{equation*} \rho(f,\phi) = \frac{1}{2} \begin{pmatrix} 1 + \alpha_3 & \alpha_1 - i\alpha_2 \\ \alpha_1 + i\alpha_2 & 1 - \alpha_3 \end{pmatrix}. \end{equation*} For an antiparticle, the imaginary part proportional to $\alpha_2$ switches sign (complex conjugate). A chiral particle is not affected. In the generalized Bloch representation, this translates into coefficients for $T^{1,2,3}$, all others stay zero. <>= procedure :: init_axis => polarization_init_axis <>= subroutine polarization_init_axis (pol, flv, alpha) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv real(default), dimension(3), intent(in) :: alpha call pol%init (flv) select case (pol%chirality) case (0) if (pol%anti) then call pol%bv%init_vector (pol%spin_type, & [alpha(1), alpha(2), alpha(3)]) else call pol%bv%init_vector (pol%spin_type, & [alpha(1),-alpha(2), alpha(3)]) end if end select end subroutine polarization_init_axis @ %def polarization_init_axis @ This version specifies the polarization axis in terms of $r$ (polarization degree) and $\theta,\phi$ (polar and azimuthal angles). If one of the angles is a nonzero multiple of $\pi$, roundoff errors typically will result in tiny contributions to unwanted components. Therefore, include a catch for small numbers. <>= procedure :: init_angles => polarization_init_angles <>= subroutine polarization_init_angles (pol, flv, r, theta, phi) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv real(default), intent(in) :: r, theta, phi real(default), dimension(3) :: alpha real(default), parameter :: eps = 10 * epsilon (1._default) alpha(1) = r * sin (theta) * cos (phi) alpha(2) = r * sin (theta) * sin (phi) alpha(3) = r * cos (theta) where (abs (alpha) < eps) alpha = 0 call pol%init_axis (flv, alpha) end subroutine polarization_init_angles @ %def polarization_init_angles @ Longitudinal polarization is defined only for massive bosons. Only the zero component is filled. Otherwise, unpolarized. In the generalized Bloch representation, the zero component corresponds to a linear combination of all diagonal (Cartan) generators. <>= procedure :: init_longitudinal => polarization_init_longitudinal <>= subroutine polarization_init_longitudinal (pol, flv, f) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv real(default), intent(in) :: f real(default), dimension(:), allocatable :: rd integer :: s, d s = flv%get_spin_type () select case (s) case (VECTOR, TENSOR) call pol%init_generic (flv) if (pol%bv%is_polarized ()) then d = pol%bv%get_n_states () allocate (rd (d), source = 0._default) rd(pol%bv%hel_index (0)) = f call pol%bv%set (rd) end if case default call pol%init_unpolarized (flv) end select end subroutine polarization_init_longitudinal @ %def polarization_init_longitudinal @ This is diagonal polarization: we specify all components explicitly. [[rd]] is the array of diagonal elements of the density matrix. We assume that the length of [[rd]] is equal to the particle multiplicity. <>= procedure :: init_diagonal => polarization_init_diagonal <>= subroutine polarization_init_diagonal (pol, flv, rd) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv real(default), dimension(:), intent(in) :: rd real(default) :: trace call pol%init_generic (flv) if (pol%bv%is_polarized ()) then trace = sum (rd) if (trace /= 0) call pol%bv%set (rd / trace) end if end subroutine polarization_init_diagonal @ %def polarization_init_diagonal @ \subsection{Operations} Combine polarization states by computing the outer product of the state matrices. <>= public :: combine_polarization_states <>= subroutine combine_polarization_states (pol, state) type(polarization_t), dimension(:), intent(in), target :: pol type(state_matrix_t), intent(out) :: state type(state_matrix_t), dimension(size(pol)), target :: pol_state integer :: i do i = 1, size (pol) call pol(i)%to_state (pol_state(i)) end do call outer_multiply (pol_state, state) do i = 1, size (pol) call pol_state(i)%final () end do end subroutine combine_polarization_states @ %def combine_polarization_states @ Transform a polarization density matrix into a polarization vector. This is possible without information loss only for spin-1/2 and for massless particles. To get a unique answer in all cases, we consider only the components with highest weight. Obviously, this loses the longitudinal component of a massive vector, for instance. The norm of the returned axis is the polarization fraction for the highest-weight subspace. For a scalar particle, we return a zero vector. The same result applies if the highest-weight component vanishes. This is the inverse operation of [[polarization_init_axis]] above, where the polarization fraction is set to unity. For an antiparticle, the [[alpha(2)]] coefficient flips sign. <>= procedure :: get_axis => polarization_get_axis <>= function polarization_get_axis (pol) result (alpha) class(polarization_t), intent(in), target :: pol real(default), dimension(3) :: alpha select case (pol%chirality) case (0) call pol%bv%to_vector (alpha) if (.not. pol%anti) alpha(2) = - alpha(2) case (-1) alpha = [0._default, 0._default, -1._default] case (1) alpha = [0._default, 0._default, 1._default] end select end function polarization_get_axis @ %def polarization_get_axis @ This function returns polarization degree and polar and azimuthal angles ($\theta,\phi$) of the polarization axis. The same restrictions apply as above. Since we call the [[get_axis]] method, the phase flips sign for an antiparticle. <>= procedure :: to_angles => polarization_to_angles <>= subroutine polarization_to_angles (pol, r, theta, phi) class(polarization_t), intent(in) :: pol real(default), intent(out) :: r, theta, phi real(default), dimension(3) :: alpha real(default) :: norm, r12 alpha = pol%get_axis () norm = sum (alpha**2) r = sqrt (norm) if (norm > 0) then r12 = sqrt (alpha(1)**2 + alpha(2)**2) theta = atan2 (r12, alpha(3)) if (any (alpha(1:2) /= 0)) then phi = atan2 (alpha(2), alpha(1)) else phi = 0 end if else theta = 0 phi = 0 end if end subroutine polarization_to_angles @ %def polarization_to_angles @ \subsection{Polarization Iterator} The iterator acts like a state matrix iterator, i.e., it points to one helicity combination at a time and can return the corresponding helicity object and matrix-element value. Since the polarization is stored as a Bloch vector, we recover the whole density matrix explicitly upon initialization, store it inside the iterator object, and then just return its elements one at a time. For an unpolarized particle, the iterator returns a single state with undefined helicity. The value is the value of any diagonal density matrix element, $1/n$ where $n$ is the multiplicity. <>= public :: polarization_iterator_t <>= type :: polarization_iterator_t private type(polarization_t), pointer :: pol => null () logical :: polarized = .false. integer :: h1 = 0 integer :: h2 = 0 integer :: i = 0 integer :: j = 0 complex(default), dimension(:,:), allocatable :: r complex(default) :: value = 1._default real(default) :: tolerance = -1._default logical :: valid = .false. contains <> end type polarization_iterator_t @ %def polarization_iterator_t @ Output for debugging purposes only, therefore no format for real/complex. <>= procedure :: write => polarization_iterator_write <>= subroutine polarization_iterator_write (it, unit) class(polarization_iterator_t), intent(in) :: it integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1X,A)") "Polarization iterator:" write (u, "(3X,A,L1)") "assigned = ", associated (it%pol) write (u, "(3X,A,L1)") "valid = ", it%valid if (it%valid) then write (u, "(3X,A,2(1X,I2))") "i, j = ", it%i, it%j write (u, "(3X,A,2(1X,I2))") "h1, h2 = ", it%h1, it%h2 write (u, "(3X,A)", advance="no") "value = " write (u, *) it%value if (allocated (it%r)) then do i = 1, size (it%r, 2) write (u, *) it%r(i,:) end do end if end if end subroutine polarization_iterator_write @ %def polarization_iterator_write @ Initialize, i.e., (virtually) point to the first helicity state supported by the polarization object. If the density matrix is nontrivial, we calculate it here. Following the older state-matrix conventions, the iterator sequence starts at the lowest helicity value. In the current internal representation, this corresponds to the highest index value. If the current matrix-element value is zero, advance the iterator. Advancing will stop at a nonzero value or if the iterator becomes invalid. If [[tolerance]] is given, any state matrix entry less or equal will be treated as zero, causing the iterator to skip an entry. By default, the value is negative, so no entry is skipped. <>= procedure :: init => polarization_iterator_init <>= subroutine polarization_iterator_init (it, pol, all_states, tolerance) class(polarization_iterator_t), intent(out) :: it type(polarization_t), intent(in), target :: pol logical, intent(in), optional :: all_states real(default), intent(in), optional :: tolerance integer :: d logical :: only_max_weight it%pol => pol if (present (all_states)) then if (.not. all_states) then if (present (tolerance)) then it%tolerance = tolerance else it%tolerance = 0 end if end if end if select case (pol%chirality) case (0) d = pol%bv%get_n_states () only_max_weight = pol%multiplicity < d it%polarized = pol%bv%is_polarized () if (it%polarized) then it%i = d it%j = it%i it%h1 = pol%bv%hel_value (it%i) it%h2 = it%h1 call pol%bv%to_matrix (it%r, only_max_weight) it%value = it%r(it%i, it%j) else it%value = 1._default / d end if it%valid = .true. case (1,-1) it%polarized = .true. select case (pol%spin_type) case (SPINOR) it%h1 = pol%chirality case (VECTORSPINOR) it%h1 = 2 * pol%chirality end select it%h2 = it%h1 it%valid = .true. end select if (it%valid .and. abs (it%value) <= it%tolerance) call it%advance () end subroutine polarization_iterator_init @ %def polarization_iterator_init @ Advance to the next valid helicity state. Repeat if the returned value is zero. For an unpolarized object, we iterate through the diagonal helicity states with a constant value. <>= procedure :: advance => polarization_iterator_advance <>= recursive subroutine polarization_iterator_advance (it) class(polarization_iterator_t), intent(inout) :: it if (it%valid) then select case (it%pol%chirality) case (0) if (it%polarized) then if (it%j > 1) then it%j = it%j - 1 it%h2 = it%pol%bv%hel_value (it%j) it%value = it%r(it%i, it%j) else if (it%i > 1) then it%j = it%pol%bv%get_n_states () it%h2 = it%pol%bv%hel_value (it%j) it%i = it%i - 1 it%h1 = it%pol%bv%hel_value (it%i) it%value = it%r(it%i, it%j) else it%valid = .false. end if else it%valid = .false. end if case default it%valid = .false. end select if (it%valid .and. abs (it%value) <= it%tolerance) call it%advance () end if end subroutine polarization_iterator_advance @ %def polarization_iterator_advance @ This is true as long as the iterator points to a valid helicity state. <>= procedure :: is_valid => polarization_iterator_is_valid <>= function polarization_iterator_is_valid (it) result (is_valid) logical :: is_valid class(polarization_iterator_t), intent(in) :: it is_valid = it%valid end function polarization_iterator_is_valid @ %def polarization_iterator_is_valid @ Return the matrix element value for the helicity that we are currently pointing at. <>= procedure :: get_value => polarization_iterator_get_value <>= function polarization_iterator_get_value (it) result (value) complex(default) :: value class(polarization_iterator_t), intent(in) :: it if (it%valid) then value = it%value else value = 0 end if end function polarization_iterator_get_value @ %def polarization_iterator_get_value @ Return a quantum number object for the helicity that we are currently pointing at. This is a single quantum number object, not an array. Note that the [[init]] method of the helicity object has the order reversed. <>= procedure :: get_quantum_numbers => polarization_iterator_get_quantum_numbers <>= function polarization_iterator_get_quantum_numbers (it) result (qn) class(polarization_iterator_t), intent(in) :: it type(helicity_t) :: hel type(quantum_numbers_t) :: qn if (it%polarized) then call hel%init (it%h2, it%h1) end if call qn%init (hel) end function polarization_iterator_get_quantum_numbers @ %def polarization_iterator_get_quantum_numbers @ \subsection{Sparse Matrix} We introduce a simple implementation of a sparse matrix that can represent polarization (or similar concepts) for transfer to I/O within the program. It consists of an integer array that represents the index values, and a complex array that represents the nonvanishing entries. The number of nonvanishing entries must be known for initialization, but the entries are filled one at a time. Here is a base type without the special properties of a spin-density matrix. <>= public :: smatrix_t <>= type :: smatrix_t private integer :: dim = 0 integer :: n_entry = 0 integer, dimension(:,:), allocatable :: index complex(default), dimension(:), allocatable :: value contains <> end type smatrix_t @ %def smatrix_t @ Output. <>= procedure :: write => smatrix_write <>= subroutine smatrix_write (object, unit, indent) class(smatrix_t), intent(in) :: object integer, intent(in), optional :: unit, indent integer :: u, i, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent if (allocated (object%value)) then if (size (object%value) > 0) then do i = 1, object%n_entry write (u, "(1x,A,'@(')", advance="no") repeat (" ", ind) write (u, "(SP,9999(I2.1,':',1x))", advance="no") & object%index(:,i) write (u, "('('," // FMT_19 // ",','," // FMT_19 // & ",'))')") object%value(i) end do else write (u, "(1x,A)", advance="no") repeat (" ", ind) write (u, "(A)") "[empty matrix]" end if else write (u, "(1x,A)", advance="no") repeat (" ", ind) write (u, "(A)") "[undefined matrix]" end if end subroutine smatrix_write @ %def smatrix_write @ Initialization: allocate arrays to the correct size. We specify both the dimension of the matrix (if different from two, this is rather a generic tensor) and the number of nonvanishing entries. <>= procedure :: init => smatrix_init <>= subroutine smatrix_init (smatrix, dim, n_entry) class(smatrix_t), intent(out) :: smatrix integer, intent(in) :: dim integer, intent(in) :: n_entry smatrix%dim = dim smatrix%n_entry = n_entry allocate (smatrix%index (dim, n_entry)) allocate (smatrix%value (n_entry)) end subroutine smatrix_init @ %def smatrix_init @ Fill: one entry at a time. <>= procedure :: set_entry => smatrix_set_entry <>= subroutine smatrix_set_entry (smatrix, i, index, value) class(smatrix_t), intent(inout) :: smatrix integer, intent(in) :: i integer, dimension(:), intent(in) :: index complex(default), intent(in) :: value smatrix%index(:,i) = index smatrix%value(i) = value end subroutine smatrix_set_entry @ %def smatrix_set_entry @ <>= procedure :: exists => smatrix_exists <>= elemental function smatrix_exists (smatrix) result (exist) logical :: exist class(smatrix_t), intent(in) :: smatrix exist = .not. all (smatrix%value == 0) end function smatrix_exists @ %def smatrix_exists @ \subsection{Polarization Matrix} As an extension of the more generic [[smatrix]] type, we implement a proper spin-density matrix. After the matrix has been filled, we can fix spin type and multiplicity for a particle, check the matrix for consistency, and normalize it if necessary. -TODO: This implementation does not have an antiparticle flag, just +This implementation does not have an antiparticle flag, just like the state matrix object. We therefore cannot account for sign flips when using this object. TODO: The [[pure]] flag is for informational purposes only, and it only represents a necessary condition if spin is greater than $1/2$. We may either check purity for all spins or drop this. <>= public :: pmatrix_t <>= type, extends (smatrix_t) :: pmatrix_t private integer :: spin_type = 0 integer :: multiplicity = 0 logical :: massive = .true. integer :: chirality = 0 real(default) :: degree = 1 logical :: pure = .false. contains <> end type pmatrix_t @ %def pmatrix_t @ Output, including extra data. (The [[indent]] argument is ignored.) <>= procedure :: write => pmatrix_write <>= subroutine pmatrix_write (object, unit, indent) class(pmatrix_t), intent(in) :: object integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Polarization: spin density matrix" write (u, "(3x,A,I0)") "spin type = ", object%spin_type write (u, "(3x,A,I0)") "multiplicity = ", object%multiplicity write (u, "(3x,A,L1)") "massive = ", object%massive write (u, "(3x,A,I0)") "chirality = ", object%chirality write (u, "(3x,A,F10.7)") "pol.degree =", object%degree write (u, "(3x,A,L1)") "pure state = ", object%pure call object%smatrix_t%write (u, 1) end subroutine pmatrix_write @ %def pmatrix_write @ This assignment is trivial, but must be coded explicitly. <>= generic :: assignment(=) => pmatrix_assign_from_smatrix procedure, private :: pmatrix_assign_from_smatrix <>= subroutine pmatrix_assign_from_smatrix (pmatrix, smatrix) class(pmatrix_t), intent(out) :: pmatrix type(smatrix_t), intent(in) :: smatrix pmatrix%smatrix_t = smatrix end subroutine pmatrix_assign_from_smatrix @ %def pmatrix_assign_from_smatrix @ Declare spin, multiplicity, and polarization degree. Check whether all entries fit, and whether this is a valid matrix. The required properties are: \begin{enumerate} \item all entries apply to the given spin and mass type \item the diagonal is real \item only the upper of corresponding off-diagonal elements is specified, i.e., the row index is less than the column index \item the trace is nonnegative and equal to the polarization degree (the remainder, proportional to the unit matrix, is understood to be present) \item the trace of the matrix square is positive and less or equal to the trace of the matrix itself, which is the polarization degree. \item If the trace of the matrix square and the trace of the matrix are unity, we may have a pure state. (For spin up to $1/2$, this is actually sufficient.) \end{enumerate} <>= procedure :: normalize => pmatrix_normalize <>= subroutine pmatrix_normalize (pmatrix, flv, degree, tolerance) class(pmatrix_t), intent(inout) :: pmatrix type(flavor_t), intent(in) :: flv real(default), intent(in), optional :: degree real(default), intent(in), optional :: tolerance integer :: i, hmax logical :: fermion, ok real(default) :: trace, trace_sq real(default) :: tol tol = 0; if (present (tolerance)) tol = tolerance pmatrix%spin_type = flv%get_spin_type () pmatrix%massive = flv%get_mass () /= 0 if (.not. pmatrix%massive) then if (flv%is_left_handed ()) then pmatrix%chirality = -1 else if (flv%is_right_handed ()) then pmatrix%chirality = +1 end if end if if (pmatrix%spin_type == SCALAR) then pmatrix%multiplicity = 1 else if (pmatrix%massive) then pmatrix%multiplicity = pmatrix%spin_type else if (pmatrix%chirality == 0) then pmatrix%multiplicity = 2 else pmatrix%multiplicity = 1 end if if (present (degree)) then if (degree < 0 .or. degree > 1) & call msg_error ("polarization degree must be between 0 and 1") pmatrix%degree = degree end if if (size (pmatrix%index, 1) /= 2) call error ("wrong array rank") fermion = mod (pmatrix%spin_type, 2) == 0 hmax = pmatrix%spin_type / 2 if (pmatrix%n_entry > 0) then if (fermion) then if (pmatrix%massive) then ok = all (pmatrix%index /= 0) & .and. all (abs (pmatrix%index) <= hmax) else if (pmatrix%chirality == -1) then ok = all (pmatrix%index == -hmax) else if (pmatrix%chirality == +1) then ok = all (pmatrix%index == +hmax) else ok = all (abs (pmatrix%index) == hmax) end if else if (pmatrix%massive) then ok = all (abs (pmatrix%index) <= hmax) else ok = all (abs (pmatrix%index) == hmax) end if end if if (.not. ok) call error ("illegal index value") else pmatrix%degree = 0 pmatrix%pure = pmatrix%multiplicity == 1 return end if trace = 0 do i = 1, pmatrix%n_entry associate (index => pmatrix%index(:,i), value => pmatrix%value(i)) if (index(1) == index(2)) then if (abs (aimag (value)) > tol) call error ("diagonal must be real") value = real (value, kind=default) trace = trace + value else if (any (pmatrix%index(1,:) == index(2) & .and. pmatrix%index(2,:) == index(1))) then call error ("redundant off-diagonal entry") else if (index(2) < index (1)) then index = index([2,1]) value = conjg (value) end if end associate end do if (abs (trace) <= tol) call error ("trace must not vanish") trace = real (trace, kind=default) pmatrix%value = pmatrix%value / trace * pmatrix%degree trace_sq = (1 - pmatrix%degree ** 2) / pmatrix%multiplicity do i = 1, pmatrix%n_entry associate (index => pmatrix%index(:,i), value => pmatrix%value(i)) if (index(1) == index(2)) then trace_sq = trace_sq + abs (value) ** 2 else trace_sq = trace_sq + 2 * abs (value) ** 2 end if end associate end do if (pmatrix%multiplicity == 1) then pmatrix%pure = .true. else if (abs (trace_sq - 1) <= tol) then pmatrix%pure = .true. else if (trace_sq - 1 > tol .or. trace_sq < -tol) then print *, "Trace of matrix square = ", trace_sq call error ("not permissible as density matrix") end if contains subroutine error (msg) character(*), intent(in) :: msg call pmatrix%write () call msg_fatal ("Spin density matrix: " // msg) end subroutine error end subroutine pmatrix_normalize @ %def pmatrix_normalize @ A polarized matrix is defined as one with a positive polarization degree, even if the actual matrix is trivial. <>= procedure :: is_polarized => pmatrix_is_polarized <>= elemental function pmatrix_is_polarized (pmatrix) result (flag) class(pmatrix_t), intent(in) :: pmatrix logical :: flag flag = pmatrix%degree > 0 end function pmatrix_is_polarized @ %def pmatrix_is_polarized @ Check if there are only diagonal entries. <>= procedure :: is_diagonal => pmatrix_is_diagonal <>= elemental function pmatrix_is_diagonal (pmatrix) result (flag) class(pmatrix_t), intent(in) :: pmatrix logical :: flag flag = all (pmatrix%index(1,:) == pmatrix%index(2,:)) end function pmatrix_is_diagonal @ %def pmatrix_is_diagonal @ Check if there are only diagonal entries. <>= procedure :: get_simple_pol => pmatrix_get_simple_pol <>= elemental function pmatrix_get_simple_pol (pmatrix) result (pol) class(pmatrix_t), intent(in) :: pmatrix real(default) :: pol if (pmatrix%is_polarized ()) then select case (size (pmatrix%value)) case (0) pol = 0 case (1) pol = pmatrix%index (1,1) * pmatrix%degree case (2) pol = 42 end select else pol = 0 end if end function pmatrix_get_simple_pol @ %def pmatrix_get_simple_pol @ \subsection{Data Transformation} Create a [[polarization_t]] object from the contents of a normalized [[pmatrix_t]] object. We scan the entries as present in [[pmatrix]] and transform them into a density matrix, if necessary. The density matrix then initializes the Bloch vector. This is analogous to [[polarization_init_state_matrix]]. There is a subtlety associated with massless particles. Since the [[pmatrix]] doesn't contain the full density matrix but just the nontrivial part, we have to initialize the polarization object with the massless equipartion, which contains nonzero entries for the Cartan generators. The [[set]] method therefore should not erase those initial contents. This is a constraint for the implementation of [[set]], as applied to the Bloch vector. -TODO: As mentioned above, [[pmatrix_t]] does not support an +As mentioned above, [[pmatrix_t]] does not support an antiparticle flag. <>= procedure :: init_pmatrix => polarization_init_pmatrix <>= subroutine polarization_init_pmatrix (pol, pmatrix) class(polarization_t), intent(out) :: pol type(pmatrix_t), intent(in) :: pmatrix integer :: d, i, j, k, h1, h2 complex(default), dimension(:,:), allocatable :: r call pol%init_generic ( & spin_type = pmatrix%spin_type, & multiplicity = pmatrix%multiplicity, & anti = .false., & !!! SUFFICIENT? left_handed = pmatrix%chirality < 0, & right_handed = pmatrix%chirality > 0) if (pol%bv%is_polarized ()) then d = pol%bv%get_n_states () allocate (r (d, d), source = (0._default, 0._default)) if (d == pmatrix%multiplicity) then do i = 1, d r(i,i) = (1 - pmatrix%degree) / d end do else if (d > pmatrix%multiplicity) then r(1,1) = (1 - pmatrix%degree) / 2 r(d,d) = r(1,1) end if do k = 1, size (pmatrix%value) h1 = pmatrix%index(1,k) h2 = pmatrix%index(2,k) i = pol%bv%hel_index (h1) j = pol%bv%hel_index (h2) r(i,j) = r(i,j) + pmatrix%value(k) r(j,i) = conjg (r(i,j)) end do call pol%bv%set (r) end if end subroutine polarization_init_pmatrix @ %def polarization_init_pmatrix @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[polarizations_ut.f90]]>>= <> module polarizations_ut use unit_tests use polarizations_uti <> <> contains <> end module polarizations_ut @ %def polarizations_ut @ <<[[polarizations_uti.f90]]>>= <> module polarizations_uti <> use flavors use model_data use polarizations <> <> contains <> end module polarizations_uti @ %def polarizations_ut @ API: driver for the unit tests below. <>= public :: polarizations_test <>= subroutine polarizations_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine polarizations_test @ %def polarizations_test @ \subsubsection{Polarization type} Checking the setup for polarization. <>= call test (polarization_1, "polarization_1", & "check polarization setup", & u, results) <>= public :: polarization_1 <>= subroutine polarization_1 (u) use os_interface integer, intent(in) :: u type(model_data_t), target :: model type(polarization_t) :: pol type(flavor_t) :: flv real(default), dimension(3) :: alpha real(default) :: r, theta, phi real(default), parameter :: tolerance = 1.E-14_default write (u, "(A)") "* Test output: polarization_1" write (u, "(A)") "* Purpose: test polarization setup" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call model%init_sm_test () write (u, "(A)") "* Unpolarized fermion" write (u, "(A)") call flv%init (1, model) call pol%init_unpolarized (flv) call pol%write (u, state_matrix = .true.) write (u, "(A,L1)") " diagonal =", pol%is_diagonal () write (u, "(A)") write (u, "(A)") "* Unpolarized fermion" write (u, "(A)") call pol%init_circular (flv, 0._default) call pol%write (u, state_matrix = .true., all_states = .false.) write (u, "(A)") write (u, "(A)") "* Transversally polarized fermion, phi=0" write (u, "(A)") call pol%init_transversal (flv, 0._default, 1._default) call pol%write (u, state_matrix = .true.) write (u, "(A,L1)") " diagonal =", pol%is_diagonal () write (u, "(A)") write (u, "(A)") "* Transversally polarized fermion, phi=0.9, frac=0.8" write (u, "(A)") call pol%init_transversal (flv, 0.9_default, 0.8_default) call pol%write (u, state_matrix = .true.) write (u, "(A,L1)") " diagonal =", pol%is_diagonal () write (u, "(A)") write (u, "(A)") "* All polarization directions of a fermion" write (u, "(A)") call pol%init_generic (flv) call pol%write (u, state_matrix = .true.) call flv%init (21, model) write (u, "(A)") write (u, "(A)") "* Circularly polarized gluon, frac=0.3" write (u, "(A)") call pol%init_circular (flv, 0.3_default) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) call flv%init (23, model) write (u, "(A)") write (u, "(A)") "* Circularly polarized massive vector, frac=-0.7" write (u, "(A)") call pol%init_circular (flv, -0.7_default) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) write (u, "(A)") write (u, "(A)") "* Circularly polarized massive vector" write (u, "(A)") call pol%init_circular (flv, 1._default) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) write (u, "(A)") write (u, "(A)") "* Longitudinally polarized massive vector, frac=0.4" write (u, "(A)") call pol%init_longitudinal (flv, 0.4_default) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) write (u, "(A)") write (u, "(A)") "* Longitudinally polarized massive vector" write (u, "(A)") call pol%init_longitudinal (flv, 1._default) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) write (u, "(A)") write (u, "(A)") "* Diagonally polarized massive vector" write (u, "(A)") call pol%init_diagonal & (flv, [2._default, 1._default, 0._default]) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) write (u, "(A)") write (u, "(A)") "* All polarization directions of a massive vector" write (u, "(A)") call pol%init_generic (flv) call pol%write (u, state_matrix = .true.) call flv%init (21, model) write (u, "(A)") write (u, "(A)") "* Axis polarization (0.2, 0.4, 0.6)" write (u, "(A)") alpha = [0.2_default, 0.4_default, 0.6_default] call pol%init_axis (flv, alpha) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) write (u, "(A)") write (u, "(1X,A)") "Recovered axis:" alpha = pol%get_axis () write (u, "(3(1X,F10.7))") alpha write (u, "(A)") write (u, "(A)") "* Angle polarization (0.5, 0.6, -1)" r = 0.5_default theta = 0.6_default phi = -1._default call pol%init_angles (flv, r, theta, phi) write (u, "(A)") call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) write (u, "(A)") write (u, "(1X,A)") "Recovered parameters (r, theta, phi):" call pol%to_angles (r, theta, phi) write (u, "(3(1x,F10.7))") r, theta, phi call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: polarization_1" end subroutine polarization_1 @ %def polarization_1 @ \subsubsection{Sparse-Matrix type} Use a sparse density matrix universally as the input for setting up polarization. <>= call test (polarization_2, "polarization_2", & "matrix polarization setup", & u, results) <>= public :: polarization_2 <>= subroutine polarization_2 (u) use os_interface integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(polarization_t) :: pol real(default), dimension(3) :: alpha type(pmatrix_t) :: pmatrix real(default), parameter :: tolerance = 1e-8_default write (u, "(A)") "* Test output: polarization_2" write (u, "(A)") "* Purpose: matrix polarization setup" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call model%init_sm_test () write (u, "(A)") "* Unpolarized fermion" write (u, "(A)") call flv%init (1, model) call pmatrix%init (2, 0) call pmatrix%normalize (flv, 0._default, tolerance) call pmatrix%write (u) write (u, *) write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized () write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal () write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Transversally polarized fermion, phi=0" write (u, "(A)") call pmatrix%init (2, 3) call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default)) call pmatrix%set_entry (2, [+1,+1], (1._default, 0._default)) call pmatrix%set_entry (3, [-1,+1], (1._default, 0._default)) call pmatrix%normalize (flv, 1._default, tolerance) call pmatrix%write (u) write (u, *) write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized () write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal () write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Transversally polarized fermion, phi=0.9, frac=0.8" write (u, "(A)") call pmatrix%init (2, 3) call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default)) call pmatrix%set_entry (2, [+1,+1], (1._default, 0._default)) call pmatrix%set_entry (3, [-1,+1], exp ((0._default, -0.9_default))) call pmatrix%normalize (flv, 0.8_default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true.) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Left-handed massive fermion, frac=1" write (u, "(A)") call flv%init (11, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default)) call pmatrix%normalize (flv, 1._default, tolerance) call pmatrix%write (u) write (u, *) write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized () write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal () write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Left-handed massive fermion, frac=0.8" write (u, "(A)") call flv%init (11, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default)) call pmatrix%normalize (flv, 0.8_default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Left-handed massless fermion" write (u, "(A)") call flv%init (12, model) call pmatrix%init (2, 0) call pmatrix%normalize (flv, 1._default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true.) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Right-handed massless fermion, frac=0.5" write (u, "(A)") call flv%init (-12, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [1,1], (1._default, 0._default)) call pmatrix%normalize (flv, 0.5_default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true.) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Circularly polarized gluon, frac=0.3" write (u, "(A)") call flv%init (21, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [1,1], (1._default, 0._default)) call pmatrix%normalize (flv, 0.3_default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Circularly polarized massive vector, frac=0.7" write (u, "(A)") call flv%init (23, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [1,1], (1._default, 0._default)) call pmatrix%normalize (flv, 0.7_default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Circularly polarized massive vector" write (u, "(A)") call flv%init (23, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [1,1], (1._default, 0._default)) call pmatrix%normalize (flv, 1._default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Longitudinally polarized massive vector, frac=0.4" write (u, "(A)") call flv%init (23, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [0,0], (1._default, 0._default)) call pmatrix%normalize (flv, 0.4_default, tolerance) call pmatrix%write (u) write (u, *) write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized () write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal () write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Longitudinally polarized massive vector" write (u, "(A)") call flv%init (23, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [0,0], (1._default, 0._default)) call pmatrix%normalize (flv, 1._default, tolerance) call pmatrix%write (u) write (u, *) write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized () write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal () write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Axis polarization (0.2, 0.4, 0.6)" write (u, "(A)") call flv%init (11, model) alpha = [0.2_default, 0.4_default, 0.6_default] alpha = alpha / sqrt (sum (alpha**2)) call pmatrix%init (2, 3) call pmatrix%set_entry (1, [-1,-1], cmplx (1 - alpha(3), kind=default)) call pmatrix%set_entry (2, [1,-1], & cmplx (alpha(1),-alpha(2), kind=default)) call pmatrix%set_entry (3, [1,1], cmplx (1 + alpha(3), kind=default)) call pmatrix%normalize (flv, 1._default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true.) ! call pol%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: polarization_2" end subroutine polarization_2 @ %def polarization_2 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Particles} This module defines the [[particle_t]] object type, and the methods and operations that deal with it. <<[[particles.f90]]>>= <> module particles <> <> use io_units use format_utils, only: write_compressed_integer_array, write_separator use format_utils, only: pac_fmt use format_defs, only: FMT_16, FMT_19 use numeric_utils use diagnostics use lorentz use model_data use flavors use colors use helicities use quantum_numbers use state_matrices use interactions use subevents use polarizations use pdg_arrays, only: is_quark, is_gluon <> <> <> <> <> contains <> end module particles @ %def particles @ \subsection{The particle type} \subsubsection{Particle status codes} The overall status codes (incoming/outgoing etc.) are inherited from the module [[subevents]]. Polarization status: <>= integer, parameter, public :: PRT_UNPOLARIZED = 0 integer, parameter, public :: PRT_DEFINITE_HELICITY = 1 integer, parameter, public :: PRT_GENERIC_POLARIZATION = 2 @ %def PRT_UNPOLARIZED PRT_DEFINITE_HELICITY PRT_GENERIC_POLARIZATION @ \subsubsection{Definition} The quantum numbers are flavor (from which invariant particle properties can be derived), color, and polarization. The particle may be unpolarized. In this case, [[hel]] and [[pol]] are unspecified. If it has a definite helicity, the [[hel]] component is defined. If it has a generic polarization, the [[pol]] component is defined. For each particle we store the four-momentum and the invariant mass squared, i.e., the squared norm of the four-momentum. There is also an optional list of parent and child particles, for bookkeeping in physical events. The [[vertex]] is an optional component that consists of a Lorentz 4-vector, denoting the position and time of the vertex (displaced vertex/time). [[lifetime]] is an optional component that accounts for the finite lifetime $\tau$ of a decaying particle. In case there is no magnetic field etc., the true decay vertex of a particle in the detector would be $\vec{v}^\prime = \vec{v} + \tau \times \vec{p}/p^0$, where $p^0$ and $\vec{p}$ are the energy and 3-momentum of the particle. <>= public :: particle_t <>= type :: particle_t !private integer :: status = PRT_UNDEFINED integer :: polarization = PRT_UNPOLARIZED type(flavor_t) :: flv type(color_t) :: col type(helicity_t) :: hel type(polarization_t) :: pol type(vector4_t) :: p = vector4_null real(default) :: p2 = 0 type(vector4_t), allocatable :: vertex real(default), allocatable :: lifetime integer, dimension(:), allocatable :: parent integer, dimension(:), allocatable :: child contains <> end type particle_t @ %def particle_t @ Copy a particle. (Deep copy) This excludes the parent-child relations. <>= generic :: init => init_particle procedure :: init_particle => particle_init_particle <>= subroutine particle_init_particle (prt_out, prt_in) class(particle_t), intent(out) :: prt_out type(particle_t), intent(in) :: prt_in prt_out%status = prt_in%status prt_out%polarization = prt_in%polarization prt_out%flv = prt_in%flv prt_out%col = prt_in%col prt_out%hel = prt_in%hel prt_out%pol = prt_in%pol prt_out%p = prt_in%p prt_out%p2 = prt_in%p2 if (allocated (prt_in%vertex)) & allocate (prt_out%vertex, source=prt_in%vertex) if (allocated (prt_in%lifetime)) & allocate (prt_out%lifetime, source=prt_in%lifetime) end subroutine particle_init_particle @ %def particle_init_particle @ Initialize a particle using external information. <>= generic :: init => init_external procedure :: init_external => particle_init_external <>= subroutine particle_init_external & (particle, status, pdg, model, col, anti_col, mom) class(particle_t), intent(out) :: particle integer, intent(in) :: status, pdg, col, anti_col class(model_data_t), pointer, intent(in) :: model type(vector4_t), intent(in) :: mom type(flavor_t) :: flavor type(color_t) :: color call flavor%init (pdg, model) call particle%set_flavor (flavor) call color%init_col_acl (col, anti_col) call particle%set_color (color) call particle%set_status (status) call particle%set_momentum (mom) end subroutine particle_init_external @ %def particle_init_external @ Initialize a particle using a single-particle state matrix which determines flavor, color, and polarization. The state matrix must have unique flavor and color. The factorization mode determines whether the particle is unpolarized, has definite helicity, or generic polarization. This mode is translated into the polarization status. <>= generic :: init => init_state procedure :: init_state => particle_init_state <>= subroutine particle_init_state (prt, state, status, mode) class(particle_t), intent(out) :: prt type(state_matrix_t), intent(in), target :: state integer, intent(in) :: status, mode type(state_iterator_t) :: it prt%status = status call it%init (state) prt%flv = it%get_flavor (1) if (prt%flv%is_radiated ()) prt%status = PRT_BEAM_REMNANT prt%col = it%get_color (1) select case (mode) case (FM_SELECT_HELICITY) prt%hel = it%get_helicity (1) if (prt%hel%is_defined ()) then prt%polarization = PRT_DEFINITE_HELICITY end if case (FM_FACTOR_HELICITY) call prt%pol%init_state_matrix (state) prt%polarization = PRT_GENERIC_POLARIZATION end select end subroutine particle_init_state @ %def particle_init_state @ Finalizer. <>= procedure :: final => particle_final <>= subroutine particle_final (prt) class(particle_t), intent(inout) :: prt if (allocated (prt%vertex)) deallocate (prt%vertex) if (allocated (prt%lifetime)) deallocate (prt%lifetime) end subroutine particle_final @ %def particle_final @ \subsubsection{I/O} <>= procedure :: write => particle_write <>= subroutine particle_write (prt, unit, testflag, compressed, polarization) class(particle_t), intent(in) :: prt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag, compressed, polarization logical :: comp, pacified, pol integer :: u, h1, h2 real(default) :: pp2 character(len=7) :: fmt character(len=20) :: buffer comp = .false.; if (present (compressed)) comp = compressed pacified = .false.; if (present (testflag)) pacified = testflag pol = .true.; if (present (polarization)) pol = polarization call pac_fmt (fmt, FMT_19, FMT_16, testflag) u = given_output_unit (unit); if (u < 0) return pp2 = prt%p2 if (pacified) call pacify (pp2, tolerance = 1E-10_default) select case (prt%status) case (PRT_UNDEFINED); write (u, "(1x, A)", advance="no") "[-]" case (PRT_BEAM); write (u, "(1x, A)", advance="no") "[b]" case (PRT_INCOMING); write (u, "(1x, A)", advance="no") "[i]" case (PRT_OUTGOING); write (u, "(1x, A)", advance="no") "[o]" case (PRT_VIRTUAL); write (u, "(1x, A)", advance="no") "[v]" case (PRT_RESONANT); write (u, "(1x, A)", advance="no") "[r]" case (PRT_BEAM_REMNANT); write (u, "(1x, A)", advance="no") "[x]" end select write (u, "(1x)", advance="no") if (comp) then write (u, "(A7,1X)", advance="no") char (prt%flv%get_name ()) if (pol) then select case (prt%polarization) case (PRT_DEFINITE_HELICITY) ! Integer helicity, assumed diagonal call prt%hel%get_indices (h1, h2) write (u, "(I2,1X)", advance="no") h1 case (PRT_GENERIC_POLARIZATION) ! No space for full density matrix here write (u, "(A2,1X)", advance="no") "*" case default ! Blank entry if helicity is undefined write (u, "(A2,1X)", advance="no") " " end select end if write (u, "(2(I4,1X))", advance="no") & prt%col%get_col (), prt%col%get_acl () call write_compressed_integer_array (buffer, prt%parent) write (u, "(A,1X)", advance="no") buffer call write_compressed_integer_array (buffer, prt%child) write (u, "(A,1X)", advance="no") buffer call prt%p%write(u, testflag = testflag, compressed = comp) write (u, "(F12.3)") pp2 else call prt%flv%write (unit) if (prt%col%is_nonzero ()) then call color_write (prt%col, unit) end if if (pol) then select case (prt%polarization) case (PRT_DEFINITE_HELICITY) call prt%hel%write (unit) write (u, *) case (PRT_GENERIC_POLARIZATION) write (u, *) call prt%pol%write (unit, state_matrix = .true.) case default write (u, *) end select else write (u, *) end if call prt%p%write (unit, testflag = testflag) write (u, "(1x,A,1x," // fmt // ")") "T = ", pp2 if (allocated (prt%parent)) then if (size (prt%parent) /= 0) then write (u, "(1x,A,40(1x,I0))") "Parents: ", prt%parent end if end if if (allocated (prt%child)) then if (size (prt%child) /= 0) then write (u, "(1x,A,40(1x,I0))") "Children:", prt%child end if end if if (allocated (prt%vertex)) then write (u, "(1x,A,1x," // fmt // ")") "Vtx t = ", prt%vertex%p(0) write (u, "(1x,A,1x," // fmt // ")") "Vtx x = ", prt%vertex%p(1) write (u, "(1x,A,1x," // fmt // ")") "Vtx y = ", prt%vertex%p(2) write (u, "(1x,A,1x," // fmt // ")") "Vtx z = ", prt%vertex%p(3) end if if (allocated (prt%lifetime)) then write (u, "(1x,A,1x," // fmt // ")") "Lifetime = ", & prt%lifetime end if end if end subroutine particle_write @ %def particle_write @ Binary I/O: <>= procedure :: write_raw => particle_write_raw procedure :: read_raw => particle_read_raw <>= subroutine particle_write_raw (prt, u) class(particle_t), intent(in) :: prt integer, intent(in) :: u write (u) prt%status, prt%polarization call prt%flv%write_raw (u) call prt%col%write_raw (u) select case (prt%polarization) case (PRT_DEFINITE_HELICITY) call prt%hel%write_raw (u) case (PRT_GENERIC_POLARIZATION) call prt%pol%write_raw (u) end select call vector4_write_raw (prt%p, u) write (u) prt%p2 write (u) allocated (prt%parent) if (allocated (prt%parent)) then write (u) size (prt%parent) write (u) prt%parent end if write (u) allocated (prt%child) if (allocated (prt%child)) then write (u) size (prt%child) write (u) prt%child end if write (u) allocated (prt%vertex) if (allocated (prt%vertex)) then call vector4_write_raw (prt%vertex, u) end if write (u) allocated (prt%lifetime) if (allocated (prt%lifetime)) then write (u) prt%lifetime end if end subroutine particle_write_raw subroutine particle_read_raw (prt, u, iostat) class(particle_t), intent(out) :: prt integer, intent(in) :: u integer, intent(out) :: iostat logical :: allocated_parent, allocated_child logical :: allocated_vertex, allocated_lifetime integer :: size_parent, size_child read (u, iostat=iostat) prt%status, prt%polarization call prt%flv%read_raw (u, iostat=iostat) call prt%col%read_raw (u, iostat=iostat) select case (prt%polarization) case (PRT_DEFINITE_HELICITY) call prt%hel%read_raw (u, iostat=iostat) case (PRT_GENERIC_POLARIZATION) call prt%pol%read_raw (u, iostat=iostat) end select call vector4_read_raw (prt%p, u, iostat=iostat) read (u, iostat=iostat) prt%p2 read (u, iostat=iostat) allocated_parent if (allocated_parent) then read (u, iostat=iostat) size_parent allocate (prt%parent (size_parent)) read (u, iostat=iostat) prt%parent end if read (u, iostat=iostat) allocated_child if (allocated_child) then read (u, iostat=iostat) size_child allocate (prt%child (size_child)) read (u, iostat=iostat) prt%child end if read (u, iostat=iostat) allocated_vertex if (allocated_vertex) then allocate (prt%vertex) read (u, iostat=iostat) prt%vertex%p end if read (u, iostat=iostat) allocated_lifetime if (allocated_lifetime) then allocate (prt%lifetime) read (u, iostat=iostat) prt%lifetime end if end subroutine particle_read_raw @ %def particle_write_raw particle_read_raw @ \subsubsection{Setting contents} Reset the status code. Where applicable, set $p^2$ assuming that the particle is on-shell. <>= procedure :: reset_status => particle_reset_status <>= elemental subroutine particle_reset_status (prt, status) class(particle_t), intent(inout) :: prt integer, intent(in) :: status prt%status = status select case (status) case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING) prt%p2 = prt%flv%get_mass () ** 2 end select end subroutine particle_reset_status @ %def particle_reset_status @ The color can be given explicitly. <>= procedure :: set_color => particle_set_color <>= elemental subroutine particle_set_color (prt, col) class(particle_t), intent(inout) :: prt type(color_t), intent(in) :: col prt%col = col end subroutine particle_set_color @ %def particle_set_color @ The flavor can be given explicitly. <>= procedure :: set_flavor => particle_set_flavor <>= subroutine particle_set_flavor (prt, flv) class(particle_t), intent(inout) :: prt type(flavor_t), intent(in) :: flv prt%flv = flv end subroutine particle_set_flavor @ %def particle_set_flavor @ As can the helicity. <>= procedure :: set_helicity => particle_set_helicity <>= subroutine particle_set_helicity (prt, hel) class(particle_t), intent(inout) :: prt type(helicity_t), intent(in) :: hel prt%hel = hel end subroutine particle_set_helicity @ %def particle_set_helicity @ And the polarization. <>= procedure :: set_pol => particle_set_pol <>= subroutine particle_set_pol (prt, pol) class(particle_t), intent(inout) :: prt type(polarization_t), intent(in) :: pol prt%pol = pol end subroutine particle_set_pol @ %def particle_set_pol @ Manually set the model for the particle flavor. This is required, e.g., if the particle has been read from file. <>= procedure :: set_model => particle_set_model <>= subroutine particle_set_model (prt, model) class(particle_t), intent(inout) :: prt class(model_data_t), intent(in), target :: model call prt%flv%set_model (model) end subroutine particle_set_model @ %def particle_set_model @ The momentum is set independent of the quantum numbers. <>= procedure :: set_momentum => particle_set_momentum <>= elemental subroutine particle_set_momentum (prt, p, p2, on_shell) class(particle_t), intent(inout) :: prt type(vector4_t), intent(in) :: p real(default), intent(in), optional :: p2 logical, intent(in), optional :: on_shell prt%p = p if (present (on_shell)) then if (on_shell) then if (prt%flv%is_associated ()) then prt%p2 = prt%flv%get_mass () ** 2 return end if end if end if if (present (p2)) then prt%p2 = p2 else prt%p2 = p ** 2 end if end subroutine particle_set_momentum @ %def particle_set_momentum @ Set resonance information. This should be done after momentum assignment, because we need to know wheter the particle is spacelike or timelike. The resonance flag is defined only for virtual particles. <>= procedure :: set_resonance_flag => particle_set_resonance_flag <>= elemental subroutine particle_set_resonance_flag (prt, resonant) class(particle_t), intent(inout) :: prt logical, intent(in) :: resonant select case (prt%status) case (PRT_VIRTUAL) if (resonant) prt%status = PRT_RESONANT end select end subroutine particle_set_resonance_flag @ %def particle_set_resonance_flag @ Set children and parents information. <>= procedure :: set_children => particle_set_children procedure :: set_parents => particle_set_parents <>= subroutine particle_set_children (prt, idx) class(particle_t), intent(inout) :: prt integer, dimension(:), intent(in) :: idx if (allocated (prt%child)) deallocate (prt%child) allocate (prt%child (count (idx /= 0))) prt%child = pack (idx, idx /= 0) end subroutine particle_set_children subroutine particle_set_parents (prt, idx) class(particle_t), intent(inout) :: prt integer, dimension(:), intent(in) :: idx if (allocated (prt%parent)) deallocate (prt%parent) allocate (prt%parent (count (idx /= 0))) prt%parent = pack (idx, idx /= 0) end subroutine particle_set_parents @ %def particle_set_children particle_set_parents @ <>= procedure :: add_child => particle_add_child <>= subroutine particle_add_child (prt, new_child) class(particle_t), intent(inout) :: prt integer, intent(in) :: new_child integer, dimension(:), allocatable :: idx integer :: n, i n = prt%get_n_children() if (n == 0) then call prt%set_children ([new_child]) else do i = 1, n if (prt%child(i) == new_child) then return end if end do allocate (idx (1:n+1)) idx(1:n) = prt%get_children () idx(n+1) = new_child call prt%set_children (idx) end if end subroutine particle_add_child @ %def particle_add_child @ <>= procedure :: add_children => particle_add_children <>= subroutine particle_add_children (prt, new_child) class(particle_t), intent(inout) :: prt integer, dimension(:), intent(in) :: new_child integer, dimension(:), allocatable :: idx integer :: n n = prt%get_n_children() if (n == 0) then call prt%set_children (new_child) else allocate (idx (1:n+size(new_child))) idx(1:n) = prt%get_children () idx(n+1:n+size(new_child)) = new_child call prt%set_children (idx) end if end subroutine particle_add_children @ %def particle_add_children @ <>= procedure :: set_status => particle_set_status <>= elemental subroutine particle_set_status (prt, status) class(particle_t), intent(inout) :: prt integer, intent(in) :: status prt%status = status end subroutine particle_set_status @ %def particle_set_status @ <>= procedure :: set_polarization => particle_set_polarization <>= subroutine particle_set_polarization (prt, polarization) class(particle_t), intent(inout) :: prt integer, intent(in) :: polarization prt%polarization = polarization end subroutine particle_set_polarization @ %def particle_set_polarization @ <>= generic :: set_vertex => set_vertex_from_vector3, set_vertex_from_xyz, & set_vertex_from_vector4, set_vertex_from_xyzt procedure :: set_vertex_from_vector4 => particle_set_vertex_from_vector4 procedure :: set_vertex_from_vector3 => particle_set_vertex_from_vector3 procedure :: set_vertex_from_xyzt => particle_set_vertex_from_xyzt procedure :: set_vertex_from_xyz => particle_set_vertex_from_xyz <>= subroutine particle_set_vertex_from_vector4 (prt, vertex) class(particle_t), intent(inout) :: prt type(vector4_t), intent(in) :: vertex if (allocated (prt%vertex)) deallocate (prt%vertex) allocate (prt%vertex, source=vertex) end subroutine particle_set_vertex_from_vector4 subroutine particle_set_vertex_from_vector3 (prt, vertex) class(particle_t), intent(inout) :: prt type(vector3_t), intent(in) :: vertex type(vector4_t) :: vtx vtx = vector4_moving (0._default, vertex) if (allocated (prt%vertex)) deallocate (prt%vertex) allocate (prt%vertex, source=vtx) end subroutine particle_set_vertex_from_vector3 subroutine particle_set_vertex_from_xyzt (prt, vx, vy, vz, t) class(particle_t), intent(inout) :: prt real(default), intent(in) :: vx, vy, vz, t type(vector4_t) :: vertex if (allocated (prt%vertex)) deallocate (prt%vertex) vertex = vector4_moving (t, vector3_moving ([vx, vy, vz])) allocate (prt%vertex, source=vertex) end subroutine particle_set_vertex_from_xyzt subroutine particle_set_vertex_from_xyz (prt, vx, vy, vz) class(particle_t), intent(inout) :: prt real(default), intent(in) :: vx, vy, vz type(vector4_t) :: vertex if (allocated (prt%vertex)) deallocate (prt%vertex) vertex = vector4_moving (0._default, vector3_moving ([vx, vy, vz])) allocate (prt%vertex, source=vertex) end subroutine particle_set_vertex_from_xyz @ %def particle_set_vertex_from_vector3 @ %def particle_set_vertex_from_vector4 @ %def particle_set_vertex_from_xyz @ %def particle_set_vertex_from_xyzt @ Set the lifetime of a particle. <>= procedure :: set_lifetime => particle_set_lifetime <>= elemental subroutine particle_set_lifetime (prt, lifetime) class(particle_t), intent(inout) :: prt real(default), intent(in) :: lifetime if (allocated (prt%lifetime)) deallocate (prt%lifetime) allocate (prt%lifetime, source=lifetime) end subroutine particle_set_lifetime @ %def particle_set_lifetime @ \subsubsection{Accessing contents} The status code. <>= procedure :: get_status => particle_get_status <>= elemental function particle_get_status (prt) result (status) integer :: status class(particle_t), intent(in) :: prt status = prt%status end function particle_get_status @ %def particle_get_status @ Return true if the status is either [[INCOMING]], [[OUTGOING]] or [[RESONANT]]. [[BEAM]] is kept, if [[keep_beams]] is set true. <>= procedure :: is_real => particle_is_real <>= elemental function particle_is_real (prt, keep_beams) result (flag) logical :: flag, kb class(particle_t), intent(in) :: prt logical, intent(in), optional :: keep_beams kb = .false. if (present (keep_beams)) kb = keep_beams select case (prt%status) case (PRT_INCOMING, PRT_OUTGOING, PRT_RESONANT) flag = .true. case (PRT_BEAM) flag = kb case default flag = .false. end select end function particle_is_real @ %def particle_is_real @ <>= procedure :: is_colored => particle_is_colored <>= elemental function particle_is_colored (particle) result (flag) logical :: flag class(particle_t), intent(in) :: particle flag = particle%col%is_nonzero () end function particle_is_colored @ %def particle_is_colored @ $[90,100]$ hopefully catches all of them and not too many. <>= procedure :: is_hadronic_beam_remnant => particle_is_hadronic_beam_remnant <>= elemental function particle_is_hadronic_beam_remnant (particle) result (flag) class(particle_t), intent(in) :: particle logical :: flag integer :: pdg pdg = particle%flv%get_pdg () flag = particle%status == PRT_BEAM_REMNANT .and. & abs(pdg) >= 90 .and. abs(pdg) <= 100 end function particle_is_hadronic_beam_remnant @ %def particle_is_hadronic_beam_remnant @ <>= procedure :: is_beam_remnant => particle_is_beam_remnant <>= elemental function particle_is_beam_remnant (particle) result (flag) class(particle_t), intent(in) :: particle logical :: flag flag = particle%status == PRT_BEAM_REMNANT end function particle_is_beam_remnant @ %def particle_is_beam_remnant @ Polarization status. <>= procedure :: get_polarization_status => particle_get_polarization_status <>= elemental function particle_get_polarization_status (prt) result (status) integer :: status class(particle_t), intent(in) :: prt status = prt%polarization end function particle_get_polarization_status @ %def particle_get_polarization_status @ Return the PDG code from the flavor component directly. <>= procedure :: get_pdg => particle_get_pdg <>= elemental function particle_get_pdg (prt) result (pdg) integer :: pdg class(particle_t), intent(in) :: prt pdg = prt%flv%get_pdg () end function particle_get_pdg @ %def particle_get_pdg @ Return the color and anticolor quantum numbers. <>= procedure :: get_color => particle_get_color <>= pure function particle_get_color (prt) result (col) integer, dimension(2) :: col class(particle_t), intent(in) :: prt col(1) = prt%col%get_col () col(2) = prt%col%get_acl () end function particle_get_color @ %def particle_get_color @ Return a copy of the polarization density matrix. <>= procedure :: get_polarization => particle_get_polarization <>= function particle_get_polarization (prt) result (pol) class(particle_t), intent(in) :: prt type(polarization_t) :: pol pol = prt%pol end function particle_get_polarization @ %def particle_get_polarization @ Return the flavor, color and helicity. <>= procedure :: get_flv => particle_get_flv procedure :: get_col => particle_get_col procedure :: get_hel => particle_get_hel <>= function particle_get_flv (prt) result (flv) class(particle_t), intent(in) :: prt type(flavor_t) :: flv flv = prt%flv end function particle_get_flv function particle_get_col (prt) result (col) class(particle_t), intent(in) :: prt type(color_t) :: col col = prt%col end function particle_get_col function particle_get_hel (prt) result (hel) class(particle_t), intent(in) :: prt type(helicity_t) :: hel hel = prt%hel end function particle_get_hel @ %def particle_get_flv particle_get_col particle_get_hel @ Return the helicity (if defined and diagonal). <>= procedure :: get_helicity => particle_get_helicity <>= elemental function particle_get_helicity (prt) result (hel) integer :: hel integer, dimension(2) :: hel_arr class(particle_t), intent(in) :: prt hel = 0 if (prt%hel%is_defined () .and. prt%hel%is_diagonal ()) then hel_arr = prt%hel%to_pair () hel = hel_arr (1) end if end function particle_get_helicity @ %def particle_get_helicity @ Return the number of children/parents <>= procedure :: get_n_parents => particle_get_n_parents procedure :: get_n_children => particle_get_n_children <>= elemental function particle_get_n_parents (prt) result (n) integer :: n class(particle_t), intent(in) :: prt if (allocated (prt%parent)) then n = size (prt%parent) else n = 0 end if end function particle_get_n_parents elemental function particle_get_n_children (prt) result (n) integer :: n class(particle_t), intent(in) :: prt if (allocated (prt%child)) then n = size (prt%child) else n = 0 end if end function particle_get_n_children @ %def particle_get_n_parents particle_get_n_children @ Return the array of parents/children. <>= procedure :: get_parents => particle_get_parents procedure :: get_children => particle_get_children <>= function particle_get_parents (prt) result (parent) class(particle_t), intent(in) :: prt integer, dimension(:), allocatable :: parent if (allocated (prt%parent)) then allocate (parent (size (prt%parent))) parent = prt%parent else allocate (parent (0)) end if end function particle_get_parents function particle_get_children (prt) result (child) class(particle_t), intent(in) :: prt integer, dimension(:), allocatable :: child if (allocated (prt%child)) then allocate (child (size (prt%child))) child = prt%child else allocate (child (0)) end if end function particle_get_children @ %def particle_get_children @ <>= procedure :: has_children => particle_has_children <>= elemental function particle_has_children (prt) result (has_children) logical :: has_children class(particle_t), intent(in) :: prt has_children = .false. if (allocated (prt%child)) then has_children = size (prt%child) > 0 end if end function particle_has_children @ %def particle_has_children @ <>= procedure :: has_parents => particle_has_parents <>= elemental function particle_has_parents (prt) result (has_parents) logical :: has_parents class(particle_t), intent(in) :: prt has_parents = .false. if (allocated (prt%parent)) then has_parents = size (prt%parent) > 0 end if end function particle_has_parents @ %def particle_has_parents @ Return momentum and momentum squared. <>= procedure :: get_momentum => particle_get_momentum procedure :: get_p2 => particle_get_p2 <>= elemental function particle_get_momentum (prt) result (p) type(vector4_t) :: p class(particle_t), intent(in) :: prt p = prt%p end function particle_get_momentum elemental function particle_get_p2 (prt) result (p2) real(default) :: p2 class(particle_t), intent(in) :: prt p2 = prt%p2 end function particle_get_p2 @ %def particle_get_momentum particle_get_p2 @ Return the particle vertex, if allocated. <>= procedure :: get_vertex => particle_get_vertex <>= elemental function particle_get_vertex (prt) result (vtx) type(vector4_t) :: vtx class(particle_t), intent(in) :: prt if (allocated (prt%vertex)) then vtx = prt%vertex else vtx = vector4_null end if end function particle_get_vertex @ %def particle_get_vertex @ Return the lifetime of a particle. <>= procedure :: get_lifetime => particle_get_lifetime <>= elemental function particle_get_lifetime (prt) result (lifetime) real(default) :: lifetime class(particle_t), intent(in) :: prt if (allocated (prt%lifetime)) then lifetime = prt%lifetime else lifetime = 0 end if end function particle_get_lifetime @ %def particle_get_lifetime @ <>= procedure :: momentum_to_pythia6 => particle_momentum_to_pythia6 <>= pure function particle_momentum_to_pythia6 (prt) result (p) real(double), dimension(1:5) :: p class(particle_t), intent(in) :: prt p = prt%p%to_pythia6 (sqrt (prt%p2)) end function particle_momentum_to_pythia6 @ %def particle_momentum_to_pythia6 @ \subsection{Particle sets} A particle set is what is usually called an event: an array of particles. The individual particle entries carry momentum, quantum numbers, polarization, and optionally connections. There is (also optionally) a correlated state-density matrix that maintains spin correlations that are lost in the individual particle entries. - -TODO: consider making this opaque (PRIVATE), might require some additional -access methods. <>= public :: particle_set_t <>= type :: particle_set_t ! private !!! integer :: n_beam = 0 integer :: n_in = 0 integer :: n_vir = 0 integer :: n_out = 0 integer :: n_tot = 0 integer :: factorization_mode = FM_IGNORE_HELICITY type(particle_t), dimension(:), allocatable :: prt type(state_matrix_t) :: correlated_state contains <> end type particle_set_t @ %def particle_set_t @ A particle set can be initialized from an interaction or from a HepMC event record. <>= generic :: init => init_interaction procedure :: init_interaction => particle_set_init_interaction @ When a particle set is initialized from a given interaction, we have to determine the branch within the original state matrix that fixes the particle quantum numbers. This is done with the appropriate probabilities, based on a random number [[x]]. The [[mode]] determines whether the individual particles become unpolarized, or take a definite (diagonal) helicity, or acquire single-particle polarization matrices. The flag [[keep_correlations]] tells whether the spin-correlation matrix is to be calculated and stored in addition to the particles. The flag [[keep_virtual]] tells whether virtual particles should be dropped. Note that if virtual particles are dropped, the spin-correlation matrix makes no sense, and parent-child relations are not set. For a correct disentangling of color and flavor (in the presence of helicity), we consider two interactions. [[int]] has no color information, and is used to select a flavor state. Consequently, we trace over helicities here. [[int_flows]] contains color-flow and potentially helicity information, but is useful only after the flavor combination has been chosen. So this interaction is used to select helicity and color, but restricted to the selected flavor combination. [[int]] and [[int_flows]] may be identical if there is only a single (or no) color flow. If there is just a single flavor combination, [[x(1)]] can be set to zero. The current algorithm of evaluator convolution requires that the beam particles are assumed outgoing (in the beam interaction) and become virtual in all derived interactions. In the particle set they should be re-identified as incoming. The optional integer [[n_incoming]] can be used to perform this correction. The flag [[is_valid]] is false if factorization of the state is not possible, in particular if the squared matrix element is zero. <>= subroutine particle_set_init_interaction & (particle_set, is_valid, int, int_flows, mode, x, & keep_correlations, keep_virtual, n_incoming, qn_select) class(particle_set_t), intent(out) :: particle_set logical, intent(out) :: is_valid type(interaction_t), intent(in), target :: int, int_flows integer, intent(in) :: mode real(default), dimension(2), intent(in) :: x logical, intent(in) :: keep_correlations, keep_virtual integer, intent(in), optional :: n_incoming type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_select type(state_matrix_t), dimension(:), allocatable, target :: flavor_state type(state_matrix_t), dimension(:), allocatable, target :: single_state integer :: n_in, n_vir, n_out, n_tot type(quantum_numbers_t), dimension(:,:), allocatable :: qn logical :: ok integer :: i, j if (present (n_incoming)) then n_in = n_incoming n_vir = int%get_n_vir () - n_incoming else n_in = int%get_n_in () n_vir = int%get_n_vir () end if n_out = int%get_n_out () n_tot = int%get_n_tot () particle_set%n_in = n_in particle_set%n_out = n_out if (keep_virtual) then particle_set%n_vir = n_vir particle_set%n_tot = n_tot else particle_set%n_vir = 0 particle_set%n_tot = n_in + n_out end if particle_set%factorization_mode = mode allocate (qn (n_tot, 1)) if (.not. present (qn_select)) then call int%factorize & (FM_IGNORE_HELICITY, x(1), is_valid, flavor_state) do i = 1, n_tot qn(i,:) = flavor_state(i)%get_quantum_number (1) end do else do i = 1, n_tot qn(i,:) = qn_select(i) end do end if if (keep_correlations .and. keep_virtual) then call particle_set%correlated_state%final () call int_flows%factorize (mode, x(2), ok, & single_state, particle_set%correlated_state, qn(:,1)) else call int_flows%factorize (mode, x(2), ok, & single_state, qn_in=qn(:,1)) end if is_valid = is_valid .and. ok allocate (particle_set%prt (particle_set%n_tot)) j = 1 do i = 1, n_tot if (i <= n_in) then call particle_set%prt(j)%init (single_state(i), PRT_INCOMING, mode) call particle_set%prt(j)%set_momentum (int%get_momentum (i)) else if (i <= n_in + n_vir) then if (.not. keep_virtual) cycle call particle_set%prt(j)%init & (single_state(i), PRT_VIRTUAL, mode) call particle_set%prt(j)%set_momentum (int%get_momentum (i)) else call particle_set%prt(j)%init (single_state(i), PRT_OUTGOING, mode) call particle_set%prt(j)%set_momentum & (int%get_momentum (i), on_shell = .true.) end if if (keep_virtual) then call particle_set%prt(j)%set_children & (interaction_get_children (int, i)) call particle_set%prt(j)%set_parents & (interaction_get_parents (int, i)) end if j = j + 1 end do if (keep_virtual) then call particle_set_resonance_flag & (particle_set%prt, int%get_resonance_flags ()) end if if (allocated (flavor_state)) then do i = 1, size(flavor_state) call flavor_state(i)%final () end do end if do i = 1, size(single_state) call single_state(i)%final () end do end subroutine particle_set_init_interaction @ %def particle_set_init_interaction @ Duplicate generic binding, to make sure that assignment works as it should. <>= generic :: assignment(=) => init_particle_set generic :: init => init_particle_set procedure :: init_particle_set => particle_set_init_particle_set <>= subroutine particle_set_init_particle_set (pset_out, pset_in) class(particle_set_t), intent(out) :: pset_out type(particle_set_t), intent(in) :: pset_in integer :: i pset_out%n_beam = pset_in%n_beam pset_out%n_in = pset_in%n_in pset_out%n_vir = pset_in%n_vir pset_out%n_out = pset_in%n_out pset_out%n_tot = pset_in%n_tot pset_out%factorization_mode = pset_in%factorization_mode if (allocated (pset_in%prt)) then allocate (pset_out%prt (size (pset_in%prt))) do i = 1, size (pset_in%prt) pset_out%prt(i) = pset_in%prt(i) end do end if pset_out%correlated_state = pset_in%correlated_state end subroutine particle_set_init_particle_set @ %def particle_set_init_particle_set @ Manually set the model for the stored particles. <>= procedure :: set_model => particle_set_set_model <>= subroutine particle_set_set_model (particle_set, model) class(particle_set_t), intent(inout) :: particle_set class(model_data_t), intent(in), target :: model integer :: i do i = 1, particle_set%n_tot call particle_set%prt(i)%set_model (model) end do call particle_set%correlated_state%set_model (model) end subroutine particle_set_set_model @ %def particle_set_set_model @ Pointer components are hidden inside the particle polarization, and in the correlated state matrix. <>= procedure :: final => particle_set_final <>= subroutine particle_set_final (particle_set) class(particle_set_t), intent(inout) :: particle_set integer :: i if (allocated (particle_set%prt)) then do i = 1, size(particle_set%prt) call particle_set%prt(i)%final () end do deallocate (particle_set%prt) end if call particle_set%correlated_state%final () end subroutine particle_set_final @ %def particle_set_final @ \subsection{Manual build} Basic initialization. Just allocate with a given number of beam, incoming, virtual, and outgoing particles. <>= procedure :: basic_init => particle_set_basic_init <>= subroutine particle_set_basic_init (particle_set, n_beam, n_in, n_vir, n_out) class(particle_set_t), intent(out) :: particle_set integer, intent(in) :: n_beam, n_in, n_vir, n_out particle_set%n_beam = n_beam particle_set%n_in = n_in particle_set%n_vir = n_vir particle_set%n_out = n_out particle_set%n_tot = n_beam + n_in + n_vir + n_out allocate (particle_set%prt (particle_set%n_tot)) end subroutine particle_set_basic_init @ %def particle_set_basic_init @ Build a particle set from scratch. This is used for testing purposes. The ordering of particles in the result is beam-incoming-remnant-virtual-outgoing. Parent-child relations: \begin{itemize} \item Beams are parents of incoming and beam remnants. The assignment is alternating (first beam, second beam). \item Incoming are parents of virtual and outgoing, collectively. \end{itemize} More specific settings, such as resonance histories, cannot be set this way. Beam-remnant particles are counted as virtual, but have a different status code. We assume that the [[pdg]] array has the correct size. <>= procedure :: init_direct => particle_set_init_direct <>= subroutine particle_set_init_direct (particle_set, & n_beam, n_in, n_rem, n_vir, n_out, pdg, model) class(particle_set_t), intent(out) :: particle_set integer, intent(in) :: n_beam integer, intent(in) :: n_in integer, intent(in) :: n_rem integer, intent(in) :: n_vir integer, intent(in) :: n_out integer, dimension(:), intent(in) :: pdg class(model_data_t), intent(in), target :: model type(flavor_t), dimension(:), allocatable :: flv integer :: i, k, n call particle_set%basic_init (n_beam, n_in, n_rem+n_vir, n_out) n = 0 call particle_set%prt(n+1:n+n_beam)%reset_status (PRT_BEAM) do i = n+1, n+n_beam call particle_set%prt(i)%set_children & ([(k, k=i+n_beam, n+n_beam+n_in+n_rem, 2)]) end do n = n + n_beam call particle_set%prt(n+1:n+n_in)%reset_status (PRT_INCOMING) do i = n+1, n+n_in if (n_beam > 0) then call particle_set%prt(i)%set_parents & ([i-n_beam]) end if call particle_set%prt(i)%set_children & ([(k, k=n+n_in+n_rem+1, n+n_in+n_rem+n_vir+n_out)]) end do n = n + n_in call particle_set%prt(n+1:n+n_rem)%reset_status (PRT_BEAM_REMNANT) do i = n+1, n+n_rem if (n_beam > 0) then call particle_set%prt(i)%set_parents & ([i-n_in-n_beam]) end if end do n = n + n_rem call particle_set%prt(n+1:n+n_vir)%reset_status (PRT_VIRTUAL) do i = n+1, n+n_vir call particle_set%prt(i)%set_parents & ([(k, k=n-n_rem-n_in+1, n-n_rem)]) end do n = n + n_vir call particle_set%prt(n+1:n+n_out)%reset_status (PRT_OUTGOING) do i = n+1, n+n_out call particle_set%prt(i)%set_parents & ([(k, k=n-n_vir-n_rem-n_in+1, n-n_vir-n_rem)]) end do allocate (flv (particle_set%n_tot)) call flv%init (pdg, model) do k = n_beam+n_in+1, n_beam+n_in+n_rem call flv(k)%tag_radiated () end do do i = 1, particle_set%n_tot call particle_set%prt(i)%set_flavor (flv(i)) end do end subroutine particle_set_init_direct @ %def particle_set_init_direct @ Copy a particle set into a new, extended one. Use the mapping array to determine the new positions of particles. The new set contains [[n_new]] additional entries. Count the new, undefined particles as virtual. - -TODO: implement mapping for the state matrix. <>= procedure :: transfer => particle_set_transfer <>= subroutine particle_set_transfer (pset, source, n_new, map) class(particle_set_t), intent(out) :: pset class(particle_set_t), intent(in) :: source integer, intent(in) :: n_new integer, dimension(:), intent(in) :: map integer :: i call pset%basic_init & (source%n_beam, source%n_in, source%n_vir + n_new, source%n_out) do i = 1, source%n_tot call pset%prt(map(i))%reset_status (source%prt(i)%get_status ()) call pset%prt(map(i))%set_flavor (source%prt(i)%get_flv ()) call pset%prt(map(i))%set_color (source%prt(i)%get_col ()) call pset%prt(map(i))%set_parents (map (source%prt(i)%get_parents ())) call pset%prt(map(i))%set_children (map (source%prt(i)%get_children ())) end do end subroutine particle_set_transfer @ %def particle_set_transfer @ Insert a new particle as an intermediate into a previously empty position. Flavor and status are just set. Color is not set (but see below). The complicated part is reassigning parent-child relations. The inserted particle comes with an array [[child]] of its children which are supposed to be existing particles. We first scan all particles that come before the new insertion. Whenever a particle has children that coincide with the children of the new particle, those child entries are removed. (a) If the new particle has no parent entry yet, those child entries are replaced by the index of the new particle and simultaneously, the particle is registered as a parent of the new particle. (b) If the current particle already has a parent entry, those child entries are removed. When this is done, the new particle is registered as the (only) parent of its children. <>= procedure :: insert => particle_set_insert <>= subroutine particle_set_insert (pset, i, status, flv, child) class(particle_set_t), intent(inout) :: pset integer, intent(in) :: i integer, intent(in) :: status type(flavor_t), intent(in) :: flv integer, dimension(:), intent(in) :: child integer, dimension(:), allocatable :: p_child, parent integer :: j, k, c, n_parent logical :: no_match call pset%prt(i)%reset_status (status) call pset%prt(i)%set_flavor (flv) call pset%prt(i)%set_children (child) n_parent = pset%prt(i)%get_n_parents () do j = 1, i - 1 p_child = pset%prt(j)%get_children () no_match = .true. do k = 1, size (p_child) if (any (p_child(k) == child)) then if (n_parent == 0 .and. no_match) then if (.not. allocated (parent)) then parent = [j] else parent = [parent, j] end if p_child(k) = i else p_child(k) = 0 end if no_match = .false. end if end do if (.not. no_match) then p_child = pack (p_child, p_child /= 0) call pset%prt(j)%set_children (p_child) end if end do if (n_parent == 0) then call pset%prt(i)%set_parents (parent) end if do j = 1, size (child) c = child(j) call pset%prt(c)%set_parents ([i]) end do end subroutine particle_set_insert @ %def particle_set_insert @ This should be done after completing all insertions: recover color assignments for the inserted particles, working backwards from children to parents. A single call to the routine recovers the color and anticolor line indices for a single particle. <>= procedure :: recover_color => particle_set_recover_color <>= subroutine particle_set_recover_color (pset, i) class(particle_set_t), intent(inout) :: pset integer, intent(in) :: i type(color_t) :: col integer, dimension(:), allocatable :: child integer :: j child = pset%prt(i)%get_children () if (size (child) > 0) then col = pset%prt(child(1))%get_col () do j = 2, size (child) col = col .fuse. pset%prt(child(j))%get_col () end do call pset%prt(i)%set_color (col) end if end subroutine particle_set_recover_color @ %def particle_set_recover_color @ \subsection{Extract/modify contents} <>= generic :: get_color => get_color_all generic :: get_color => get_color_indices procedure :: get_color_all => particle_set_get_color_all procedure :: get_color_indices => particle_set_get_color_indices <>= function particle_set_get_color_all (particle_set) result (col) class(particle_set_t), intent(in) :: particle_set type(color_t), dimension(:), allocatable :: col allocate (col (size (particle_set%prt))) col = particle_set%prt%col end function particle_set_get_color_all @ %def particle_set_get_color_all @ <>= function particle_set_get_color_indices (particle_set, indices) result (col) type(color_t), dimension(:), allocatable :: col class(particle_set_t), intent(in) :: particle_set integer, intent(in), dimension(:), allocatable :: indices integer :: i allocate (col (size (indices))) do i = 1, size (indices) col(i) = particle_set%prt(indices(i))%col end do end function particle_set_get_color_indices @ %def particle_set_get_color_indices @ Set a single or all color components. This is a wrapper around the corresponding [[particle_t]] method, with the same options. We assume that the particle array is allocated. <>= generic :: set_color => set_color_single generic :: set_color => set_color_indices generic :: set_color => set_color_all procedure :: set_color_single => particle_set_set_color_single procedure :: set_color_indices => particle_set_set_color_indices procedure :: set_color_all => particle_set_set_color_all <>= subroutine particle_set_set_color_single (particle_set, i, col) class(particle_set_t), intent(inout) :: particle_set integer, intent(in) :: i type(color_t), intent(in) :: col call particle_set%prt(i)%set_color (col) end subroutine particle_set_set_color_single subroutine particle_set_set_color_indices (particle_set, indices, col) class(particle_set_t), intent(inout) :: particle_set integer, dimension(:), intent(in) :: indices type(color_t), dimension(:), intent(in) :: col integer :: i do i = 1, size (indices) call particle_set%prt(indices(i))%set_color (col(i)) end do end subroutine particle_set_set_color_indices subroutine particle_set_set_color_all (particle_set, col) class(particle_set_t), intent(inout) :: particle_set type(color_t), dimension(:), intent(in) :: col call particle_set%prt%set_color (col) end subroutine particle_set_set_color_all @ %def particle_set_set_color @ Assigning particles manually may result in color mismatches. This is checked here for all particles in the set. The color object is compared against the color type that belongs to the flavor object. The return value is an allocatable array which consists of the particles with invalid color assignments. If the array size is zero, all is fine. <>= procedure :: find_prt_invalid_color => particle_set_find_prt_invalid_color <>= subroutine particle_set_find_prt_invalid_color (particle_set, index, prt) class(particle_set_t), intent(in) :: particle_set integer, dimension(:), allocatable, intent(out) :: index type(particle_t), dimension(:), allocatable, intent(out), optional :: prt type(flavor_t) :: flv type(color_t) :: col logical, dimension(:), allocatable :: mask integer :: i, n, n_invalid n = size (particle_set%prt) allocate (mask (n)) do i = 1, n associate (prt => particle_set%prt(i)) flv = prt%get_flv () col = prt%get_col () mask(i) = flv%get_color_type () /= col%get_type () end associate end do index = pack ([(i, i = 1, n)], mask) if (present (prt)) prt = pack (particle_set%prt, mask) end subroutine particle_set_find_prt_invalid_color @ %def particle_set_find_prt_invalid_color @ <>= generic :: get_momenta => get_momenta_all generic :: get_momenta => get_momenta_indices procedure :: get_momenta_all => particle_set_get_momenta_all procedure :: get_momenta_indices => particle_set_get_momenta_indices <>= function particle_set_get_momenta_all (particle_set) result (p) class(particle_set_t), intent(in) :: particle_set type(vector4_t), dimension(:), allocatable :: p allocate (p (size (particle_set%prt))) p = particle_set%prt%p end function particle_set_get_momenta_all @ %def particle_set_get_momenta_all @ <>= function particle_set_get_momenta_indices (particle_set, indices) result (p) type(vector4_t), dimension(:), allocatable :: p class(particle_set_t), intent(in) :: particle_set integer, intent(in), dimension(:), allocatable :: indices integer :: i allocate (p (size (indices))) do i = 1, size (indices) p(i) = particle_set%prt(indices(i))%p end do end function particle_set_get_momenta_indices @ %def particle_set_get_momenta_indices @ Replace a single or all momenta. This is a wrapper around the corresponding [[particle_t]] method, with the same options. We assume that the particle array is allocated. <>= generic :: set_momentum => set_momentum_single generic :: set_momentum => set_momentum_indices generic :: set_momentum => set_momentum_all procedure :: set_momentum_single => particle_set_set_momentum_single procedure :: set_momentum_indices => particle_set_set_momentum_indices procedure :: set_momentum_all => particle_set_set_momentum_all <>= subroutine particle_set_set_momentum_single & (particle_set, i, p, p2, on_shell) class(particle_set_t), intent(inout) :: particle_set integer, intent(in) :: i type(vector4_t), intent(in) :: p real(default), intent(in), optional :: p2 logical, intent(in), optional :: on_shell call particle_set%prt(i)%set_momentum (p, p2, on_shell) end subroutine particle_set_set_momentum_single subroutine particle_set_set_momentum_indices & (particle_set, indices, p, p2, on_shell) class(particle_set_t), intent(inout) :: particle_set integer, dimension(:), intent(in) :: indices type(vector4_t), dimension(:), intent(in) :: p real(default), dimension(:), intent(in), optional :: p2 logical, intent(in), optional :: on_shell integer :: i if (present (p2)) then do i = 1, size (indices) call particle_set%prt(indices(i))%set_momentum (p(i), p2(i), on_shell) end do else do i = 1, size (indices) call particle_set%prt(indices(i))%set_momentum & (p(i), on_shell=on_shell) end do end if end subroutine particle_set_set_momentum_indices subroutine particle_set_set_momentum_all (particle_set, p, p2, on_shell) class(particle_set_t), intent(inout) :: particle_set type(vector4_t), dimension(:), intent(in) :: p real(default), dimension(:), intent(in), optional :: p2 logical, intent(in), optional :: on_shell call particle_set%prt%set_momentum (p, p2, on_shell) end subroutine particle_set_set_momentum_all @ %def particle_set_set_momentum @ Recover a momentum by recombining from children, assuming that this is possible. The reconstructed momentum is not projected on-shell. <>= procedure :: recover_momentum => particle_set_recover_momentum <>= subroutine particle_set_recover_momentum (particle_set, i) class(particle_set_t), intent(inout) :: particle_set integer, intent(in) :: i type(vector4_t), dimension(:), allocatable :: p integer, dimension(:), allocatable :: index index = particle_set%prt(i)%get_children () p = particle_set%get_momenta (index) call particle_set%set_momentum (i, sum (p)) end subroutine particle_set_recover_momentum @ %def particle_set_recover_momentum @ <>= procedure :: replace_incoming_momenta => particle_set_replace_incoming_momenta <>= subroutine particle_set_replace_incoming_momenta (particle_set, p) class(particle_set_t), intent(inout) :: particle_set type(vector4_t), intent(in), dimension(:) :: p integer :: i, j i = 1 do j = 1, particle_set%get_n_tot () if (particle_set%prt(j)%get_status () == PRT_INCOMING) then particle_set%prt(j)%p = p(i) i = i + 1 if (i > particle_set%n_in) exit end if end do end subroutine particle_set_replace_incoming_momenta @ %def particle_set_replace_incoming_momenta @ <>= procedure :: replace_outgoing_momenta => particle_set_replace_outgoing_momenta <>= subroutine particle_set_replace_outgoing_momenta (particle_set, p) class(particle_set_t), intent(inout) :: particle_set type(vector4_t), intent(in), dimension(:) :: p integer :: i, j i = particle_set%n_in + 1 do j = 1, particle_set%n_tot if (particle_set%prt(j)%get_status () == PRT_OUTGOING) then particle_set%prt(j)%p = p(i) i = i + 1 end if end do end subroutine particle_set_replace_outgoing_momenta @ %def particle_set_replace_outgoing_momenta @ <>= procedure :: get_outgoing_momenta => particle_set_get_outgoing_momenta <>= function particle_set_get_outgoing_momenta (particle_set) result (p) class(particle_set_t), intent(in) :: particle_set type(vector4_t), dimension(:), allocatable :: p integer :: i, k allocate (p (count (particle_set%prt%get_status () == PRT_OUTGOING))) k = 0 do i = 1, size (particle_set%prt) if (particle_set%prt(i)%get_status () == PRT_OUTGOING) then k = k + 1 p(k) = particle_set%prt(i)%get_momentum () end if end do end function particle_set_get_outgoing_momenta @ %def particle_set_get_outgoing_momenta @ <>= procedure :: parent_add_child => particle_set_parent_add_child <>= subroutine particle_set_parent_add_child (particle_set, parent, child) class(particle_set_t), intent(inout) :: particle_set integer, intent(in) :: parent, child call particle_set%prt(child)%set_parents ([parent]) call particle_set%prt(parent)%add_child (child) end subroutine particle_set_parent_add_child @ %def particle_set_parent_add_child @ Given the [[particle_set]] before radiation, the new momenta [[p_radiated]], the [[emitter]] and the [[flv_radiated]] as well as the [[model]] and a random number [[r_color]] for chosing a color, we update the [[particle_set]]. <>= procedure :: build_radiation => particle_set_build_radiation <>= subroutine particle_set_build_radiation (particle_set, p_radiated, & emitter, flv_radiated, model, r_color) class(particle_set_t), intent(inout) :: particle_set type(vector4_t), intent(in), dimension(:) :: p_radiated integer, intent(in) :: emitter integer, intent(in), dimension(:) :: flv_radiated class(model_data_t), intent(in), target :: model real(default), intent(in) :: r_color type(particle_set_t) :: new_particle_set type(particle_t) :: new_particle integer :: i integer :: pdg_index_emitter, pdg_index_radiation integer, dimension(:), allocatable :: parents, children type(flavor_t) :: new_flv logical, dimension(:), allocatable :: status_mask integer, dimension(:), allocatable :: & i_in1, i_beam1, i_remnant1, i_virt1, i_out1 integer, dimension(:), allocatable :: & i_in2, i_beam2, i_remnant2, i_virt2, i_out2 integer :: n_in1, n_beam1, n_remnant1, n_virt1, n_out1 integer :: n_in2, n_beam2, n_remnant2, n_virt2, n_out2 integer :: n, n_tot integer :: i_emitter n = particle_set%get_n_tot () allocate (status_mask (n)) do i = 1, n status_mask(i) = particle_set%prt(i)%get_status () == PRT_INCOMING end do n_in1 = count (status_mask) allocate (i_in1 (n_in1)) i_in1 = particle_set%get_indices (status_mask) do i = 1, n status_mask(i) = particle_set%prt(i)%get_status () == PRT_BEAM end do n_beam1 = count (status_mask) allocate (i_beam1 (n_beam1)) i_beam1 = particle_set%get_indices (status_mask) do i = 1, n status_mask(i) = particle_set%prt(i)%get_status () == PRT_BEAM_REMNANT end do n_remnant1 = count (status_mask) allocate (i_remnant1 (n_remnant1)) i_remnant1 = particle_set%get_indices (status_mask) do i = 1, n status_mask(i) = particle_set%prt(i)%get_status () == PRT_VIRTUAL end do n_virt1 = count (status_mask) allocate (i_virt1 (n_virt1)) i_virt1 = particle_set%get_indices (status_mask) do i = 1, n status_mask(i) = particle_set%prt(i)%get_status () == PRT_OUTGOING end do n_out1 = count (status_mask) allocate (i_out1 (n_out1)) i_out1 = particle_set%get_indices (status_mask) n_in2 = n_in1; n_beam2 = n_beam1; n_remnant2 = n_remnant1 n_virt2 = n_virt1 + n_out1 n_out2 = n_out1 + 1 n_tot = n_in2 + n_beam2 + n_remnant2 + n_virt2 + n_out2 allocate (i_in2 (n_in2), i_beam2 (n_beam2), i_remnant2 (n_remnant2)) i_in2 = i_in1; i_beam2 = i_beam1; i_remnant2 = i_remnant1 allocate (i_virt2 (n_virt2)) i_virt2(1 : n_virt1) = i_virt1 i_virt2(n_virt1 + 1 : n_virt2) = i_out1 allocate (i_out2 (n_out2)) i_out2(1 : n_out1) = i_out1(1 : n_out1) + n_out1 i_out2(n_out2) = n_tot new_particle_set%n_beam = n_beam2 new_particle_set%n_in = n_in2 new_particle_set%n_vir = n_virt2 new_particle_set%n_out = n_out2 new_particle_set%n_tot = n_tot new_particle_set%correlated_state = particle_set%correlated_state allocate (new_particle_set%prt (n_tot)) if (size (i_beam1) > 0) new_particle_set%prt(i_beam2) = particle_set%prt(i_beam1) if (size (i_remnant1) > 0) new_particle_set%prt(i_remnant2) = particle_set%prt(i_remnant1) do i = 1, n_virt1 new_particle_set%prt(i_virt2(i)) = particle_set%prt(i_virt1(i)) end do do i = n_virt1 + 1, n_virt2 new_particle_set%prt(i_virt2(i)) = particle_set%prt(i_out1(i - n_virt1)) call new_particle_set%prt(i_virt2(i))%reset_status (PRT_VIRTUAL) end do do i = 1, n_in2 new_particle_set%prt(i_in2(i)) = particle_set%prt(i_in1(i)) new_particle_set%prt(i_in2(i))%p = p_radiated (i) end do do i = 1, n_out2 - 1 new_particle_set%prt(i_out2(i)) = particle_set%prt(i_out1(i)) new_particle_set%prt(i_out2(i))%p = p_radiated(i + n_in2) call new_particle_set%prt(i_out2(i))%reset_status (PRT_OUTGOING) end do call new_particle%reset_status (PRT_OUTGOING) call new_particle%set_momentum (p_radiated (n_in2 + n_out2)) !!! Helicity and polarization handling is missing at this point !!! Also, no helicities or polarizations yet pdg_index_emitter = flv_radiated (emitter) pdg_index_radiation = flv_radiated (n_in2 + n_out2) call new_flv%init (pdg_index_radiation, model) i_emitter = emitter + n_virt2 + n_remnant2 + n_beam2 call reassign_colors (new_particle, new_particle_set%prt(i_emitter), & pdg_index_radiation, pdg_index_emitter, r_color) call new_particle%set_flavor (new_flv) new_particle_set%prt(n_tot) = new_particle allocate (children (n_out2)) children = i_out2 do i = n_in2 + n_beam2 + n_remnant2 + n_virt1 + 1, n_in2 + n_beam2 + n_remnant2 + n_virt2 call new_particle_set%prt(i)%set_children (children) end do !!! Set proper parents for outgoing particles allocate (parents (n_out1)) parents = i_out1 do i = n_in2 + n_beam2 + n_remnant2 + n_virt2 + 1, n_tot call new_particle_set%prt(i)%set_parents (parents) end do call particle_set%init (new_particle_set) contains <> subroutine reassign_colors (prt_radiated, prt_emitter, i_rad, i_em, r_col) type(particle_t), intent(inout) :: prt_radiated, prt_emitter integer, intent(in) :: i_rad, i_em real(default), intent(in) :: r_col type(color_t) :: col_rad, col_em if (is_quark (i_em) .and. is_gluon (i_rad)) then call reassign_colors_qg (prt_emitter, col_rad, col_em) else if (is_gluon (i_em) .and. is_gluon (i_rad)) then call reassign_colors_gg (prt_emitter, r_col, col_rad, col_em) else if (is_gluon (i_em) .and. is_quark (i_rad)) then call reassign_colors_qq (prt_emitter, i_em, col_rad, col_em) else call msg_fatal ("Invalid splitting") end if call prt_emitter%set_color (col_em) call prt_radiated%set_color (col_rad) end subroutine reassign_colors subroutine reassign_colors_qg (prt_emitter, col_rad, col_em) type(particle_t), intent(in) :: prt_emitter type(color_t), intent(out) :: col_rad, col_em integer, dimension(2) :: color_rad, color_em integer :: i1, i2 integer :: new_color_index logical :: is_anti_quark color_em = prt_emitter%get_color () i1 = 1; i2 = 2 is_anti_quark = color_em(2) /= 0 if (is_anti_quark) then i1 = 2; i2 = 1 end if new_color_index = color_em(i1)+1 color_rad(i1) = color_em(i1) color_rad(i2) = new_color_index color_em(i1) = new_color_index call col_em%init_col_acl (color_em(1), color_em(2)) call col_rad%init_col_acl (color_rad(1), color_rad(2)) end subroutine reassign_colors_qg subroutine reassign_colors_gg (prt_emitter, random, col_rad, col_em) !!! NOT TESTED YET type(particle_t), intent(in) :: prt_emitter real(default), intent(in) :: random type(color_t), intent(out) :: col_rad, col_em integer, dimension(2) :: color_rad, color_em integer :: i1, i2 integer :: new_color_index color_em = prt_emitter%get_color () new_color_index = maxval (abs (color_em)) i1 = 1; i2 = 2 if (random < 0.5) then i1 = 2; i2 = 1 end if color_rad(i1) = new_color_index color_rad(i2) = color_em(i2) color_em(i2) = new_color_index call col_em%init_col_acl (color_em(1), color_em(2)) call col_rad%init_col_acl (color_rad(1), color_rad(2)) end subroutine reassign_colors_gg subroutine reassign_colors_qq (prt_emitter, pdg_emitter, col_rad, col_em) !!! NOT TESTED YET type(particle_t), intent(in) :: prt_emitter integer, intent(in) :: pdg_emitter type(color_t), intent(out) :: col_rad, col_em integer, dimension(2) :: color_rad, color_em integer :: i1, i2 logical :: is_anti_quark color_em = prt_emitter%get_color () i1 = 1; i2 = 2 is_anti_quark = pdg_emitter < 0 if (is_anti_quark) then i1 = 2; i1 = 1 end if color_em(i2) = 0 color_rad(i1) = 0 color_rad(i2) = color_em(i1) call col_em%init_col_acl (color_em(1), color_em(2)) call col_rad%init_col_acl (color_rad(1), color_rad(2)) end subroutine reassign_colors_qq end subroutine particle_set_build_radiation @ %def particle_set_build_radiation @ Increments the color indices of all particles by their maximal value to distinguish them from the record-keeping Born particles in the LHE-output if the virtual entries are kept. <>= subroutine set_color_offset (particle_set) type(particle_set_t), intent(inout) :: particle_set integer, dimension(2) :: color integer :: i, i_color_max type(color_t) :: new_color i_color_max = 0 do i = 1, size (particle_set%prt) associate (prt => particle_set%prt(i)) if (prt%get_status () <= PRT_INCOMING) cycle color = prt%get_color () i_color_max = maxval([i_color_max, color(1), color(2)]) end associate end do do i = 1, size (particle_set%prt) associate (prt => particle_set%prt(i)) if (prt%get_status () /= PRT_OUTGOING) cycle color = prt%get_color () where (color /= 0) color = color + i_color_max call new_color%init_col_acl (color(1), color(2)) call prt%set_color (new_color) end associate end do end subroutine set_color_offset @ %def set_color_offset @ Output (default format) <>= procedure :: write => particle_set_write <>= subroutine particle_set_write & (particle_set, unit, testflag, summary, compressed) class(particle_set_t), intent(in) :: particle_set integer, intent(in), optional :: unit logical, intent(in), optional :: testflag, summary, compressed logical :: summ, comp, pol type(vector4_t) :: sum_vec integer :: u, i u = given_output_unit (unit); if (u < 0) return summ = .false.; if (present (summary)) summ = summary comp = .false.; if (present (compressed)) comp = compressed pol = particle_set%factorization_mode /= FM_IGNORE_HELICITY write (u, "(1x,A)") "Particle set:" call write_separator (u) if (comp) then if (pol) then write (u, & "((A4,1X),(A6,1X),(A7,1X),(A3),2(A4,1X),2(A20,1X),5(A12,1X))") & "Nr", "Status", "Flavor", "Hel", "Col", "ACol", & "Parents", "Children", & "P(0)", "P(1)", "P(2)", "P(3)", "P^2" else write (u, & "((A4,1X),(A6,1X),(A7,1X),2(A4,1X),2(A20,1X),5(A12,1X))") & "Nr", "Status", "Flavor", "Col", "ACol", & "Parents", "Children", & "P(0)", "P(1)", "P(2)", "P(3)", "P^2" end if end if if (particle_set%n_tot /= 0) then do i = 1, particle_set%n_tot if (comp) then write (u, "(I4,1X,2X)", advance="no") i else write (u, "(1x,A,1x,I0)", advance="no") "Particle", i end if call particle_set%prt(i)%write (u, testflag = testflag, & compressed = comp, polarization = pol) end do if (particle_set%correlated_state%is_defined ()) then call write_separator (u) write (u, *) "Correlated state density matrix:" call particle_set%correlated_state%write (u) end if if (summ) then call write_separator (u) write (u, "(A)", advance="no") & "Sum of incoming momenta: p(0:3) = " sum_vec = sum (particle_set%prt%p, & mask=particle_set%prt%get_status () == PRT_INCOMING) call pacify (sum_vec, tolerance = 1E-3_default) call sum_vec%write (u, compressed=.true.) write (u, *) write (u, "(A)", advance="no") & "Sum of beam remnant momenta: p(0:3) = " sum_vec = sum (particle_set%prt%p, & mask=particle_set%prt%get_status () == PRT_BEAM_REMNANT) call pacify (sum_vec, tolerance = 1E-3_default) call sum_vec%write (u, compressed=.true.) write (u, *) write (u, "(A)", advance="no") & "Sum of outgoing momenta: p(0:3) = " sum_vec = sum (particle_set%prt%p, & mask=particle_set%prt%get_status () == PRT_OUTGOING) call pacify (sum_vec, tolerance = 1E-3_default) call sum_vec%write (u, compressed=.true.) write (u, "(A)") "" end if else write (u, "(3x,A)") "[empty]" end if end subroutine particle_set_write @ %def particle_set_write @ \subsection{I/O formats} Here, we define input/output of particle sets in various formats. This is the right place since particle sets contain most of the event information. All write/read routines take as first argument the object, as second argument the I/O unit which in this case is a mandatory argument. Then follow further event data. \subsubsection{Internal binary format} This format is supposed to contain the complete information, so the particle data set can be fully reconstructed. The exception is the model part of the particle flavors; this is unassigned for the flavor values read from file. <>= procedure :: write_raw => particle_set_write_raw procedure :: read_raw => particle_set_read_raw <>= subroutine particle_set_write_raw (particle_set, u) class(particle_set_t), intent(in) :: particle_set integer, intent(in) :: u integer :: i write (u) & particle_set%n_beam, particle_set%n_in, & particle_set%n_vir, particle_set%n_out write (u) particle_set%factorization_mode write (u) particle_set%n_tot do i = 1, particle_set%n_tot call particle_set%prt(i)%write_raw (u) end do call particle_set%correlated_state%write_raw (u) end subroutine particle_set_write_raw subroutine particle_set_read_raw (particle_set, u, iostat) class(particle_set_t), intent(out) :: particle_set integer, intent(in) :: u integer, intent(out) :: iostat integer :: i read (u, iostat=iostat) & particle_set%n_beam, particle_set%n_in, & particle_set%n_vir, particle_set%n_out read (u, iostat=iostat) particle_set%factorization_mode read (u, iostat=iostat) particle_set%n_tot allocate (particle_set%prt (particle_set%n_tot)) do i = 1, size (particle_set%prt) call particle_set%prt(i)%read_raw (u, iostat=iostat) end do call particle_set%correlated_state%read_raw (u, iostat=iostat) end subroutine particle_set_read_raw @ %def particle_set_write_raw particle_set_read_raw @ \subsubsection{Get contents} Find parents/children of a particular particle recursively; the search terminates if a parent/child has status [[BEAM]], [[INCOMING]], [[OUTGOING]] or [[RESONANT]]. <>= procedure :: get_real_parents => particle_set_get_real_parents procedure :: get_real_children => particle_set_get_real_children <>= function particle_set_get_real_parents (pset, i, keep_beams) result (parent) integer, dimension(:), allocatable :: parent class(particle_set_t), intent(in) :: pset integer, intent(in) :: i logical, intent(in), optional :: keep_beams logical, dimension(:), allocatable :: is_real logical, dimension(:), allocatable :: is_parent, is_real_parent logical :: kb integer :: j, k kb = .false. if (present (keep_beams)) kb = keep_beams allocate (is_real (pset%n_tot)) is_real = pset%prt%is_real (kb) allocate (is_parent (pset%n_tot), is_real_parent (pset%n_tot)) is_real_parent = .false. is_parent = .false. is_parent(pset%prt(i)%get_parents()) = .true. do while (any (is_parent)) where (is_real .and. is_parent) is_real_parent = .true. is_parent = .false. end where mark_next_parent: do j = size (is_parent), 1, -1 if (is_parent(j)) then is_parent(pset%prt(j)%get_parents()) = .true. is_parent(j) = .false. exit mark_next_parent end if end do mark_next_parent end do allocate (parent (count (is_real_parent))) j = 0 do k = 1, size (is_parent) if (is_real_parent(k)) then j = j + 1 parent(j) = k end if end do end function particle_set_get_real_parents function particle_set_get_real_children (pset, i, keep_beams) result (child) integer, dimension(:), allocatable :: child class(particle_set_t), intent(in) :: pset integer, intent(in) :: i logical, dimension(:), allocatable :: is_real logical, dimension(:), allocatable :: is_child, is_real_child logical, intent(in), optional :: keep_beams integer :: j, k logical :: kb kb = .false. if (present (keep_beams)) kb = keep_beams allocate (is_real (pset%n_tot)) is_real = pset%prt%is_real (kb) is_real = pset%prt%is_real (kb) allocate (is_child (pset%n_tot), is_real_child (pset%n_tot)) is_real_child = .false. is_child = .false. is_child(pset%prt(i)%get_children()) = .true. do while (any (is_child)) where (is_real .and. is_child) is_real_child = .true. is_child = .false. end where mark_next_child: do j = 1, size (is_child) if (is_child(j)) then is_child(pset%prt(j)%get_children()) = .true. is_child(j) = .false. exit mark_next_child end if end do mark_next_child end do allocate (child (count (is_real_child))) j = 0 do k = 1, size (is_child) if (is_real_child(k)) then j = j + 1 child(j) = k end if end do end function particle_set_get_real_children @ %def particle_set_get_real_parents @ %def particle_set_get_real_children @ Get the [[n_tot]], [[n_in]], and [[n_out]] values out of the particle set. <>= procedure :: get_n_beam => particle_set_get_n_beam procedure :: get_n_in => particle_set_get_n_in procedure :: get_n_vir => particle_set_get_n_vir procedure :: get_n_out => particle_set_get_n_out procedure :: get_n_tot => particle_set_get_n_tot procedure :: get_n_remnants => particle_set_get_n_remnants <>= function particle_set_get_n_beam (pset) result (n_beam) class(particle_set_t), intent(in) :: pset integer :: n_beam n_beam = pset%n_beam end function particle_set_get_n_beam function particle_set_get_n_in (pset) result (n_in) class(particle_set_t), intent(in) :: pset integer :: n_in n_in = pset%n_in end function particle_set_get_n_in function particle_set_get_n_vir (pset) result (n_vir) class(particle_set_t), intent(in) :: pset integer :: n_vir n_vir = pset%n_vir end function particle_set_get_n_vir function particle_set_get_n_out (pset) result (n_out) class(particle_set_t), intent(in) :: pset integer :: n_out n_out = pset%n_out end function particle_set_get_n_out function particle_set_get_n_tot (pset) result (n_tot) class(particle_set_t), intent(in) :: pset integer :: n_tot n_tot = pset%n_tot end function particle_set_get_n_tot function particle_set_get_n_remnants (pset) result (n_remn) class(particle_set_t), intent(in) :: pset integer :: n_remn if (allocated (pset%prt)) then n_remn = count (pset%prt%get_status () == PRT_BEAM_REMNANT) else n_remn = 0 end if end function particle_set_get_n_remnants @ %def particle_set_get_n_beam @ %def particle_set_get_n_in @ %def particle_set_get_n_vir @ %def particle_set_get_n_out @ %def particle_set_get_n_tot @ %def particle_set_get_n_remnants @ Return a pointer to the particle corresponding to the number <>= procedure :: get_particle => particle_set_get_particle <>= function particle_set_get_particle (pset, index) result (particle) class(particle_set_t), intent(in) :: pset integer, intent(in) :: index type(particle_t) :: particle particle = pset%prt(index) end function particle_set_get_particle @ %def particle_set_get_particle @ <>= procedure :: get_indices => particle_set_get_indices <>= pure function particle_set_get_indices (pset, mask) result (finals) integer, dimension(:), allocatable :: finals class(particle_set_t), intent(in) :: pset logical, dimension(:), intent(in) :: mask integer, dimension(size(mask)) :: indices integer :: i allocate (finals (count (mask))) indices = [(i, i=1, pset%n_tot)] finals = pack (indices, mask) end function particle_set_get_indices @ %def particle_set_get_indices @ <>= procedure :: get_in_and_out_momenta => particle_set_get_in_and_out_momenta <>= function particle_set_get_in_and_out_momenta (pset) result (phs_point) type(phs_point_t) :: phs_point class(particle_set_t), intent(in) :: pset logical, dimension(:), allocatable :: mask integer, dimension(:), allocatable :: indices type(vector4_t), dimension(:), allocatable :: p allocate (mask (pset%get_n_tot ())) allocate (p (size (pset%prt))) mask = pset%prt%status == PRT_INCOMING .or. & pset%prt%status == PRT_OUTGOING allocate (indices (count (mask))) indices = pset%get_indices (mask) phs_point = pset%get_momenta (indices) end function particle_set_get_in_and_out_momenta @ %def particle_set_get_in_and_out_momenta @ \subsubsection{Tools} Build a new particles array without hadronic remnants but with [[n_extra]] additional spots. We also update the mother-daughter relations assuming the ordering [[b]], [[i]], [[r]], [[x]], [[o]]. <>= procedure :: without_hadronic_remnants => & particle_set_without_hadronic_remnants <>= subroutine particle_set_without_hadronic_remnants & (particle_set, particles, n_particles, n_extra) class(particle_set_t), intent(inout) :: particle_set type(particle_t), dimension(:), allocatable, intent(out) :: particles integer, intent(out) :: n_particles integer, intent(in) :: n_extra logical, dimension(:), allocatable :: no_hadronic_remnants, & no_hadronic_children integer, dimension(:), allocatable :: children, new_children integer :: i, j, k, first_remnant first_remnant = particle_set%n_tot do i = 1, particle_set%n_tot if (particle_set%prt(i)%is_hadronic_beam_remnant ()) then first_remnant = i exit end if end do n_particles = count (.not. particle_set%prt%is_hadronic_beam_remnant ()) allocate (no_hadronic_remnants (particle_set%n_tot)) no_hadronic_remnants = .not. particle_set%prt%is_hadronic_beam_remnant () allocate (particles (n_particles + n_extra)) k = 1 do i = 1, particle_set%n_tot if (no_hadronic_remnants(i)) then particles(k) = particle_set%prt(i) k = k + 1 end if end do if (n_particles /= particle_set%n_tot) then do i = 1, n_particles select case (particles(i)%get_status ()) case (PRT_BEAM) if (allocated (children)) deallocate (children) allocate (children (particles(i)%get_n_children ())) children = particles(i)%get_children () if (allocated (no_hadronic_children)) & deallocate (no_hadronic_children) allocate (no_hadronic_children (particles(i)%get_n_children ())) no_hadronic_children = .not. & particle_set%prt(children)%is_hadronic_beam_remnant () if (allocated (new_children)) deallocate (new_children) allocate (new_children (count (no_hadronic_children))) new_children = pack (children, no_hadronic_children) call particles(i)%set_children (new_children) case (PRT_INCOMING, PRT_RESONANT) <> case (PRT_OUTGOING, PRT_BEAM_REMNANT) case default end select end do end if end subroutine particle_set_without_hadronic_remnants @ %def particle_set_without_hadronic_remnants <>= if (allocated (children)) deallocate (children) allocate (children (particles(i)%get_n_children ())) children = particles(i)%get_children () do j = 1, size (children) if (children(j) > first_remnant) then children(j) = children (j) - & (particle_set%n_tot - n_particles) end if end do call particles(i)%set_children (children) @ Build a new particles array without remnants but with [[n_extra]] additional spots. We also update the mother-daughter relations assuming the ordering [[b]], [[i]], [[r]], [[x]], [[o]]. <>= procedure :: without_remnants => particle_set_without_remnants <>= subroutine particle_set_without_remnants & (particle_set, particles, n_particles, n_extra) class(particle_set_t), intent(inout) :: particle_set type(particle_t), dimension(:), allocatable, intent(out) :: particles integer, intent(in) :: n_extra integer, intent(out) :: n_particles logical, dimension(:), allocatable :: no_remnants, no_children integer, dimension(:), allocatable :: children, new_children integer :: i,j, k, first_remnant first_remnant = particle_set%n_tot do i = 1, particle_set%n_tot if (particle_set%prt(i)%is_beam_remnant ()) then first_remnant = i exit end if end do allocate (no_remnants (particle_set%n_tot)) no_remnants = .not. (particle_set%prt%is_beam_remnant ()) n_particles = count (no_remnants) allocate (particles (n_particles + n_extra)) k = 1 do i = 1, particle_set%n_tot if (no_remnants(i)) then particles(k) = particle_set%prt(i) k = k + 1 end if end do if (n_particles /= particle_set%n_tot) then do i = 1, n_particles select case (particles(i)%get_status ()) case (PRT_BEAM) if (allocated (children)) deallocate (children) allocate (children (particles(i)%get_n_children ())) children = particles(i)%get_children () if (allocated (no_children)) deallocate (no_children) allocate (no_children (particles(i)%get_n_children ())) no_children = .not. (particle_set%prt(children)%is_beam_remnant ()) if (allocated (new_children)) deallocate (new_children) allocate (new_children (count (no_children))) new_children = pack (children, no_children) call particles(i)%set_children (new_children) case (PRT_INCOMING, PRT_RESONANT) <> case (PRT_OUTGOING, PRT_BEAM_REMNANT) case default end select end do end if end subroutine particle_set_without_remnants @ %def particle_set_without_remnants @ <>= procedure :: find_particle => particle_set_find_particle <>= pure function particle_set_find_particle & (particle_set, pdg, momentum, abs_smallness, rel_smallness) result (idx) integer :: idx class(particle_set_t), intent(in) :: particle_set integer, intent(in) :: pdg type(vector4_t), intent(in) :: momentum real(default), intent(in), optional :: abs_smallness, rel_smallness integer :: i, j logical, dimension(0:3) :: equals idx = 0 do i = 1, size (particle_set%prt) if (particle_set%prt(i)%flv%get_pdg () == pdg) then !!! Workaround for gfortran 4.8.3 with overloaded elemental function do j = 0, 3 equals(j) = nearly_equal (particle_set%prt(i)%p%p(j), momentum%p(j), & abs_smallness, rel_smallness) end do if (all (equals)) then idx = i return end if end if end do end function particle_set_find_particle @ %def particle_set_find_particle <>= procedure :: reverse_find_particle => particle_set_reverse_find_particle <>= pure function particle_set_reverse_find_particle & (particle_set, pdg, momentum, abs_smallness, rel_smallness) result (idx) integer :: idx class(particle_set_t), intent(in) :: particle_set integer, intent(in) :: pdg type(vector4_t), intent(in) :: momentum real(default), intent(in), optional :: abs_smallness, rel_smallness integer :: i idx = 0 do i = size (particle_set%prt), 1, -1 if (particle_set%prt(i)%flv%get_pdg () == pdg) then if (all (nearly_equal (particle_set%prt(i)%p%p, momentum%p, & abs_smallness, rel_smallness))) then idx = i return end if end if end do end function particle_set_reverse_find_particle @ %def particle_set_reverse_find_particle @ This connects broken links of the form $\text{something} \to i \to \text{none or} j$ and $\text{none} \to j \to \text{something or none}$ where the particles $i$ and $j$ are \emph{identical}. It also works if $i \to j$, directly, and thus removes duplicates. We are removing $j$ and connect the possible daughters to $i$. <>= procedure :: remove_duplicates => particle_set_remove_duplicates <>= subroutine particle_set_remove_duplicates (particle_set, smallness) class(particle_set_t), intent(inout) :: particle_set real(default), intent(in) :: smallness integer :: n_removals integer, dimension(particle_set%n_tot) :: to_remove type(particle_t), dimension(:), allocatable :: particles type(vector4_t) :: p_i integer, dimension(:), allocatable :: map to_remove = 0 call find_duplicates () n_removals = count (to_remove > 0) if (n_removals > 0) then call strip_duplicates (particles) call particle_set%replace (particles) end if contains <> end subroutine particle_set_remove_duplicates @ %def particle_set_remove_duplicates @ This doesn't catch all cases. Missing are splittings of the type $i \to \text{something and} j$. <>= subroutine find_duplicates () integer :: pdg_i, child_i, i, j OUTER: do i = 1, particle_set%n_tot if (particle_set%prt(i)%status == PRT_OUTGOING .or. & particle_set%prt(i)%status == PRT_VIRTUAL .or. & particle_set%prt(i)%status == PRT_RESONANT) then if (allocated (particle_set%prt(i)%child)) then if (size (particle_set%prt(i)%child) > 1) cycle OUTER if (size (particle_set%prt(i)%child) == 1) then child_i = particle_set%prt(i)%child(1) else child_i = 0 end if else child_i = 0 end if pdg_i = particle_set%prt(i)%flv%get_pdg () p_i = particle_set%prt(i)%p do j = i + 1, particle_set%n_tot if (pdg_i == particle_set%prt(j)%flv%get_pdg ()) then if (all (nearly_equal (particle_set%prt(j)%p%p, p_i%p, & abs_smallness = smallness, & rel_smallness = 1E4_default * smallness))) then if (child_i == 0 .or. j == child_i) then to_remove(j) = i call msg_debug2 (D_PARTICLES, & "Particles: Will remove duplicate of i", i) call msg_debug2 (D_PARTICLES, & "Particles: j", j) end if cycle OUTER end if end if end do end if end do OUTER end subroutine find_duplicates @ <>= recursive function get_alive_index (try) result (alive) integer :: alive integer :: try if (map(try) > 0) then alive = map(try) else alive = get_alive_index (to_remove(try)) end if end function get_alive_index @ <>= subroutine strip_duplicates (particles) type(particle_t), dimension(:), allocatable, intent(out) :: particles integer :: kept, removed, i, j integer, dimension(:), allocatable :: old_children logical, dimension(:), allocatable :: parent_set call msg_debug (D_PARTICLES, "Particles: Removing duplicates") call msg_debug (D_PARTICLES, "Particles: n_removals", n_removals) if (debug2_active (D_PARTICLES)) then call msg_debug2 (D_PARTICLES, "Particles: Given set before removing:") call particle_set%write (summary=.true., compressed=.true.) end if allocate (particles (particle_set%n_tot - n_removals)) allocate (map (particle_set%n_tot)) allocate (parent_set (particle_set%n_tot)) parent_set = .false. map = 0 j = 0 do i = 1, particle_set%n_tot if (to_remove(i) == 0) then j = j + 1 map(i) = j call particles(j)%init (particle_set%prt(i)) end if end do do i = 1, particle_set%n_tot if (map(i) /= 0) then if (.not. parent_set(map(i))) then call particles(map(i))%set_parents & (map (particle_set%prt(i)%get_parents ())) end if call particles(map(i))%set_children & (map (particle_set%prt(i)%get_children ())) else removed = i kept = to_remove(i) if (particle_set%prt(removed)%has_children ()) then old_children = particle_set%prt(removed)%get_children () do j = 1, size (old_children) if (map(old_children(j)) > 0) then call particles(map(old_children(j)))%set_parents & ([get_alive_index (kept)]) parent_set(map(old_children(j))) = .true. call particles(get_alive_index (kept))%add_child & (map(old_children(j))) end if end do particles(get_alive_index (kept))%status = PRT_RESONANT else particles(get_alive_index (kept))%status = PRT_OUTGOING end if end if end do end subroutine strip_duplicates @ Given a subevent, reset status codes. If the new status is beam, incoming, or outgoing, we also make sure that the stored $p^2$ value is equal to the on-shell mass squared. <>= procedure :: reset_status => particle_set_reset_status <>= subroutine particle_set_reset_status (particle_set, index, status) class(particle_set_t), intent(inout) :: particle_set integer, dimension(:), intent(in) :: index integer, intent(in) :: status integer :: i if (allocated (particle_set%prt)) then do i = 1, size (index) call particle_set%prt(index(i))%reset_status (status) end do end if particle_set%n_beam = & count (particle_set%prt%get_status () == PRT_BEAM) particle_set%n_in = & count (particle_set%prt%get_status () == PRT_INCOMING) particle_set%n_out = & count (particle_set%prt%get_status () == PRT_OUTGOING) particle_set%n_vir = particle_set%n_tot & - particle_set%n_beam - particle_set%n_in - particle_set%n_out end subroutine particle_set_reset_status @ %def particle_set_reset_status @ Reduce a particle set to the essential entries. The entries kept are those with status [[INCOMING]], [[OUTGOING]] or [[RESONANT]]. [[BEAM]] is kept if [[keep_beams]] is true. Other entries are skipped. The correlated state matrix, if any, is also ignored. <>= procedure :: reduce => particle_set_reduce <>= subroutine particle_set_reduce (pset_in, pset_out, keep_beams) class(particle_set_t), intent(in) :: pset_in type(particle_set_t), intent(out) :: pset_out logical, intent(in), optional :: keep_beams integer, dimension(:), allocatable :: status, map integer :: i, j logical :: kb kb = .false.; if (present (keep_beams)) kb = keep_beams allocate (status (pset_in%n_tot)) pset_out%factorization_mode = pset_in%factorization_mode status = pset_in%prt%get_status () if (kb) pset_out%n_beam = count (status == PRT_BEAM) pset_out%n_in = count (status == PRT_INCOMING) pset_out%n_vir = count (status == PRT_RESONANT) pset_out%n_out = count (status == PRT_OUTGOING) pset_out%n_tot = & pset_out%n_beam + pset_out%n_in + pset_out%n_vir + pset_out%n_out allocate (pset_out%prt (pset_out%n_tot)) allocate (map (pset_in%n_tot)) map = 0 j = 0 if (kb) call copy_particles (PRT_BEAM) call copy_particles (PRT_INCOMING) call copy_particles (PRT_RESONANT) call copy_particles (PRT_OUTGOING) do i = 1, pset_in%n_tot if (map(i) == 0) cycle !!! !!! triggers nagfor bug! !!! call particle_set_parents (pset_out%prt(map(i)), & !!! map (particle_set_get_real_parents (pset_in, i))) !!! call particle_set_children (pset_out%prt(map(i)), & !!! map (particle_set_get_real_children (pset_in, i))) !!! !!! workaround: call pset_out%prt(map(i))%set_parents & (pset_in%get_real_parents (i, kb)) call pset_out%prt(map(i))%set_parents & (map (pset_out%prt(map(i))%parent)) call pset_out%prt(map(i))%set_children & (pset_in%get_real_children (i, kb)) call pset_out%prt(map(i))%set_children & (map (pset_out%prt(map(i))%child)) end do contains subroutine copy_particles (stat) integer, intent(in) :: stat integer :: i do i = 1, pset_in%n_tot if (status(i) == stat) then j = j + 1 map(i) = j call particle_init_particle (pset_out%prt(j), pset_in%prt(i)) end if end do end subroutine copy_particles end subroutine particle_set_reduce @ %def particles_set_reduce @ Remove the beam particles and beam remnants from the particle set if the keep beams flag is false. If keep beams is not given, the beam particles and the beam remnants are removed. The correlated state matrix, if any, is also ignored. <>= procedure :: filter_particles => particle_set_filter_particles <>= subroutine particle_set_filter_particles & (pset_in, pset_out, keep_beams, real_parents, keep_virtuals) class(particle_set_t), intent(in) :: pset_in type(particle_set_t), intent(out) :: pset_out logical, intent(in), optional :: keep_beams, real_parents, keep_virtuals integer, dimension(:), allocatable :: status, map logical, dimension(:), allocatable :: filter integer :: i, j logical :: kb, rp, kv kb = .false.; if (present (keep_beams)) kb = keep_beams rp = .false.; if (present (real_parents)) rp = real_parents kv = .true.; if (present (keep_virtuals)) kv = keep_virtuals call msg_debug (D_PARTICLES, "filter_particles") if (debug2_active (D_PARTICLES)) then print *, 'keep_beams = ', kb print *, 'real_parents = ', rp print *, 'keep_virtuals = ', kv print *, '>>> pset_in : ' call pset_in%write(compressed=.true.) end if call count_and_allocate() map = 0 j = 0 filter = .false. if (.not. kb) filter = status == PRT_BEAM .or. status == PRT_BEAM_REMNANT if (.not. kv) filter = filter .or. status == PRT_VIRTUAL call copy_particles () do i = 1, pset_in%n_tot if (map(i) == 0) cycle if (rp) then call pset_out%prt(map(i))%set_parents & (map (pset_in%get_real_parents (i, kb))) call pset_out%prt(map(i))%set_children & (map (pset_in%get_real_children (i, kb))) else call pset_out%prt(map(i))%set_parents & (map (pset_in%prt(i)%get_parents ())) call pset_out%prt(map(i))%set_children & (map (pset_in%prt(i)%get_children ())) end if end do if (debug2_active (D_PARTICLES)) then print *, '>>> pset_out : ' call pset_out%write(compressed=.true.) end if contains <> end subroutine particle_set_filter_particles @ %def particles_set_filter_particles <>= subroutine copy_particles () integer :: i do i = 1, pset_in%n_tot if (.not. filter(i)) then j = j + 1 map(i) = j call particle_init_particle (pset_out%prt(j), pset_in%prt(i)) end if end do end subroutine copy_particles <>= subroutine count_and_allocate allocate (status (pset_in%n_tot)) status = particle_get_status (pset_in%prt) if (kb) pset_out%n_beam = count (status == PRT_BEAM) pset_out%n_in = count (status == PRT_INCOMING) if (kb .and. kv) then pset_out%n_vir = count (status == PRT_VIRTUAL) + & count (status == PRT_RESONANT) + & count (status == PRT_BEAM_REMNANT) else if (kb .and. .not. kv) then pset_out%n_vir = count (status == PRT_RESONANT) + & count (status == PRT_BEAM_REMNANT) else if (.not. kb .and. kv) then pset_out%n_vir = count (status == PRT_VIRTUAL) + & count (status == PRT_RESONANT) else pset_out%n_vir = count (status == PRT_RESONANT) end if pset_out%n_out = count (status == PRT_OUTGOING) pset_out%n_tot = & pset_out%n_beam + pset_out%n_in + pset_out%n_vir + pset_out%n_out allocate (pset_out%prt (pset_out%n_tot)) allocate (map (pset_in%n_tot)) allocate (filter (pset_in%n_tot)) end subroutine count_and_allocate @ Transform a particle set into HEPEVT-compatible form. In this form, for each particle, the parents and the children are contiguous in the particle array. Usually, this requires to clone some particles. We do not know in advance how many particles the canonical form will have. To be on the safe side, allocate four times the original size. <>= procedure :: to_hepevt_form => particle_set_to_hepevt_form <>= subroutine particle_set_to_hepevt_form (pset_in, pset_out) class(particle_set_t), intent(in) :: pset_in type(particle_set_t), intent(out) :: pset_out type :: particle_entry_t integer :: src = 0 integer :: status = 0 integer :: orig = 0 integer :: copy = 0 end type particle_entry_t type(particle_entry_t), dimension(:), allocatable :: prt integer, dimension(:), allocatable :: map1, map2 integer, dimension(:), allocatable :: parent, child integer :: n_tot, n_parents, n_children, i, j, c, n n_tot = pset_in%n_tot allocate (prt (4 * n_tot)) allocate (map1(4 * n_tot)) allocate (map2(4 * n_tot)) map1 = 0 map2 = 0 allocate (child (n_tot)) allocate (parent (n_tot)) n = 0 do i = 1, n_tot if (pset_in%prt(i)%get_n_parents () == 0) then call append (i) end if end do do i = 1, n_tot n_children = pset_in%prt(i)%get_n_children () if (n_children > 0) then child(1:n_children) = pset_in%prt(i)%get_children () c = child(1) if (map1(c) == 0) then n_parents = pset_in%prt(c)%get_n_parents () if (n_parents > 1) then parent(1:n_parents) = pset_in%prt(c)%get_parents () if (i == parent(1) .and. & any( [(map1(i)+j-1, j=1,n_parents)] /= & map1(parent(1:n_parents)))) then do j = 1, n_parents call append (parent(j)) end do end if else if (map1(i) == 0) then call append (i) end if do j = 1, n_children call append (child(j)) end do end if else if (map1(i) == 0) then call append (i) end if end do do i = n, 1, -1 if (prt(i)%status /= PRT_OUTGOING) then do j = 1, i-1 if (prt(j)%status == PRT_OUTGOING) then call append(prt(j)%src) end if end do exit end if end do pset_out%n_beam = count (prt(1:n)%status == PRT_BEAM) pset_out%n_in = count (prt(1:n)%status == PRT_INCOMING) pset_out%n_vir = count (prt(1:n)%status == PRT_RESONANT) pset_out%n_out = count (prt(1:n)%status == PRT_OUTGOING) pset_out%n_tot = n allocate (pset_out%prt (n)) do i = 1, n call particle_init_particle (pset_out%prt(i), pset_in%prt(prt(i)%src)) call pset_out%prt(i)%reset_status (prt(i)%status) if (prt(i)%orig == 0) then call pset_out%prt(i)%set_parents & (map2 (pset_in%prt(prt(i)%src)%get_parents ())) else call pset_out%prt(i)%set_parents ([ prt(i)%orig ]) end if if (prt(i)%copy == 0) then call pset_out%prt(i)%set_children & (map1 (pset_in%prt(prt(i)%src)%get_children ())) else call pset_out%prt(i)%set_children ([ prt(i)%copy ]) end if end do contains subroutine append (i) integer, intent(in) :: i n = n + 1 if (n > size (prt)) & call msg_bug ("Particle set transform to HEPEVT: insufficient space") prt(n)%src = i prt(n)%status = pset_in%prt(i)%get_status () if (map1(i) == 0) then map1(i) = n else prt(map2(i))%status = PRT_VIRTUAL prt(map2(i))%copy = n prt(n)%orig = map2(i) end if map2(i) = n end subroutine append end subroutine particle_set_to_hepevt_form @ %def particle_set_to_hepevt_form @ This procedure aims at reconstructing the momenta of an interaction, given a particle set. Since the particle orderings <>= procedure :: fill_interaction => particle_set_fill_interaction <>= subroutine particle_set_fill_interaction & (pset, int, n_in, recover_beams, check_match, state_flv) class(particle_set_t), intent(in) :: pset type(interaction_t), intent(inout) :: int integer, intent(in) :: n_in logical, intent(in), optional :: recover_beams, check_match type(state_flv_content_t), intent(in), optional :: state_flv integer, dimension(:), allocatable :: map, pdg integer, dimension(:), allocatable :: i_in, i_out, p_in, p_out logical, dimension(:), allocatable :: i_set integer :: n_out, i, p logical :: r_beams, check r_beams = .false.; if (present (recover_beams)) r_beams = recover_beams check = .true.; if (present (check_match)) check = check_match if (check) then call find_hard_process_in_int (i_in, i_out) call find_hard_process_in_pset (p_in, p_out) n_out = size (i_out) if (size (i_in) /= n_in) call err_int_n_in if (size (p_in) /= n_in) call err_pset_n_in if (size (p_out) /= n_out) call err_pset_n_out call extract_hard_process_from_pset (pdg) call determine_map_for_hard_process (map, state_flv) if (.not. r_beams) then select case (n_in) case (1) call recover_parents (p_in(1), map) case (2) do i = 1, 2 call recover_parents (p_in(i), map) end do do p = 1, 2 call recover_radiation (p, map) end do end select end if else allocate (map (int%get_n_tot ())) map = [(i, i = 1, size (map))] r_beams = .false. end if allocate (i_set (int%get_n_tot ()), source = .false.) do p = 1, size (map) if (map(p) /= 0) then i_set(map(p)) = .true. call int%set_momentum & (pset%prt(p)%get_momentum (), map(p)) end if end do if (r_beams) then do i = 1, n_in call reconstruct_beam_and_radiation (i, i_set) end do end if if (any (.not. i_set)) call err_map contains subroutine find_hard_process_in_pset (p_in, p_out) integer, dimension(:), allocatable, intent(out) :: p_in, p_out integer, dimension(:), allocatable :: p_status, p_idx integer :: n_out_p integer :: i allocate (p_status (pset%n_tot), p_idx (pset%n_tot)) p_status = pset%prt%get_status () p_idx = [(i, i = 1, pset%n_tot)] allocate (p_in (n_in)) p_in = pack (p_idx, p_status == PRT_INCOMING) if (size (p_in) == 0) call err_pset_hard i = p_in(1) n_out_p = particle_get_n_children (pset%prt(i)) allocate (p_out (n_out_p)) p_out = particle_get_children (pset%prt(i)) end subroutine find_hard_process_in_pset subroutine find_hard_process_in_int (i_in, i_out) integer, dimension(:), allocatable, intent(out) :: i_in, i_out integer :: n_in_i integer :: i i = int%get_n_tot () n_in_i = interaction_get_n_parents (int, i) if (n_in_i /= n_in) call err_int_n_in allocate (i_in (n_in)) i_in = interaction_get_parents (int, i) i = i_in(1) n_out = interaction_get_n_children (int, i) allocate (i_out (n_out)) i_out = interaction_get_children (int, i) end subroutine find_hard_process_in_int subroutine extract_hard_process_from_pset (pdg) integer, dimension(:), allocatable, intent(out) :: pdg integer, dimension(:), allocatable :: pdg_p logical, dimension(:), allocatable :: mask_p integer :: i allocate (pdg_p (pset%n_tot)) pdg_p = pset%prt%get_pdg () allocate (mask_p (pset%n_tot), source = .false.) mask_p (p_in) = .true. mask_p (p_out) = .true. allocate (pdg (n_in + n_out)) pdg = pack (pdg_p, mask_p) end subroutine extract_hard_process_from_pset subroutine determine_map_for_hard_process (map, state_flv) integer, dimension(:), allocatable, intent(out) :: map type(state_flv_content_t), intent(in), optional :: state_flv integer, dimension(:), allocatable :: pdg_i, map_i integer :: n_tot logical, dimension(:), allocatable :: mask_i, mask_p logical :: success n_tot = int%get_n_tot () if (present (state_flv)) then allocate (mask_i (n_tot), source = .false.) mask_i (i_in) = .true. mask_i (i_out) = .true. allocate (pdg_i (n_tot), map_i (n_tot)) pdg_i = unpack (pdg, mask_i, 0) call state_flv%match (pdg_i, success, map_i) allocate (mask_p (pset%n_tot), source = .false.) mask_p (p_in) = .true. mask_p (p_out) = .true. allocate (map (size (mask_p)), & source = unpack (pack (map_i, mask_i), mask_p, 0)) if (.not. success) call err_mismatch else allocate (map (n_tot), source = 0) map(p_in) = i_in map(p_out) = i_out end if end subroutine determine_map_for_hard_process recursive subroutine recover_parents (p, map) integer, intent(in) :: p integer, dimension(:), intent(inout) :: map integer :: i, n, n_p, q, k integer, dimension(:), allocatable :: i_parents, p_parents integer, dimension(1) :: pp i = map(p) n = interaction_get_n_parents (int, i) q = p n_p = particle_get_n_parents (pset%prt(q)) do while (n_p == 1) pp = particle_get_parents (pset%prt(q)) if (pset%prt(pp(1))%get_n_children () > 1) exit q = pp(1) n_p = pset%prt(q)%get_n_parents () end do if (n_p /= n) call err_map allocate (i_parents (n), p_parents (n)) i_parents = interaction_get_parents (int, i) p_parents = pset%prt(q)%get_parents () do k = 1, n q = p_parents(k) if (map(q) == 0) then map(q) = i_parents(k) call recover_parents (q, map) end if end do end subroutine recover_parents recursive subroutine recover_radiation (p, map) integer, intent(in) :: p integer, dimension(:), intent(inout) :: map integer :: i, n, n_p, q, k integer, dimension(:), allocatable :: i_children, p_children if (particle_get_status (pset%prt(p)) == PRT_INCOMING) return i = map(p) n = interaction_get_n_children (int, i) n_p = pset%prt(p)%get_n_children () if (n_p /= n) call err_map allocate (i_children (n), p_children (n)) i_children = interaction_get_children (int, i) p_children = pset%prt(p)%get_children () do k = 1, n q = p_children(k) if (map(q) == 0) then i = i_children(k) if (interaction_get_n_children (int, i) == 0) then map(q) = i else select case (n) case (2) select case (k) case (1); map(q) = i_children(2) case (2); map(q) = i_children(1) end select case (4) select case (k) case (1); map(q) = i_children(3) case (2); map(q) = i_children(4) case (3); map(q) = i_children(1) case (4); map(q) = i_children(2) end select case default call err_radiation end select end if else call recover_radiation (q, map) end if end do end subroutine recover_radiation subroutine reconstruct_beam_and_radiation (k, i_set) integer, intent(in) :: k logical, dimension(:), intent(inout) :: i_set integer :: k_src, k_in, k_rad type(interaction_t), pointer :: int_src integer, dimension(2) :: i_child call int%find_source (k, int_src, k_src) call int%set_momentum (int_src%get_momentum (k_src), k) i_set(k) = .true. if (n_in == 2) then i_child = interaction_get_children (int, k) if (interaction_get_n_children (int, i_child(1)) > 0) then k_in = i_child(1); k_rad = i_child(2) else k_in = i_child(2); k_rad = i_child(1) end if if (.not. i_set(k_in)) call err_beams call int%set_momentum & (int%get_momentum (k) - int%get_momentum (k_in), k_rad) i_set(k_rad) = .true. end if end subroutine reconstruct_beam_and_radiation subroutine err_pset_hard call msg_fatal ("Reading particle set: no particles marked as incoming") end subroutine err_pset_hard subroutine err_int_n_in integer :: n if (allocated (i_in)) then n = size (i_in) else n = 0 end if write (msg_buffer, "(A,I0,A,I0)") & "Filling hard process from particle set: expect ", n_in, & " incoming particle(s), found ", n call msg_bug end subroutine err_int_n_in subroutine err_pset_n_in write (msg_buffer, "(A,I0,A,I0)") & "Reading hard-process particle set: should contain ", n_in, & " incoming particle(s), found ", size (p_in) call msg_fatal end subroutine err_pset_n_in subroutine err_pset_n_out write (msg_buffer, "(A,I0,A,I0)") & "Reading hard-process particle set: should contain ", n_out, & " outgoing particle(s), found ", size (p_out) call msg_fatal end subroutine err_pset_n_out subroutine err_mismatch call pset%write () call state_flv%write () call msg_fatal ("Reading particle set: Flavor combination " & // "does not match requested process") end subroutine err_mismatch subroutine err_map call pset%write () call int%basic_write () call msg_fatal ("Reading hard-process particle set: " & // "Incomplete mapping from particle set to interaction") end subroutine err_map subroutine err_beams call pset%write () call int%basic_write () call msg_fatal ("Reading particle set: Beam structure " & // "does not match requested process") end subroutine err_beams subroutine err_radiation call int%basic_write () call msg_bug ("Reading particle set: Interaction " & // "contains inconsistent radiation pattern.") end subroutine err_radiation end subroutine particle_set_fill_interaction @ %def particle_set_fill_interaction @ This procedure reconstructs an array of vertex indices from the parent-child information in the particle entries, according to the HepMC scheme. For each particle, we determine which vertex it comes from and which vertex it goes to. We return the two arrays and the maximum vertex index. For each particle in the list, we first check its parents. If for any parent the vertex where it goes to is already known, this vertex index is assigned as the current 'from' vertex. Otherwise, a new index is created, assigned as the current 'from' vertex, and as the 'to' vertex for all parents. Then, the analogous procedure is done for the children. Furthermore, we assign to each vertex the vertex position from the parent(s). We check that these vertex positions coincide, and if not return a null vector. <>= procedure :: assign_vertices => particle_set_assign_vertices <>= subroutine particle_set_assign_vertices & (particle_set, v_from, v_to, n_vertices) class(particle_set_t), intent(in) :: particle_set integer, dimension(:), intent(out) :: v_from, v_to integer, intent(out) :: n_vertices integer, dimension(:), allocatable :: parent, child integer :: n_parents, n_children, vf, vt integer :: i, j, v v_from = 0 v_to = 0 vf = 0 vt = 0 do i = 1, particle_set%n_tot n_parents = particle_set%prt(i)%get_n_parents () if (n_parents /= 0) then allocate (parent (n_parents)) parent = particle_set%prt(i)%get_parents () SCAN_PARENTS: do j = 1, size (parent) v = v_to(parent(j)) if (v /= 0) then v_from(i) = v; exit SCAN_PARENTS end if end do SCAN_PARENTS if (v_from(i) == 0) then vf = vf + 1; v_from(i) = vf v_to(parent) = vf end if deallocate (parent) end if n_children = particle_set%prt(i)%get_n_children () if (n_children /= 0) then allocate (child (n_children)) child = particle_set%prt(i)%get_children () SCAN_CHILDREN: do j = 1, size (child) v = v_from(child(j)) if (v /= 0) then v_to(i) = v; exit SCAN_CHILDREN end if end do SCAN_CHILDREN if (v_to(i) == 0) then vt = vt + 1; v_to(i) = vt v_from(child) = vt end if deallocate (child) end if end do n_vertices = max (vf, vt) end subroutine particle_set_assign_vertices @ %def particle_set_assign_vertices @ \subsection{Expression interface} This converts a [[particle_set]] object as defined here to a more concise [[subevt]] object that can be used as the event root of an expression. In particular, the latter lacks virtual particles, spin correlations and parent-child relations. We keep beam particles, incoming partons, and outgoing partons. Furthermore, we keep radiated particles (a.k.a.\ beam remnants) if they have no children in the current particle set, and mark them as outgoing particles. If [[colorize]] is set and true, mark all particles in the subevent as colorized, and set color/anticolor flow indices where they are defined. Colorless particles do not get indices but are still marked as colorized, for consistency. <>= procedure :: to_subevt => particle_set_to_subevt <>= subroutine particle_set_to_subevt (particle_set, subevt, colorize) class(particle_set_t), intent(in) :: particle_set type(subevt_t), intent(out) :: subevt logical, intent(in), optional :: colorize integer :: n_tot, n_beam, n_in, n_out, n_rad integer :: i, k, n_active integer, dimension(2) :: hel logical :: keep n_tot = particle_set_get_n_tot (particle_set) n_beam = particle_set_get_n_beam (particle_set) n_in = particle_set_get_n_in (particle_set) n_out = particle_set_get_n_out (particle_set) n_rad = particle_set_get_n_remnants (particle_set) call subevt_init (subevt, n_beam + n_rad + n_in + n_out) k = 0 do i = 1, n_tot associate (prt => particle_set%prt(i)) keep = .false. select case (particle_get_status (prt)) case (PRT_BEAM) k = k + 1 call subevt_set_beam (subevt, k, & particle_get_pdg (prt), & particle_get_momentum (prt), & particle_get_p2 (prt)) keep = .true. case (PRT_INCOMING) k = k + 1 call subevt_set_incoming (subevt, k, & particle_get_pdg (prt), & particle_get_momentum (prt), & particle_get_p2 (prt)) keep = .true. case (PRT_OUTGOING) k = k + 1 call subevt_set_outgoing (subevt, k, & particle_get_pdg (prt), & particle_get_momentum (prt), & particle_get_p2 (prt)) keep = .true. case (PRT_BEAM_REMNANT) if (particle_get_n_children (prt) == 0) then k = k + 1 call subevt_set_outgoing (subevt, k, & particle_get_pdg (prt), & particle_get_momentum (prt), & particle_get_p2 (prt)) keep = .true. end if end select if (keep) then if (prt%polarization == PRT_DEFINITE_HELICITY) then if (prt%hel%is_diagonal ()) then hel = prt%hel%to_pair () call subevt_polarize (subevt, k, hel(1)) end if end if end if if (present (colorize)) then if (colorize) then call subevt_colorize & (subevt, i, prt%col%get_col (), prt%col%get_acl ()) end if end if end associate n_active = k end do call subevt_reset (subevt, n_active) end subroutine particle_set_to_subevt @ %def particle_set_to_subevt @ This replaces the [[particle\_set\%prt array]] with a given array of particles <>= procedure :: replace => particle_set_replace <>= subroutine particle_set_replace (particle_set, newprt) class(particle_set_t), intent(inout) :: particle_set type(particle_t), intent(in), dimension(:), allocatable :: newprt if (allocated (particle_set%prt)) deallocate (particle_set%prt) allocate (particle_set%prt(size (newprt))) particle_set%prt = newprt particle_set%n_tot = size (newprt) particle_set%n_beam = count (particle_get_status (newprt) == PRT_BEAM) particle_set%n_in = count (particle_get_status (newprt) == PRT_INCOMING) particle_set%n_out = count (particle_get_status (newprt) == PRT_OUTGOING) particle_set%n_vir = particle_set%n_tot & - particle_set%n_beam - particle_set%n_in - particle_set%n_out end subroutine particle_set_replace @ %def particle_set_replace @ This routines orders the outgoing particles into clusters of colorless particles and such of particles ordered corresponding to the indices of the color lines. All outgoing particles in the ordered set appear as child of the corresponding outgoing particle in the unordered set, including colored beam remnants. We always start continue via the anti-color line, such that color flows within each Lund string system is always continued from the anticolor of one particle to the identical color index of another particle. <>= procedure :: order_color_lines => particle_set_order_color_lines <>= subroutine particle_set_order_color_lines (pset_out, pset_in) class(particle_set_t), intent(inout) :: pset_out type(particle_set_t), intent(in) :: pset_in integer :: i, n, n_col_rem n_col_rem = 0 do i = 1, pset_in%n_tot if (pset_in%prt(i)%get_status () == PRT_BEAM_REMNANT .and. & any (pset_in%prt(i)%get_color () /= 0)) then n_col_rem = n_col_rem + 1 end if end do pset_out%n_beam = pset_in%n_beam pset_out%n_in = pset_in%n_in pset_out%n_vir = pset_in%n_vir + pset_in%n_out + n_col_rem pset_out%n_out = pset_in%n_out pset_out%n_tot = pset_in%n_tot + pset_in%n_out + n_col_rem pset_out%correlated_state = pset_in%correlated_state pset_out%factorization_mode = pset_in%factorization_mode allocate (pset_out%prt (pset_out%n_tot)) do i = 1, pset_in%n_tot call pset_out%prt(i)%init (pset_in%prt(i)) call pset_out%prt(i)%set_children (pset_in%prt(i)%child) call pset_out%prt(i)%set_parents (pset_in%prt(i)%parent) end do n = pset_in%n_tot do i = 1, pset_in%n_tot if (pset_out%prt(i)%get_status () == PRT_OUTGOING .and. & all (pset_out%prt(i)%get_color () == 0) .and. & .not. pset_out%prt(i)%has_children ()) then n = n + 1 call pset_out%prt(n)%init (pset_out%prt(i)) call pset_out%prt(i)%reset_status (PRT_VIRTUAL) call pset_out%prt(i)%add_child (n) call pset_out%prt(i)%set_parents ([i]) end if end do if (n_col_rem > 0) then do i = 1, n_col_rem end do end if end subroutine particle_set_order_color_lines @ %def particle_set_order_color_lines @ Eliminate numerical noise <>= public :: pacify <>= interface pacify module procedure pacify_particle module procedure pacify_particle_set end interface pacify <>= subroutine pacify_particle (prt) class(particle_t), intent(inout) :: prt real(default) :: e e = epsilon (1._default) * energy (prt%p) call pacify (prt%p, 10 * e) call pacify (prt%p2, 1e4 * e) end subroutine pacify_particle subroutine pacify_particle_set (pset) class(particle_set_t), intent(inout) :: pset integer :: i do i = 1, pset%n_tot call pacify (pset%prt(i)) end do end subroutine pacify_particle_set @ %def pacify @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[particles_ut.f90]]>>= <> module particles_ut use unit_tests use particles_uti <> <> contains <> end module particles_ut @ %def particles_ut @ <<[[particles_uti.f90]]>>= <> module particles_uti <> use io_units use numeric_utils use constants, only: one, tiny_07 use lorentz use flavors use colors use helicities use quantum_numbers use state_matrices use interactions use evaluators use model_data use subevents use particles <> <> contains <> <> end module particles_uti @ %def particles_ut @ API: driver for the unit tests below. <>= public :: particles_test <>= subroutine particles_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine particles_test @ %def particles_test @ Check the basic setup of the [[particle_set_t]] type: Set up a chain of production and decay and factorize the result into particles. The process is $d\bar d \to Z \to q\bar q$. <>= call test (particles_1, "particles_1", & "check particle_set routines", & u, results) <>= public :: particles_1 <>= subroutine particles_1 (u) use os_interface integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(3) :: flv type(color_t), dimension(3) :: col type(helicity_t), dimension(3) :: hel type(quantum_numbers_t), dimension(3) :: qn type(vector4_t), dimension(3) :: p type(interaction_t), target :: int1, int2 type(quantum_numbers_mask_t) :: qn_mask_conn type(evaluator_t), target :: eval type(interaction_t) :: int type(particle_set_t) :: particle_set1, particle_set2 type(particle_set_t) :: particle_set3, particle_set4 type(subevt_t) :: subevt logical :: ok integer :: unit, iostat write (u, "(A)") "* Test output: Particles" write (u, "(A)") "* Purpose: test particle_set routines" write (u, "(A)") write (u, "(A)") "* Reading model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Initializing production process" call int1%basic_init (2, 0, 1, set_relations=.true.) call flv%init ([1, -1, 23], model) call col%init_col_acl ([0, 0, 0], [0, 0, 0]) call hel(3)%init (1, 1) call qn%init (flv, col, hel) call int1%add_state (qn, value=(0.25_default, 0._default)) call hel(3)%init (1,-1) call qn%init (flv, col, hel) call int1%add_state (qn, value=(0._default, 0.25_default)) call hel(3)%init (-1, 1) call qn%init (flv, col, hel) call int1%add_state (qn, value=(0._default,-0.25_default)) call hel(3)%init (-1,-1) call qn%init (flv, col, hel) call int1%add_state (qn, value=(0.25_default, 0._default)) call hel(3)%init (0, 0) call qn%init (flv, col, hel) call int1%add_state (qn, value=(0.5_default, 0._default)) call int1%freeze () p(1) = vector4_moving (45._default, 45._default, 3) p(2) = vector4_moving (45._default,-45._default, 3) p(3) = p(1) + p(2) call int1%set_momenta (p) write (u, "(A)") write (u, "(A)") "* Setup decay process" call int2%basic_init (1, 0, 2, set_relations=.true.) call flv%init ([23, 1, -1], model) call col%init_col_acl ([0, 501, 0], [0, 0, 501]) call hel%init ([1, 1, 1], [1, 1, 1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(1._default, 0._default)) call hel%init ([1, 1, 1], [-1,-1,-1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(0._default, 0.1_default)) call hel%init ([-1,-1,-1], [1, 1, 1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(0._default,-0.1_default)) call hel%init ([-1,-1,-1], [-1,-1,-1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(1._default, 0._default)) call hel%init ([0, 1,-1], [0, 1,-1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(4._default, 0._default)) call hel%init ([0,-1, 1], [0, 1,-1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(2._default, 0._default)) call hel%init ([0, 1,-1], [0,-1, 1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(2._default, 0._default)) call hel%init ([0,-1, 1], [0,-1, 1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(4._default, 0._default)) call flv%init ([23, 2, -2], model) call hel%init ([0, 1,-1], [0, 1,-1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(0.5_default, 0._default)) call hel%init ([0,-1, 1], [0,-1, 1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(0.5_default, 0._default)) call int2%freeze () p(2) = vector4_moving (45._default, 45._default, 2) p(3) = vector4_moving (45._default,-45._default, 2) call int2%set_momenta (p) call int2%set_source_link (1, int1, 3) call int1%basic_write (u) call int2%basic_write (u) write (u, "(A)") write (u, "(A)") "* Concatenate production and decay" call eval%init_product (int1, int2, qn_mask_conn, & connections_are_resonant=.true.) call eval%receive_momenta () call eval%evaluate () call eval%write (u) write (u, "(A)") write (u, "(A)") "* Factorize as subevent (complete, polarized)" write (u, "(A)") int = eval%interaction_t call particle_set1%init & (ok, int, int, FM_FACTOR_HELICITY, & [0.2_default, 0.2_default], .false., .true.) call particle_set1%write (u) write (u, "(A)") write (u, "(A)") "* Factorize as subevent (in/out only, selected helicity)" write (u, "(A)") int = eval%interaction_t call particle_set2%init & (ok, int, int, FM_SELECT_HELICITY, & [0.9_default, 0.9_default], .false., .false.) call particle_set2%write (u) call particle_set2%final () write (u, "(A)") write (u, "(A)") "* Factorize as subevent (complete, selected helicity)" write (u, "(A)") int = eval%interaction_t call particle_set2%init & (ok, int, int, FM_SELECT_HELICITY, & [0.7_default, 0.7_default], .false., .true.) call particle_set2%write (u) write (u, "(A)") write (u, "(A)") & "* Factorize (complete, polarized, correlated); write and read again" write (u, "(A)") int = eval%interaction_t call particle_set3%init & (ok, int, int, FM_FACTOR_HELICITY, & [0.7_default, 0.7_default], .true., .true.) call particle_set3%write (u) unit = free_unit () open (unit, action="readwrite", form="unformatted", status="scratch") call particle_set3%write_raw (unit) rewind (unit) call particle_set4%read_raw (unit, iostat=iostat) call particle_set4%set_model (model) close (unit) write (u, "(A)") write (u, "(A)") "* Result from reading" write (u, "(A)") call particle_set4%write (u) write (u, "(A)") write (u, "(A)") "* Transform to a subevt object" write (u, "(A)") call particle_set4%to_subevt (subevt) call subevt_write (subevt, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call particle_set1%final () call particle_set2%final () call particle_set3%final () call particle_set4%final () call eval%final () call int1%final () call int2%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: particles_1" end subroutine particles_1 @ %def particles_1 @ Reconstruct a hard interaction from a particle set. <>= call test (particles_2, "particles_2", & "reconstruct hard interaction", & u, results) <>= public :: particles_2 <>= subroutine particles_2 (u) integer, intent(in) :: u type(interaction_t) :: int type(state_flv_content_t) :: state_flv type(particle_set_t) :: pset type(flavor_t), dimension(:), allocatable :: flv type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: i, j write (u, "(A)") "* Test output: Particles" write (u, "(A)") "* Purpose: reconstruct simple interaction" write (u, "(A)") write (u, "(A)") "* Set up a 2 -> 3 interaction" write (u, "(A)") " + incoming partons marked as virtual" write (u, "(A)") " + no quantum numbers" write (u, "(A)") call reset_interaction_counter () call int%basic_init (0, 2, 3) do i = 1, 2 do j = 3, 5 call int%relate (i, j) end do end do allocate (qn (5)) call int%add_state (qn) call int%freeze () call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Manually set up a flavor-content record" write (u, "(A)") call state_flv%init (1, & mask = [.false., .false., .true., .true., .true.]) call state_flv%set_entry (1, & pdg = [11, 12, 3, 4, 5], & map = [1, 2, 3, 4, 5]) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Manually create a matching particle set" write (u, "(A)") pset%n_beam = 0 pset%n_in = 2 pset%n_vir = 0 pset%n_out = 3 pset%n_tot = 5 allocate (pset%prt (pset%n_tot)) do i = 1, 2 call pset%prt(i)%reset_status (PRT_INCOMING) call pset%prt(i)%set_children ([3,4,5]) end do do i = 3, 5 call pset%prt(i)%reset_status (PRT_OUTGOING) call pset%prt(i)%set_parents ([1,2]) end do call pset%prt(1)%set_momentum (vector4_at_rest (1._default)) call pset%prt(2)%set_momentum (vector4_at_rest (2._default)) call pset%prt(3)%set_momentum (vector4_at_rest (5._default)) call pset%prt(4)%set_momentum (vector4_at_rest (4._default)) call pset%prt(5)%set_momentum (vector4_at_rest (3._default)) allocate (flv (5)) call flv%init ([11,12,5,4,3]) do i = 1, 5 call pset%prt(i)%set_flavor (flv(i)) end do call pset%write (u) write (u, "(A)") write (u, "(A)") "* Fill interaction from particle set" write (u, "(A)") call pset%fill_interaction (int, 2, state_flv=state_flv) call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call int%final () call pset%final () write (u, "(A)") write (u, "(A)") "* Test output end: particles_2" end subroutine particles_2 @ %def particles_2 @ Reconstruct an interaction with beam structure, e.g., a hadronic interaction, from a particle set. <>= call test (particles_3, "particles_3", & "reconstruct interaction with beam structure", & u, results) <>= public :: particles_3 <>= subroutine particles_3 (u) integer, intent(in) :: u type(interaction_t) :: int type(state_flv_content_t) :: state_flv type(particle_set_t) :: pset type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: i, j write (u, "(A)") "* Test output: Particles" write (u, "(A)") "* Purpose: reconstruct simple interaction" write (u, "(A)") write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation" write (u, "(A)") " + no quantum numbers" write (u, "(A)") call reset_interaction_counter () call int%basic_init (0, 6, 3) call int%relate (1, 3) call int%relate (1, 4) call int%relate (2, 5) call int%relate (2, 6) do i = 4, 6, 2 do j = 7, 9 call int%relate (i, j) end do end do allocate (qn (9)) call int%add_state (qn) call int%freeze () call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Manually set up a flavor-content record" write (u, "(A)") call state_flv%init (1, & mask = [.false., .false., .false., .false., .false., .false., & .true., .true., .true.]) call state_flv%set_entry (1, & pdg = [2011, 2012, 91, 11, 92, 12, 3, 4, 5], & map = [1, 2, 3, 4, 5, 6, 7, 8, 9]) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Manually create a matching particle set" write (u, "(A)") call create_test_particle_set_1 (pset) call pset%write (u) write (u, "(A)") write (u, "(A)") "* Fill interaction from particle set" write (u, "(A)") call pset%fill_interaction (int, 2, state_flv=state_flv) call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call int%final () call pset%final () write (u, "(A)") write (u, "(A)") "* Test output end: particles_3" end subroutine particles_3 @ %def particles_3 @ <>= subroutine create_test_particle_set_1 (pset) type(particle_set_t), intent(out) :: pset type(flavor_t), dimension(:), allocatable :: flv integer :: i pset%n_beam = 2 pset%n_in = 2 pset%n_vir = 2 pset%n_out = 3 pset%n_tot = 9 allocate (pset%prt (pset%n_tot)) call pset%prt(1)%reset_status (PRT_BEAM) call pset%prt(2)%reset_status (PRT_BEAM) call pset%prt(3)%reset_status (PRT_INCOMING) call pset%prt(4)%reset_status (PRT_INCOMING) call pset%prt(5)%reset_status (PRT_BEAM_REMNANT) call pset%prt(6)%reset_status (PRT_BEAM_REMNANT) call pset%prt(7)%reset_status (PRT_OUTGOING) call pset%prt(8)%reset_status (PRT_OUTGOING) call pset%prt(9)%reset_status (PRT_OUTGOING) call pset%prt(1)%set_children ([3,5]) call pset%prt(2)%set_children ([4,6]) call pset%prt(3)%set_children ([7,8,9]) call pset%prt(4)%set_children ([7,8,9]) call pset%prt(3)%set_parents ([1]) call pset%prt(4)%set_parents ([2]) call pset%prt(5)%set_parents ([1]) call pset%prt(6)%set_parents ([2]) call pset%prt(7)%set_parents ([3,4]) call pset%prt(8)%set_parents ([3,4]) call pset%prt(9)%set_parents ([3,4]) call pset%prt(1)%set_momentum (vector4_at_rest (1._default)) call pset%prt(2)%set_momentum (vector4_at_rest (2._default)) call pset%prt(3)%set_momentum (vector4_at_rest (4._default)) call pset%prt(4)%set_momentum (vector4_at_rest (6._default)) call pset%prt(5)%set_momentum (vector4_at_rest (3._default)) call pset%prt(6)%set_momentum (vector4_at_rest (5._default)) call pset%prt(7)%set_momentum (vector4_at_rest (7._default)) call pset%prt(8)%set_momentum (vector4_at_rest (8._default)) call pset%prt(9)%set_momentum (vector4_at_rest (9._default)) allocate (flv (9)) call flv%init ([2011, 2012, 11, 12, 91, 92, 3, 4, 5]) do i = 1, 9 call pset%prt(i)%set_flavor (flv(i)) end do end subroutine create_test_particle_set_1 @ %def create_test_particle_set_1 @ Reconstruct an interaction with beam structure, e.g., a hadronic interaction, from a particle set that is missing the beam information. <>= call test (particles_4, "particles_4", & "reconstruct interaction with missing beams", & u, results) <>= public :: particles_4 <>= subroutine particles_4 (u) integer, intent(in) :: u type(interaction_t) :: int type(interaction_t), target :: int_beams type(state_flv_content_t) :: state_flv type(particle_set_t) :: pset type(flavor_t), dimension(:), allocatable :: flv type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: i, j write (u, "(A)") "* Test output: Particles" write (u, "(A)") "* Purpose: reconstruct beams" write (u, "(A)") call reset_interaction_counter () write (u, "(A)") "* Set up an interaction that contains beams only" write (u, "(A)") call int_beams%basic_init (0, 0, 2) call int_beams%set_momentum (vector4_at_rest (1._default), 1) call int_beams%set_momentum (vector4_at_rest (2._default), 2) allocate (qn (2)) call int_beams%add_state (qn) call int_beams%freeze () call int_beams%basic_write (u) write (u, "(A)") write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation" write (u, "(A)") " + no quantum numbers" write (u, "(A)") call int%basic_init (0, 6, 3) call int%relate (1, 3) call int%relate (1, 4) call int%relate (2, 5) call int%relate (2, 6) do i = 4, 6, 2 do j = 7, 9 call int%relate (i, j) end do end do do i = 1, 2 call int%set_source_link (i, int_beams, i) end do deallocate (qn) allocate (qn (9)) call int%add_state (qn) call int%freeze () call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Manually set up a flavor-content record" write (u, "(A)") call state_flv%init (1, & mask = [.false., .false., .false., .false., .false., .false., & .true., .true., .true.]) call state_flv%set_entry (1, & pdg = [2011, 2012, 91, 11, 92, 12, 3, 4, 5], & map = [1, 2, 3, 4, 5, 6, 7, 8, 9]) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Manually create a matching particle set" write (u, "(A)") pset%n_beam = 0 pset%n_in = 2 pset%n_vir = 0 pset%n_out = 3 pset%n_tot = 5 allocate (pset%prt (pset%n_tot)) call pset%prt(1)%reset_status (PRT_INCOMING) call pset%prt(2)%reset_status (PRT_INCOMING) call pset%prt(3)%reset_status (PRT_OUTGOING) call pset%prt(4)%reset_status (PRT_OUTGOING) call pset%prt(5)%reset_status (PRT_OUTGOING) call pset%prt(1)%set_children ([3,4,5]) call pset%prt(2)%set_children ([3,4,5]) call pset%prt(3)%set_parents ([1,2]) call pset%prt(4)%set_parents ([1,2]) call pset%prt(5)%set_parents ([1,2]) call pset%prt(1)%set_momentum (vector4_at_rest (6._default)) call pset%prt(2)%set_momentum (vector4_at_rest (6._default)) call pset%prt(3)%set_momentum (vector4_at_rest (3._default)) call pset%prt(4)%set_momentum (vector4_at_rest (4._default)) call pset%prt(5)%set_momentum (vector4_at_rest (5._default)) allocate (flv (5)) call flv%init ([11, 12, 3, 4, 5]) do i = 1, 5 call pset%prt(i)%set_flavor (flv(i)) end do call pset%write (u) write (u, "(A)") write (u, "(A)") "* Fill interaction from particle set" write (u, "(A)") call pset%fill_interaction (int, 2, state_flv=state_flv, & recover_beams = .true.) call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call int%final () call pset%final () write (u, "(A)") write (u, "(A)") "* Test output end: particles_4" end subroutine particles_4 @ %def particles_4 @ Reconstruct an interaction with beam structure and cloned particles (radiated particles repeated in the event record, to maintain some canonical ordering). <>= call test (particles_5, "particles_5", & "reconstruct interaction with beams and duplicate entries", & u, results) <>= public :: particles_5 <>= subroutine particles_5 (u) integer, intent(in) :: u type(interaction_t) :: int type(state_flv_content_t) :: state_flv type(particle_set_t) :: pset type(flavor_t), dimension(:), allocatable :: flv type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: i, j write (u, "(A)") "* Test output: Particles" write (u, "(A)") "* Purpose: reconstruct event with duplicate entries" write (u, "(A)") write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation" write (u, "(A)") " + no quantum numbers" write (u, "(A)") call reset_interaction_counter () call int%basic_init (0, 6, 3) call int%relate (1, 3) call int%relate (1, 4) call int%relate (2, 5) call int%relate (2, 6) do i = 4, 6, 2 do j = 7, 9 call int%relate (i, j) end do end do allocate (qn (9)) call int%add_state (qn) call int%freeze () call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Manually set up a flavor-content record" write (u, "(A)") call state_flv%init (1, & mask = [.false., .false., .false., .false., .false., .false., & .true., .true., .true.]) call state_flv%set_entry (1, & pdg = [2011, 2012, 91, 11, 92, 12, 3, 4, 5], & map = [1, 2, 3, 4, 5, 6, 7, 8, 9]) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Manually create a matching particle set" write (u, "(A)") pset%n_beam = 2 pset%n_in = 2 pset%n_vir = 4 pset%n_out = 5 pset%n_tot = 13 allocate (pset%prt (pset%n_tot)) call pset%prt(1)%reset_status (PRT_BEAM) call pset%prt(2)%reset_status (PRT_BEAM) call pset%prt(3)%reset_status (PRT_VIRTUAL) call pset%prt(4)%reset_status (PRT_VIRTUAL) call pset%prt(5)%reset_status (PRT_VIRTUAL) call pset%prt(6)%reset_status (PRT_VIRTUAL) call pset%prt(7)%reset_status (PRT_INCOMING) call pset%prt(8)%reset_status (PRT_INCOMING) call pset%prt( 9)%reset_status (PRT_OUTGOING) call pset%prt(10)%reset_status (PRT_OUTGOING) call pset%prt(11)%reset_status (PRT_OUTGOING) call pset%prt(12)%reset_status (PRT_OUTGOING) call pset%prt(13)%reset_status (PRT_OUTGOING) call pset%prt(1)%set_children ([3,4]) call pset%prt(2)%set_children ([5,6]) call pset%prt(3)%set_children ([ 7]) call pset%prt(4)%set_children ([ 9]) call pset%prt(5)%set_children ([ 8]) call pset%prt(6)%set_children ([10]) call pset%prt(7)%set_children ([11,12,13]) call pset%prt(8)%set_children ([11,12,13]) call pset%prt(3)%set_parents ([1]) call pset%prt(4)%set_parents ([1]) call pset%prt(5)%set_parents ([2]) call pset%prt(6)%set_parents ([2]) call pset%prt( 7)%set_parents ([3]) call pset%prt( 8)%set_parents ([5]) call pset%prt( 9)%set_parents ([4]) call pset%prt(10)%set_parents ([6]) call pset%prt(11)%set_parents ([7,8]) call pset%prt(12)%set_parents ([7,8]) call pset%prt(13)%set_parents ([7,8]) call pset%prt(1)%set_momentum (vector4_at_rest (1._default)) call pset%prt(2)%set_momentum (vector4_at_rest (2._default)) call pset%prt(3)%set_momentum (vector4_at_rest (4._default)) call pset%prt(4)%set_momentum (vector4_at_rest (3._default)) call pset%prt(5)%set_momentum (vector4_at_rest (6._default)) call pset%prt(6)%set_momentum (vector4_at_rest (5._default)) call pset%prt(7)%set_momentum (vector4_at_rest (4._default)) call pset%prt(8)%set_momentum (vector4_at_rest (6._default)) call pset%prt( 9)%set_momentum (vector4_at_rest (3._default)) call pset%prt(10)%set_momentum (vector4_at_rest (5._default)) call pset%prt(11)%set_momentum (vector4_at_rest (7._default)) call pset%prt(12)%set_momentum (vector4_at_rest (8._default)) call pset%prt(13)%set_momentum (vector4_at_rest (9._default)) allocate (flv (13)) call flv%init ([2011, 2012, 11, 91, 12, 92, 11, 12, 91, 92, 3, 4, 5]) do i = 1, 13 call pset%prt(i)%set_flavor (flv(i)) end do call pset%write (u) write (u, "(A)") write (u, "(A)") "* Fill interaction from particle set" write (u, "(A)") call pset%fill_interaction (int, 2, state_flv=state_flv) call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call int%final () call pset%final () write (u, "(A)") write (u, "(A)") "* Test output end: particles_5" end subroutine particles_5 @ %def particles_5 @ Reconstruct an interaction with pair spectrum, e.g., beamstrahlung from a particle set. <>= call test (particles_6, "particles_6", & "reconstruct interaction with pair spectrum", & u, results) <>= public :: particles_6 <>= subroutine particles_6 (u) integer, intent(in) :: u type(interaction_t) :: int type(state_flv_content_t) :: state_flv type(particle_set_t) :: pset type(flavor_t), dimension(:), allocatable :: flv type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: i, j write (u, "(A)") "* Test output: Particles" write (u, "(A)") "* Purpose: reconstruct interaction with pair spectrum" write (u, "(A)") write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation" write (u, "(A)") " + no quantum numbers" write (u, "(A)") call reset_interaction_counter () call int%basic_init (0, 6, 3) do i = 1, 2 do j = 3, 6 call int%relate (i, j) end do end do do i = 5, 6 do j = 7, 9 call int%relate (i, j) end do end do allocate (qn (9)) call int%add_state (qn) call int%freeze () call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Manually set up a flavor-content record" write (u, "(A)") call state_flv%init (1, & mask = [.false., .false., .false., .false., .false., .false., & .true., .true., .true.]) call state_flv%set_entry (1, & pdg = [1011, 1012, 21, 22, 11, 12, 3, 4, 5], & map = [1, 2, 3, 4, 5, 6, 7, 8, 9]) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Manually create a matching particle set" write (u, "(A)") pset%n_beam = 2 pset%n_in = 2 pset%n_vir = 2 pset%n_out = 3 pset%n_tot = 9 allocate (pset%prt (pset%n_tot)) call pset%prt(1)%reset_status (PRT_BEAM) call pset%prt(2)%reset_status (PRT_BEAM) call pset%prt(3)%reset_status (PRT_INCOMING) call pset%prt(4)%reset_status (PRT_INCOMING) call pset%prt(5)%reset_status (PRT_OUTGOING) call pset%prt(6)%reset_status (PRT_OUTGOING) call pset%prt(7)%reset_status (PRT_OUTGOING) call pset%prt(8)%reset_status (PRT_OUTGOING) call pset%prt(9)%reset_status (PRT_OUTGOING) call pset%prt(1)%set_children ([3,4,5,6]) call pset%prt(2)%set_children ([3,4,5,6]) call pset%prt(3)%set_children ([7,8,9]) call pset%prt(4)%set_children ([7,8,9]) call pset%prt(3)%set_parents ([1,2]) call pset%prt(4)%set_parents ([1,2]) call pset%prt(5)%set_parents ([1,2]) call pset%prt(6)%set_parents ([1,2]) call pset%prt(7)%set_parents ([3,4]) call pset%prt(8)%set_parents ([3,4]) call pset%prt(9)%set_parents ([3,4]) call pset%prt(1)%set_momentum (vector4_at_rest (1._default)) call pset%prt(2)%set_momentum (vector4_at_rest (2._default)) call pset%prt(3)%set_momentum (vector4_at_rest (5._default)) call pset%prt(4)%set_momentum (vector4_at_rest (6._default)) call pset%prt(5)%set_momentum (vector4_at_rest (3._default)) call pset%prt(6)%set_momentum (vector4_at_rest (4._default)) call pset%prt(7)%set_momentum (vector4_at_rest (7._default)) call pset%prt(8)%set_momentum (vector4_at_rest (8._default)) call pset%prt(9)%set_momentum (vector4_at_rest (9._default)) allocate (flv (9)) call flv%init ([1011, 1012, 11, 12, 21, 22, 3, 4, 5]) do i = 1, 9 call pset%prt(i)%set_flavor (flv(i)) end do call pset%write (u) write (u, "(A)") write (u, "(A)") "* Fill interaction from particle set" write (u, "(A)") call pset%fill_interaction (int, 2, state_flv=state_flv) call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call int%final () call pset%final () write (u, "(A)") write (u, "(A)") "* Test output end: particles_6" end subroutine particles_6 @ %def particles_6 @ Reconstruct a hard decay interaction from a shuffled particle set. <>= call test (particles_7, "particles_7", & "reconstruct decay interaction with reordering", & u, results) <>= public :: particles_7 <>= subroutine particles_7 (u) integer, intent(in) :: u type(interaction_t) :: int type(state_flv_content_t) :: state_flv type(particle_set_t) :: pset type(flavor_t), dimension(:), allocatable :: flv type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: i, j write (u, "(A)") "* Test output: Particles" write (u, "(A)") "* Purpose: reconstruct decay interaction with reordering" write (u, "(A)") write (u, "(A)") "* Set up a 1 -> 3 interaction" write (u, "(A)") " + no quantum numbers" write (u, "(A)") call reset_interaction_counter () call int%basic_init (0, 1, 3) do j = 2, 4 call int%relate (1, j) end do allocate (qn (4)) call int%add_state (qn) call int%freeze () call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Manually set up a flavor-content record" write (u, "(A)") "* assumed interaction: 6 12 5 -11" write (u, "(A)") call state_flv%init (1, & mask = [.false., .true., .true., .true.]) call state_flv%set_entry (1, & pdg = [6, 5, -11, 12], & map = [1, 4, 2, 3]) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Manually create a matching particle set" write (u, "(A)") pset%n_beam = 0 pset%n_in = 1 pset%n_vir = 0 pset%n_out = 3 pset%n_tot = 4 allocate (pset%prt (pset%n_tot)) do i = 1, 1 call pset%prt(i)%reset_status (PRT_INCOMING) call pset%prt(i)%set_children ([2,3,4]) end do do i = 2, 4 call pset%prt(i)%reset_status (PRT_OUTGOING) call pset%prt(i)%set_parents ([1]) end do call pset%prt(1)%set_momentum (vector4_at_rest (1._default)) call pset%prt(2)%set_momentum (vector4_at_rest (3._default)) call pset%prt(3)%set_momentum (vector4_at_rest (2._default)) call pset%prt(4)%set_momentum (vector4_at_rest (4._default)) allocate (flv (4)) call flv%init ([6,5,12,-11]) do i = 1, 4 call pset%prt(i)%set_flavor (flv(i)) end do call pset%write (u) write (u, "(A)") write (u, "(A)") "* Fill interaction from particle set" write (u, "(A)") call pset%fill_interaction (int, 1, state_flv=state_flv) call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call int%final () call pset%final () write (u, "(A)") write (u, "(A)") "* Test output end: particles_7" end subroutine particles_7 @ %def particles_7 @ <>= call test (particles_8, "particles_8", & "Test functions on particle sets", u, results) <>= public :: particles_8 <>= subroutine particles_8 (u) integer, intent(in) :: u type(particle_set_t) :: particle_set type(particle_t), dimension(:), allocatable :: particles integer, allocatable, dimension(:) :: children, parents integer :: n_particles, i write (u, "(A)") "* Test output: particles_8" write (u, "(A)") "* Purpose: Test functions on particle sets" write (u, "(A)") call create_test_particle_set_1 (particle_set) call particle_set%write (u) call assert_equal (u, particle_set%n_tot, 9) call assert_equal (u, particle_set%n_beam, 2) allocate (children (particle_set%prt(3)%get_n_children ())) children = particle_set%prt(3)%get_children() call assert_equal (u, particle_set%prt(children(1))%get_pdg (), 3) call assert_equal (u, size (particle_set%prt(1)%get_children ()), 2) call assert_equal (u, size (particle_set%prt(2)%get_children ()), 2) call particle_set%without_hadronic_remnants & (particles, n_particles, 3) call particle_set%replace (particles) write (u, "(A)") call particle_set%write (u) call assert_equal (u, n_particles, 7) call assert_equal (u, size(particles), 10) call assert_equal (u, particle_set%n_tot, 10) call assert_equal (u, particle_set%n_beam, 2) do i = 3, 4 if (allocated (children)) deallocate (children) allocate (children (particle_set%prt(i)%get_n_children ())) children = particle_set%prt(i)%get_children() call assert_equal (u, particle_set%prt(children(1))%get_pdg (), 3) call assert_equal (u, particle_set%prt(children(2))%get_pdg (), 4) call assert_equal (u, particle_set%prt(children(3))%get_pdg (), 5) end do do i = 5, 7 if (allocated (parents)) deallocate (parents) allocate (parents (particle_set%prt(i)%get_n_parents ())) parents = particle_set%prt(i)%get_parents() call assert_equal (u, particle_set%prt(parents(1))%get_pdg (), 11) call assert_equal (u, particle_set%prt(parents(2))%get_pdg (), 12) end do call assert_equal (u, size (particle_set%prt(1)%get_children ()), & 1, "get children of 1") call assert_equal (u, size (particle_set%prt(2)%get_children ()), & 1, "get children of 2") call assert_equal (u, particle_set%find_particle & (particle_set%prt(1)%get_pdg (), particle_set%prt(1)%p), & 1, "find 1st particle") call assert_equal (u, particle_set%find_particle & (particle_set%prt(2)%get_pdg (), particle_set%prt(2)%p * & (one + tiny_07), rel_smallness=1.0E-6_default), & 2, "find 2nd particle fuzzy") write (u, "(A)") write (u, "(A)") "* Test output end: particles_8" end subroutine particles_8 @ %def particles_8 @ Order color lines into Lund string systems, without colored beam remnants first. <>= call test (particles_9, "particles_9", & "order into Lund strings, uncolored beam remnants", & u, results) <>= public :: particles_9 <>= subroutine particles_9 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: particles_9" write (u, "(A)") "* Purpose: Order into Lund strings, " write (u, "(A)") "* uncolored beam remnants" write (u, "(A)") end subroutine particles_9 @ %def particles_9 Index: trunk/src/transforms/transforms.nw =================================================================== --- trunk/src/transforms/transforms.nw (revision 8234) +++ trunk/src/transforms/transforms.nw (revision 8235) @@ -1,14085 +1,14084 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD event transforms and event API %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Event Implementation} \includemodulegraph{transforms} With a process object and the associated methods at hand, we can generate events for elementary processes and, by subsequent transformation, for complete physical processes. We have the following modules: \begin{description} \item[event\_transforms] Abstract base type for transforming a physical process with process instance and included evaluators, etc., into a new object. The following modules extend this base type. \item[resonance\_insertion] Insert a resonance history into an event record, based on kinematical and matrix-element information. \item[recoil\_kinematics] Common kinematics routines for the ISR and EPA handlers. \item[isr\_photon\_handler] Transform collinear kinematics, as it results from applying ISR radiation, to non-collinear kinematics with a reasonable transverse-momentum distribution of the radiated photons, and also of the recoiling partonic event. \item[epa\_beam\_handler] For photon-initiated processes where the effective photon approximation is used in integration, to add in beam-particle recoil. Analogous to the ISR handler. \item[decays] Combine the elementary process with elementary decay processes and thus transform the elementary event into a decayed event, still at the parton level. \item[showers] Create QED/QCD showers out of the partons that are emitted by elementary processes. This should be interleaved with showering of radiated particles (structure functions) and multiple interactions. \item[hadrons] (not implemented yet) Apply hadronization to the partonic events, interleaved with hadron decays. (The current setup relies on hadronizing partonic events externally.) \item[tau\_decays] (not implemented yet) Let $\tau$ leptons decay taking full spin correlations into account. \item[evt\_nlo] Handler for fixed-order NLO events. \item[events] Combine all pieces to generate full events. \item[eio\_raw] Raw I/O for complete events. \end{description} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Abstract Event Transforms} <<[[event_transforms.f90]]>>= <> module event_transforms <> <> use io_units use format_utils, only: write_separator use diagnostics use model_data use interactions use particles use subevents use rng_base use quantum_numbers, only: quantum_numbers_t use process, only: process_t use instances, only: process_instance_t use process_stacks <> <> <> <> contains <> end module event_transforms @ %def event_transforms @ \subsection{Abstract base type} Essentially, all methods are abstract, but some get minimal base versions. We know that there will be a random-number generator at top level, and that we will relate to an elementary process. The model is stored separately. It may contain modified setting that differ from the model instance stored in the process object. Each event transform contains a particle set that it can fill for further use. There is a flag that indicates this. We will collect event transforms in a list, therefore we include [[previous]] and [[next]] pointers. <>= public :: evt_t <>= type, abstract :: evt_t type(process_t), pointer :: process => null () type(process_instance_t), pointer :: process_instance => null () class(model_data_t), pointer :: model => null () class(rng_t), allocatable :: rng integer :: rejection_count = 0 logical :: particle_set_exists = .false. type(particle_set_t) :: particle_set class(evt_t), pointer :: previous => null () class(evt_t), pointer :: next => null () real(default) :: weight = 0._default logical :: only_weighted_events = .false. contains <> end type evt_t @ %def evt_t @ Finalizer. In any case, we finalize the r.n.g. The process instance is a pointer and should not be finalized here. <>= procedure :: final => evt_final procedure :: base_final => evt_final <>= subroutine evt_final (evt) class(evt_t), intent(inout) :: evt if (allocated (evt%rng)) call evt%rng%final () if (evt%particle_set_exists) & call evt%particle_set%final () end subroutine evt_final @ %def evt_final @ Print out the type of the [[evt]]. <>= procedure (evt_write_name), deferred :: write_name <>= abstract interface subroutine evt_write_name (evt, unit) import class(evt_t), intent(in) :: evt integer, intent(in), optional :: unit end subroutine evt_write_name end interface @ %def evt_write_name @ <>= procedure (evt_write), deferred :: write <>= abstract interface subroutine evt_write (evt, unit, verbose, more_verbose, testflag) import class(evt_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag end subroutine evt_write end interface @ %def evt_write @ Output. We can print r.n.g. info. <>= procedure :: base_write => evt_base_write <>= subroutine evt_base_write (evt, unit, testflag, show_set) class(evt_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag, show_set integer :: u logical :: show u = given_output_unit (unit) show = .true.; if (present (show_set)) show = show_set if (associated (evt%process)) then write (u, "(3x,A,A,A)") "Associated process: '", & char (evt%process%get_id ()), "'" end if if (allocated (evt%rng)) then call evt%rng%write (u, 1) write (u, "(3x,A,I0)") "Number of tries = ", evt%rejection_count end if if (show) then if (evt%particle_set_exists) then call write_separator (u) call evt%particle_set%write (u, testflag = testflag) end if end if end subroutine evt_base_write @ %def evt_base_write @ Connect the transform with a process instance (and thus with the associated process). Use this to allocate the master random-number generator. This is not an initializer; we may initialize the transform by implementation-specific methods. <>= procedure :: connect => evt_connect procedure :: base_connect => evt_connect <>= subroutine evt_connect (evt, process_instance, model, process_stack) class(evt_t), intent(inout), target :: evt type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack evt%process => process_instance%process evt%process_instance => process_instance evt%model => model call evt%process%make_rng (evt%rng) end subroutine evt_connect @ %def evt_connect @ Reset internal state. <>= procedure :: reset => evt_reset procedure :: base_reset => evt_reset <>= subroutine evt_reset (evt) class(evt_t), intent(inout) :: evt evt%rejection_count = 0 call evt%particle_set%final () evt%particle_set_exists = .false. end subroutine evt_reset @ %def evt_reset @ Prepare for a new event: reset internal state, if necessary. We provide MCI and term index of the parent process. <>= procedure (evt_prepare_new_event), deferred :: prepare_new_event <>= interface subroutine evt_prepare_new_event (evt, i_mci, i_term) import class(evt_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term end subroutine evt_prepare_new_event end interface @ %def evt_prepare_new_event @ Generate a weighted event, using a valid initiator event in the process instance, and the random-number generator. The returned event probability should be a number between zero and one that we can use for rejection. <>= procedure (evt_generate_weighted), deferred :: generate_weighted <>= abstract interface subroutine evt_generate_weighted (evt, probability) import class(evt_t), intent(inout) :: evt real(default), intent(inout) :: probability end subroutine evt_generate_weighted end interface @ %def evt_generate_weighted @ The unweighted event generation routine is actually implemented. It uses the random-number generator for simple rejection. Of course, the implementation may override this and implement a different way of generating an unweighted event. <>= procedure :: generate_unweighted => evt_generate_unweighted procedure :: base_generate_unweighted => evt_generate_unweighted <>= subroutine evt_generate_unweighted (evt) class(evt_t), intent(inout) :: evt real(default) :: p, x evt%rejection_count = 0 REJECTION: do evt%rejection_count = evt%rejection_count + 1 call evt%generate_weighted (p) if (signal_is_pending ()) return call evt%rng%generate (x) if (x < p) exit REJECTION end do REJECTION end subroutine evt_generate_unweighted @ %def evt_generate_unweighted @ Make a particle set. This should take the most recent evaluator (or whatever stores the event), factorize the density matrix if necessary, and store as a particle set. If applicable, the factorization should make use of the [[factorization_mode]] and [[keep_correlations]] settings. The values [[r]], if set, should control the factorization in more detail, e.g., bypassing the random-number generator. <>= procedure (evt_make_particle_set), deferred :: make_particle_set <>= interface subroutine evt_make_particle_set & (evt, factorization_mode, keep_correlations, r) import class(evt_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r end subroutine evt_make_particle_set end interface @ %def evt_make_particle_set @ Copy an existing particle set into the event record. This bypasses all methods to evaluate the internal state, but may be sufficient for further processing. <>= procedure :: set_particle_set => evt_set_particle_set <>= subroutine evt_set_particle_set (evt, particle_set, i_mci, i_term) class(evt_t), intent(inout) :: evt type(particle_set_t), intent(in) :: particle_set integer, intent(in) :: i_term, i_mci call evt%prepare_new_event (i_mci, i_term) evt%particle_set = particle_set evt%particle_set_exists = .true. end subroutine evt_set_particle_set @ %def evt_set_particle_set @ This procedure can help in the previous task, if the particles are available in the form of an interaction object. (We need two interactions, one with color summed over, and one with the probability distributed among flows.) We use the two values from the random number generator for factorizing the state. For testing purposes, we can provide those numbers explicitly. <>= procedure :: factorize_interactions => evt_factorize_interactions <>= subroutine evt_factorize_interactions & (evt, int_matrix, int_flows, factorization_mode, & keep_correlations, r, qn_select) class(evt_t), intent(inout) :: evt type(interaction_t), intent(in), target :: int_matrix, int_flows integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_select real(default), dimension(2) :: x if (present (r)) then if (size (r) == 2) then x = r else call msg_bug ("event factorization: size of r array must be 2") end if else call evt%rng%generate (x) end if call evt%particle_set%init (evt%particle_set_exists, & int_matrix, int_flows, factorization_mode, x, & keep_correlations, keep_virtual=.true., qn_select = qn_select) evt%particle_set_exists = .true. end subroutine evt_factorize_interactions @ %def evt_factorize_interactions @ <>= public :: make_factorized_particle_set <>= subroutine make_factorized_particle_set (evt, factorization_mode, & keep_correlations, r, ii_term, qn_select) class(evt_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r integer, intent(in), optional :: ii_term type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_select integer :: i_term type(interaction_t), pointer :: int_matrix, int_flows if (evt%process_instance%is_complete_event ()) then if (present (ii_term)) then i_term = ii_term else i_term = evt%process_instance%select_i_term () end if int_matrix => evt%process_instance%get_matrix_int_ptr (i_term) int_flows => evt%process_instance%get_flows_int_ptr (i_term) call evt%factorize_interactions (int_matrix, int_flows, & factorization_mode, keep_correlations, r, qn_select) call evt%tag_incoming () else call msg_bug ("Event factorization: event is incomplete") end if end subroutine make_factorized_particle_set @ %def make_factorized_particle_set @ Mark the incoming particles as incoming in the particle set. This is necessary because in the interaction objects they are usually marked as virtual. In the inquiry functions we set the term index to one; the indices of beams and incoming particles should be identical for all process terms. We use the initial elementary process for obtaining the indices. Thus, we implicitly assume that the beam and incoming indices stay the same across event transforms. If this is not true for a transform (say, MPI), it should override this method. <>= procedure :: tag_incoming => evt_tag_incoming <>= subroutine evt_tag_incoming (evt) class(evt_t), intent(inout) :: evt integer :: i_term, n_in integer, dimension(:), allocatable :: beam_index, in_index n_in = evt%process%get_n_in () i_term = 1 allocate (beam_index (n_in)) call evt%process_instance%get_beam_index (i_term, beam_index) call evt%particle_set%reset_status (beam_index, PRT_BEAM) allocate (in_index (n_in)) call evt%process_instance%get_in_index (i_term, in_index) call evt%particle_set%reset_status (in_index, PRT_INCOMING) end subroutine evt_tag_incoming @ %def evt_tag_incoming @ \subsection{Implementation: Trivial transform} This transform contains just a pointer to process and process instance. The [[generate]] methods do nothing. <>= public :: evt_trivial_t <>= type, extends (evt_t) :: evt_trivial_t contains <> end type evt_trivial_t @ %def evt_trivial_t @ <>= procedure :: write_name => evt_trivial_write_name <>= subroutine evt_trivial_write_name (evt, unit) class(evt_trivial_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: trivial (hard process)" end subroutine evt_trivial_write_name @ %def evt_trivial_write_name @ The finalizer is trivial. Some output: <>= procedure :: write => evt_trivial_write <>= subroutine evt_trivial_write (evt, unit, verbose, more_verbose, testflag) class(evt_trivial_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u) call evt%base_write (u, testflag = testflag) end subroutine evt_trivial_write @ %def evt_trivial_write @ Nothing to do here: <>= procedure :: prepare_new_event => evt_trivial_prepare_new_event <>= subroutine evt_trivial_prepare_new_event (evt, i_mci, i_term) class(evt_trivial_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () end subroutine evt_trivial_prepare_new_event @ %def evt_trivial_prepare_new_event @ The weighted generator is, surprisingly, trivial. <>= procedure :: generate_weighted => evt_trivial_generate_weighted <>= subroutine evt_trivial_generate_weighted (evt, probability) class(evt_trivial_t), intent(inout) :: evt real(default), intent(inout) :: probability probability = 1 end subroutine evt_trivial_generate_weighted @ %def evt_trivial_generate_weighted @ This routine makes a particle set, using the associated process instance as-is. <>= procedure :: make_particle_set => evt_trivial_make_particle_set <>= subroutine evt_trivial_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_trivial_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r call make_factorized_particle_set (evt, factorization_mode, & keep_correlations, r) evt%particle_set_exists = .true. end subroutine evt_trivial_make_particle_set @ %def event_trivial_make_particle_set @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[event_transforms_ut.f90]]>>= <> module event_transforms_ut use unit_tests use event_transforms_uti <> <> contains <> end module event_transforms_ut @ %def event_transforms_ut @ <<[[event_transforms_uti.f90]]>>= <> module event_transforms_uti <> <> use format_utils, only: write_separator use os_interface use sm_qcd use models use state_matrices, only: FM_IGNORE_HELICITY use interactions, only: reset_interaction_counter use process_libraries use rng_base use mci_base use mci_midpoint use phs_base use phs_single use prc_core use prc_test, only: prc_test_create_library use process, only: process_t use instances, only: process_instance_t use event_transforms use rng_base_ut, only: rng_test_factory_t <> <> contains <> <> end module event_transforms_uti @ %def event_transforms_uti @ API: driver for the unit tests below. <>= public :: event_transforms_test <>= subroutine event_transforms_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine event_transforms_test @ %def event_transforms_test @ \subsubsection{Test trivial event transform} The trivial transform, as an instance of the abstract transform, does nothing but to trigger event generation for an elementary process. <>= call test (event_transforms_1, "event_transforms_1", & "trivial event transform", & u, results) <>= public :: event_transforms_1 <>= subroutine event_transforms_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_t), target :: model type(process_library_t), target :: lib type(string_t) :: libname, procname1 class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance class(evt_t), allocatable :: evt integer :: factorization_mode logical :: keep_correlations write (u, "(A)") "* Test output: event_transforms_1" write (u, "(A)") "* Purpose: handle trivial transform" write (u, "(A)") write (u, "(A)") "* Initialize environment and parent process" write (u, "(A)") call os_data%init () libname = "event_transforms_1_lib" procname1 = "event_transforms_1_p" call prc_test_create_library (libname, lib, & scattering = .true., procname1 = procname1) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname1, lib, os_data, model) call process%setup_test_cores () allocate (phs_single_config_t :: phs_config_template) call process%init_components (phs_config_template) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test_midpoint) call process%setup_terms () allocate (process_instance) call process_instance%init (process) call process_instance%integrate (1, n_it=1, n_calls=100) call process%final_integration (1) call process_instance%final () deallocate (process_instance) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () call process_instance%init_simulation (1) write (u, "(A)") "* Initialize trivial event transform" write (u, "(A)") allocate (evt_trivial_t :: evt) call evt%connect (process_instance, process%get_model_ptr ()) write (u, "(A)") "* Generate event and subsequent transform" write (u, "(A)") call process_instance%generate_unweighted_event (1) call process_instance%evaluate_event_data () call evt%prepare_new_event (1, 1) call evt%generate_unweighted () call write_separator (u, 2) call evt%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Obtain particle set" write (u, "(A)") factorization_mode = FM_IGNORE_HELICITY keep_correlations = .false. call evt%make_particle_set (factorization_mode, keep_correlations) call write_separator (u, 2) call evt%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Cleanup" call evt%final () call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Test output end: event_transforms_1" end subroutine event_transforms_1 @ %def event_transforms_1 @ MCI record prepared for midpoint integrator. <>= subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo) use variables, only: var_list_t class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_midpoint_t :: mci) end subroutine dispatch_mci_test_midpoint @ %def dispatch_mci_test_midpoint @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Hadronization interface} <<[[hadrons.f90]]>>= <> module hadrons <> <> use constants use diagnostics use event_transforms use format_utils, only: write_separator use helicities use hep_common use io_units use lorentz use model_data use models use numeric_utils, only: vanishes use particles use physics_defs use process, only: process_t use instances, only: process_instance_t use process_stacks use pythia8 use rng_base, only: rng_t use shower_base use shower_pythia6 use sm_qcd use subevents use variables use whizard_lha <> <> <> <> <> contains <> end module hadrons @ %def hadrons @ \subsection{Hadronization implementations} <>= public :: HADRONS_UNDEFINED, HADRONS_WHIZARD, HADRONS_PYTHIA6, HADRONS_PYTHIA8 <>= integer, parameter :: HADRONS_UNDEFINED = 0 integer, parameter :: HADRONS_WHIZARD = 1 integer, parameter :: HADRONS_PYTHIA6 = 2 integer, parameter :: HADRONS_PYTHIA8 = 3 @ %def HADRONS_UNDEFINED HADRONS_WHIZARD HADRONS_PYTHIA6 HADRONS_PYTHIA8 @ A dictionary <>= public :: hadrons_method <>= interface hadrons_method module procedure hadrons_method_of_string module procedure hadrons_method_to_string end interface <>= elemental function hadrons_method_of_string (string) result (i) integer :: i type(string_t), intent(in) :: string select case (char(string)) case ("WHIZARD") i = HADRONS_WHIZARD case ("PYTHIA6") i = HADRONS_PYTHIA6 case ("PYTHIA8") i = HADRONS_PYTHIA8 case default i = HADRONS_UNDEFINED end select end function hadrons_method_of_string elemental function hadrons_method_to_string (i) result (string) type(string_t) :: string integer, intent(in) :: i select case (i) case (HADRONS_WHIZARD) string = "WHIZARD" case (HADRONS_PYTHIA6) string = "PYTHIA6" case (HADRONS_PYTHIA8) string = "PYTHIA8" case default string = "UNDEFINED" end select end function hadrons_method_to_string @ %def hadrons_method @ \subsection{Hadronization settings} These are the general settings and parameters for the different shower methods. <>= public :: hadron_settings_t <>= type :: hadron_settings_t logical :: active = .false. integer :: method = HADRONS_UNDEFINED real(default) :: enhanced_fraction = 0 real(default) :: enhanced_width = 0 contains <> end type hadron_settings_t @ %def hadron_settings_t @ Read in the hadronization settings. <>= procedure :: init => hadron_settings_init <>= subroutine hadron_settings_init (hadron_settings, var_list) class(hadron_settings_t), intent(out) :: hadron_settings type(var_list_t), intent(in) :: var_list hadron_settings%active = & var_list%get_lval (var_str ("?hadronization_active")) hadron_settings%method = hadrons_method_of_string ( & var_list%get_sval (var_str ("$hadronization_method"))) hadron_settings%enhanced_fraction = & var_list%get_rval (var_str ("hadron_enhanced_fraction")) hadron_settings%enhanced_width = & var_list%get_rval (var_str ("hadron_enhanced_width")) end subroutine hadron_settings_init @ %def hadron_settings_init @ <>= procedure :: write => hadron_settings_write <>= subroutine hadron_settings_write (settings, unit) class(hadron_settings_t), intent(in) :: settings integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Hadronization settings:" call write_separator (u) write (u, "(1x,A)") "Master switches:" write (u, "(3x,A,1x,L1)") & "active = ", settings%active write (u, "(1x,A)") "General settings:" if (settings%active) then write (u, "(3x,A)") & "hadron_method = " // & char (hadrons_method_to_string (settings%method)) else write (u, "(3x,A)") " [Hadronization off]" end if write (u, "(1x,A)") "pT generation parameters" write (u, "(3x,A,1x,ES19.12)") & "enhanced_fraction = ", settings%enhanced_fraction write (u, "(3x,A,1x,ES19.12)") & "enhanced_width = ", settings%enhanced_width end subroutine hadron_settings_write @ %def hadron_settings_write @ \subsection{Abstract Hadronization Type} The [[model]] is the fallback model including all hadrons <>= type, abstract :: hadrons_t class(rng_t), allocatable :: rng type(shower_settings_t) :: shower_settings type(hadron_settings_t) :: hadron_settings type(model_t), pointer :: model => null() contains <> end type hadrons_t @ %def hadrons_t @ <>= procedure (hadrons_init), deferred :: init <>= abstract interface subroutine hadrons_init & (hadrons, shower_settings, hadron_settings, model_hadrons) import class(hadrons_t), intent(out) :: hadrons type(shower_settings_t), intent(in) :: shower_settings type(hadron_settings_t), intent(in) :: hadron_settings type(model_t), target, intent(in) :: model_hadrons end subroutine hadrons_init end interface @ %def hadrons_init @ <>= procedure (hadrons_hadronize), deferred :: hadronize <>= abstract interface subroutine hadrons_hadronize (hadrons, particle_set, valid) import class(hadrons_t), intent(inout) :: hadrons type(particle_set_t), intent(in) :: particle_set logical, intent(out) :: valid end subroutine hadrons_hadronize end interface @ %def hadrons_hadronize @ <>= procedure (hadrons_make_particle_set), deferred :: make_particle_set <>= abstract interface subroutine hadrons_make_particle_set (hadrons, particle_set, & model, valid) import class(hadrons_t), intent(in) :: hadrons type(particle_set_t), intent(inout) :: particle_set class(model_data_t), intent(in), target :: model logical, intent(out) :: valid end subroutine hadrons_make_particle_set end interface @ %def hadrons_make_particle_set @ <>= procedure :: import_rng => hadrons_import_rng <>= pure subroutine hadrons_import_rng (hadrons, rng) class(hadrons_t), intent(inout) :: hadrons class(rng_t), intent(inout), allocatable :: rng call move_alloc (from = rng, to = hadrons%rng) end subroutine hadrons_import_rng @ %def hadrons_import_rng @ \subsection{[[WHIZARD]] Hadronization Type} Hadronization can be (incompletely) performed through \whizard's internal routine. <>= public :: hadrons_hadrons_t <>= type, extends (hadrons_t) :: hadrons_hadrons_t contains <> end type hadrons_hadrons_t @ %def hadrons_hadrons_t @ <>= procedure :: init => hadrons_hadrons_init <>= subroutine hadrons_hadrons_init & (hadrons, shower_settings, hadron_settings, model_hadrons) class(hadrons_hadrons_t), intent(out) :: hadrons type(shower_settings_t), intent(in) :: shower_settings type(hadron_settings_t), intent(in) :: hadron_settings type(model_t), intent(in), target :: model_hadrons hadrons%model => model_hadrons hadrons%shower_settings = shower_settings hadrons%hadron_settings = hadron_settings call msg_message & ("Hadronization: WHIZARD model for hadronization and decays") end subroutine hadrons_hadrons_init @ %def hadrons_hadrons_init @ <>= procedure :: hadronize => hadrons_hadrons_hadronize <>= subroutine hadrons_hadrons_hadronize (hadrons, particle_set, valid) class(hadrons_hadrons_t), intent(inout) :: hadrons type(particle_set_t), intent(in) :: particle_set logical, intent(out) :: valid integer, dimension(:), allocatable :: cols, acols, octs integer :: n if (signal_is_pending ()) return call msg_debug (D_TRANSFORMS, "hadrons_hadrons_hadronize") call particle_set%write (6, compressed=.true.) n = particle_set%get_n_tot () allocate (cols (n), acols (n), octs (n)) call extract_color_systems (particle_set, cols, acols, octs) print *, "size(cols) = ", size (cols) if (size(cols) > 0) then print *, "cols = ", cols end if print *, "size(acols) = ", size(acols) if (size(acols) > 0) then print *, "acols = ", acols end if print *, "size(octs) = ", size(octs) if (size (octs) > 0) then print *, "octs = ", octs end if !!! if all arrays are empty, i.e. zero particles found, nothing to do end subroutine hadrons_hadrons_hadronize @ %def hadrons_hadrons_hadronize @ This type contains a flavor selector for the creation of hadrons, including parameters for the special handling of baryons. <>= public :: had_flav_t <>= type had_flav_t end type had_flav_t @ %def had_flav_t @ This is the type for the ends of Lund strings. <>= public :: lund_end <>= type lund_end logical :: from_pos integer :: i_end integer :: i_max integer :: id_had integer :: i_pos_old integer :: i_neg_old integer :: i_pos_new integer :: i_neg_new real(default) :: px_old real(default) :: py_old real(default) :: px_new real(default) :: py_new real(default) :: px_had real(default) :: py_had real(default) :: m_had real(default) :: mT2_had real(default) :: z_had real(default) :: gamma_old real(default) :: gamma_new real(default) :: x_pos_old real(default) :: x_pos_new real(default) :: x_pos_had real(default) :: x_neg_old real(default) :: x_neg_new real(default) :: x_neg_had type(had_flav_t) :: old_flav type(had_flav_t) :: new_flav type(vector4_t) :: p_had type(vector4_t) :: p_pre end type lund_end @ %def lund_end @ Generator for transverse momentum for the fragmentation. <>= public :: lund_pt_t <>= type lund_pt_t real(default) :: sigma_min real(default) :: sigma_q real(default) :: enhanced_frac real(default) :: enhanced_width real(default) :: sigma_to_had class(rng_t), allocatable :: rng contains <> end type lund_pt_t @ %def lund_pt <>= procedure :: init => lund_pt_init <>= subroutine lund_pt_init (lund_pt, settings) class (lund_pt_t), intent(out) :: lund_pt type(hadron_settings_t), intent(in) :: settings end subroutine lund_pt_init @ %def lund_pt_init @ <>= procedure :: make_particle_set => hadrons_hadrons_make_particle_set <>= subroutine hadrons_hadrons_make_particle_set & (hadrons, particle_set, model, valid) class(hadrons_hadrons_t), intent(in) :: hadrons type(particle_set_t), intent(inout) :: particle_set class(model_data_t), intent(in), target :: model logical, intent(out) :: valid if (signal_is_pending ()) return valid = .false. if (valid) then else call msg_fatal ("WHIZARD hadronization not yet implemented") end if end subroutine hadrons_hadrons_make_particle_set @ %def hadrons_hadrons_make_particle_set @ <>= subroutine extract_color_systems (p_set, cols, acols, octs) type(particle_set_t), intent(in) :: p_set integer, dimension(:), allocatable, intent(out) :: cols, acols, octs logical, dimension(:), allocatable :: mask integer :: i, n, n_cols, n_acols, n_octs n = p_set%get_n_tot () allocate (mask (n)) do i = 1, n mask(i) = p_set%prt(i)%col%get_col () /= 0 .and. & p_set%prt(i)%col%get_acl () == 0 .and. & p_set%prt(i)%get_status () == PRT_OUTGOING end do n_cols = count (mask) allocate (cols (n_cols)) cols = p_set%get_indices (mask) do i = 1, n mask(i) = p_set%prt(i)%col%get_col () == 0 .and. & p_set%prt(i)%col%get_acl () /= 0 .and. & p_set%prt(i)%get_status () == PRT_OUTGOING end do n_acols = count (mask) allocate (acols (n_acols)) acols = p_set%get_indices (mask) do i = 1, n mask(i) = p_set%prt(i)%col%get_col () /= 0 .and. & p_set%prt(i)%col%get_acl () /= 0 .and. & p_set%prt(i)%get_status () == PRT_OUTGOING end do n_octs = count (mask) allocate (octs (n_octs)) octs = p_set%get_indices (mask) end subroutine extract_color_systems @ %def extract_color_systems @ \subsection{[[PYTHIA6]] Hadronization Type} Hadronization via [[PYTHIA6]] is at another option for hadronization within \whizard. <>= public :: hadrons_pythia6_t <>= type, extends (hadrons_t) :: hadrons_pythia6_t contains <> end type hadrons_pythia6_t @ %def hadrons_pythia6_t <>= procedure :: init => hadrons_pythia6_init <>= subroutine hadrons_pythia6_init & (hadrons, shower_settings, hadron_settings, model_hadrons) class(hadrons_pythia6_t), intent(out) :: hadrons type(shower_settings_t), intent(in) :: shower_settings type(hadron_settings_t), intent(in) :: hadron_settings type(model_t), intent(in), target :: model_hadrons logical :: pygive_not_set_by_shower hadrons%model => model_hadrons hadrons%shower_settings = shower_settings hadrons%hadron_settings = hadron_settings pygive_not_set_by_shower = .not. (shower_settings%method == PS_PYTHIA6 & .and. (shower_settings%isr_active .or. shower_settings%fsr_active)) if (pygive_not_set_by_shower) then call pythia6_set_verbose (shower_settings%verbose) call pythia6_set_config (shower_settings%pythia6_pygive) end if call msg_message & ("Hadronization: Using PYTHIA6 interface for hadronization and decays") end subroutine hadrons_pythia6_init @ %def hadrons_pythia6_init @ Assume that the event record is still in the PYTHIA COMMON BLOCKS transferred there by the WHIZARD or PYTHIA6 shower routines. <>= procedure :: hadronize => hadrons_pythia6_hadronize <>= subroutine hadrons_pythia6_hadronize (hadrons, particle_set, valid) class(hadrons_pythia6_t), intent(inout) :: hadrons type(particle_set_t), intent(in) :: particle_set logical, intent(out) :: valid integer :: N, NPAD, K real(double) :: P, V common /PYJETS/ N, NPAD, K(4000,5), P(4000,5), V(4000,5) save /PYJETS/ if (signal_is_pending ()) return call msg_debug (D_TRANSFORMS, "hadrons_pythia6_hadronize") call pygive ("MSTP(111)=1") !!! Switch on hadronization and decays call pygive ("MSTJ(1)=1") !!! String fragmentation call pygive ("MSTJ(21)=2") !!! String fragmentation keeping resonance momentum call pygive ("MSTJ(28)=0") !!! Switch off tau decays if (debug_active (D_TRANSFORMS)) then call msg_debug (D_TRANSFORMS, "N", N) call pylist(2) print *, ' line 7 : ', k(7,1:5), p(7,1:5) end if call pyedit (12) call pythia6_set_last_treated_line (N) call pyexec () call pyedit (12) valid = .true. end subroutine hadrons_pythia6_hadronize @ %def hadrons_pythia6_hadronize @ <>= procedure :: make_particle_set => hadrons_pythia6_make_particle_set <>= subroutine hadrons_pythia6_make_particle_set & (hadrons, particle_set, model, valid) class(hadrons_pythia6_t), intent(in) :: hadrons type(particle_set_t), intent(inout) :: particle_set class(model_data_t), intent(in), target :: model logical, intent(out) :: valid if (signal_is_pending ()) return valid = pythia6_handle_errors () if (valid) then call pythia6_combine_with_particle_set & (particle_set, model, hadrons%model, hadrons%shower_settings) end if end subroutine hadrons_pythia6_make_particle_set @ %def hadrons_pythia6_make_particle_set @ \subsection{[[PYTHIA8]] Hadronization} @ <>= public :: hadrons_pythia8_t <>= type, extends (hadrons_t) :: hadrons_pythia8_t type(pythia8_t) :: pythia type(whizard_lha_t) :: lhaup logical :: user_process_set = .false. logical :: pythia_initialized = .false., & lhaup_initialized = .false. contains <> end type hadrons_pythia8_t @ %def hadrons_pythia8_t @ <>= procedure :: init => hadrons_pythia8_init <>= subroutine hadrons_pythia8_init & (hadrons, shower_settings, hadron_settings, model_hadrons) class(hadrons_pythia8_t), intent(out) :: hadrons type(shower_settings_t), intent(in) :: shower_settings type(hadron_settings_t), intent(in) :: hadron_settings type(model_t), intent(in), target :: model_hadrons hadrons%model => model_hadrons hadrons%shower_settings = shower_settings hadrons%hadron_settings = hadron_settings call msg_message & ("Hadronization: Using PYTHIA8 interface for hadronization and decays.") ! TODO sbrass which verbose? call hadrons%pythia%init (verbose = shower_settings%verbose) call hadrons%lhaup%init () end subroutine hadrons_pythia8_init @ %def hadrons_pythia8_init @ Transfer hadron settings to [[PYTHIA8]]. <>= procedure, private :: transfer_settings => hadrons_pythia8_transfer_settings <>= subroutine hadrons_pythia8_transfer_settings (hadrons) class(hadrons_pythia8_t), intent(inout), target :: hadrons real(default) :: r call msg_debug (D_TRANSFORMS, "hadrons_pythia8_transfer_settings") call msg_debug2 (D_TRANSFORMS, "pythia_initialized", hadrons%pythia_initialized) if (hadrons%pythia_initialized) return call hadrons%pythia%import_rng (hadrons%rng) call hadrons%pythia%parse_and_set_config (hadrons%shower_settings%pythia8_config) if (len (hadrons%shower_settings%pythia8_config_file) > 0) & call hadrons%pythia%read_file (hadrons%shower_settings%pythia8_config_file) call hadrons%pythia%read_string (var_str ("Beams:frameType = 5")) call hadrons%pythia%read_string (var_str ("ProcessLevel:all = off")) if (.not. hadrons%shower_settings%verbose) then call hadrons%pythia%read_string (var_str ("Print:quiet = on")) end if call hadrons%pythia%set_lhaup_ptr (hadrons%lhaup) call hadrons%pythia%init_pythia () hadrons%pythia_initialized = .true. end subroutine hadrons_pythia8_transfer_settings @ %def hadrons_pythia8_transfer_settings @ Set user process for the LHA interface. <>= procedure, private :: set_user_process => hadrons_pythia8_set_user_process <>= subroutine hadrons_pythia8_set_user_process (hadrons, pset) class(hadrons_pythia8_t), intent(inout) :: hadrons type(particle_set_t), intent(in) :: pset integer, dimension(2) :: beam_pdg real(default), dimension(2) :: beam_energy integer, parameter :: process_id = 0, n_processes = 0 call msg_debug (D_TRANSFORMS, "hadrons_pythia8_set_user_process") beam_pdg = [pset%prt(1)%get_pdg (), pset%prt(2)%get_pdg ()] beam_energy = [energy(pset%prt(1)%p), energy(pset%prt(2)%p)] call hadrons%lhaup%set_init (beam_pdg, beam_energy, & n_processes, unweighted = .false., negative_weights = .false.) call hadrons%lhaup%set_process_parameters (process_id = process_id, & cross_section = one, error = one) end subroutine hadrons_pythia8_set_user_process @ %def hadrons_pythia8_set_user_process @ Import particle set. <>= procedure, private :: import_particle_set => hadrons_pythia8_import_particle_set <>= subroutine hadrons_pythia8_import_particle_set (hadrons, particle_set) class(hadrons_pythia8_t), target, intent(inout) :: hadrons type(particle_set_t), intent(in) :: particle_set type(particle_set_t) :: pset_reduced integer, parameter :: PROCESS_ID = 1 call msg_debug (D_TRANSFORMS, "hadrons_pythia8_import_particle_set") if (.not. hadrons%user_process_set) then call hadrons%set_user_process (particle_set) hadrons%user_process_set = .true. end if call hadrons%lhaup%set_event_process (process_id = PROCESS_ID, scale = -one, & alpha_qcd = -one, alpha_qed = -one, weight = -one) call hadrons%lhaup%set_event (process_id = PROCESS_ID, particle_set = particle_set, & polarization = .true.) if (debug_active (D_TRANSFORMS)) then call hadrons%lhaup%list_init () end if end subroutine hadrons_pythia8_import_particle_set @ %def hadrons_pythia8_import_particle_set @ <>= procedure :: hadronize => hadrons_pythia8_hadronize <>= subroutine hadrons_pythia8_hadronize (hadrons, particle_set, valid) class(hadrons_pythia8_t), intent(inout) :: hadrons type(particle_set_t), intent(in) :: particle_set logical, intent(out) :: valid if (signal_is_pending ()) return call hadrons%import_particle_set (particle_set) if (.not. hadrons%pythia_initialized) & call hadrons%transfer_settings () call hadrons%pythia%next (valid) if (debug_active (D_TRANSFORMS)) then call hadrons%pythia%list_event () call particle_set%write (summary=.true., compressed=.true.) end if end subroutine hadrons_pythia8_hadronize @ %def hadrons_pythia8_hadronize @ <>= procedure :: make_particle_set => hadrons_pythia8_make_particle_set <>= subroutine hadrons_pythia8_make_particle_set & (hadrons, particle_set, model, valid) class(hadrons_pythia8_t), intent(in) :: hadrons type(particle_set_t), intent(inout) :: particle_set class(model_data_t), intent(in), target :: model logical, intent(out) :: valid type(particle_t), dimension(:), allocatable :: beam call msg_debug (D_TRANSFORMS, "hadrons_pythia8_make_particle_set") if (signal_is_pending ()) return associate (settings => hadrons%shower_settings) if (debug_active (D_TRANSFORMS)) then call msg_debug (D_TRANSFORMS, 'Combine PYTHIA8 with particle set') call msg_debug (D_TRANSFORMS, 'Particle set before replacing') call particle_set%write (summary=.true., compressed=.true.) call hadrons%pythia%list_event () call msg_debug (D_TRANSFORMS, string = "settings%hadron_collision", & value = settings%hadron_collision) end if call hadrons%pythia%get_hadron_particles (& model, hadrons%model, particle_set, & helicity = PRT_DEFINITE_HELICITY) end associate if (debug_active (D_TRANSFORMS)) then print *, 'Particle set after replacing' call particle_set%write (summary=.true., compressed=.true.) end if valid = .true. end subroutine hadrons_pythia8_make_particle_set @ %def hadrons_pythia8_make_particle_set @ \subsection{Hadronization Event Transform} This is the type for the hadronization event transform. It does not depend on the specific hadronization implementation of [[hadrons_t]]. <>= public :: evt_hadrons_t <>= type, extends (evt_t) :: evt_hadrons_t class(hadrons_t), allocatable :: hadrons type(model_t), pointer :: model_hadrons => null() type(qcd_t) :: qcd logical :: is_first_event contains <> end type evt_hadrons_t @ %def evt_hadrons_t @ Initialize the parameters. The [[model_hadrons]] is supposed to be the SM variant that contains all hadrons that may be generated in the shower. <>= procedure :: init => evt_hadrons_init <>= subroutine evt_hadrons_init (evt, model_hadrons) class(evt_hadrons_t), intent(out) :: evt type(model_t), intent(in), target :: model_hadrons evt%model_hadrons => model_hadrons evt%is_first_event = .true. end subroutine evt_hadrons_init @ %def evt_hadrons_init @ <>= procedure :: write_name => evt_hadrons_write_name <>= subroutine evt_hadrons_write_name (evt, unit) class(evt_hadrons_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: hadronization" end subroutine evt_hadrons_write_name @ %def evt_hadrons_write_name @ Output. <>= procedure :: write => evt_hadrons_write <>= subroutine evt_hadrons_write (evt, unit, verbose, more_verbose, testflag) class(evt_hadrons_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u) call evt%base_write (u, testflag = testflag, show_set = .false.) if (evt%particle_set_exists) & call evt%particle_set%write & (u, summary = .true., compressed = .true., testflag = testflag) call write_separator (u) call evt%hadrons%shower_settings%write (u) call write_separator (u) call evt%hadrons%hadron_settings%write (u) end subroutine evt_hadrons_write @ %def evt_hadrons_write @ <>= procedure :: first_event => evt_hadrons_first_event <>= subroutine evt_hadrons_first_event (evt) class(evt_hadrons_t), intent(inout) :: evt call msg_debug (D_TRANSFORMS, "evt_hadrons_first_event") associate (settings => evt%hadrons%shower_settings) settings%hadron_collision = .false. !!! !!! !!! Workaround for PGF90 16.1 !!! if (all (evt%particle_set%prt(1:2)%flv%get_pdg_abs () <= 39)) then if (evt%particle_set%prt(1)%flv%get_pdg_abs () <= 39 .and. & evt%particle_set%prt(2)%flv%get_pdg_abs () <= 39) then settings%hadron_collision = .false. !!! else if (all (evt%particle_set%prt(1:2)%flv%get_pdg_abs () >= 100)) then else if (evt%particle_set%prt(1)%flv%get_pdg_abs () >= 100 .and. & evt%particle_set%prt(2)%flv%get_pdg_abs () >= 100) then settings%hadron_collision = .true. else call msg_fatal ("evt_hadrons didn't recognize beams setup") end if call msg_debug (D_TRANSFORMS, "hadron_collision", settings%hadron_collision) if (.not. (settings%isr_active .or. settings%fsr_active)) then call msg_fatal ("Hadronization without shower is not supported") end if end associate evt%is_first_event = .false. end subroutine evt_hadrons_first_event @ %def evt_hadrons_first_event @ Here we take the particle set from the previous event transform and apply the hadronization. The result is stored in the [[evt%hadrons]] object. We always return a probability of unity as we don't have the analytic weight of the hadronization. Invalid events have to be discarded by the caller which is why we mark the particle set as invalid. <>= procedure :: generate_weighted => evt_hadrons_generate_weighted <>= subroutine evt_hadrons_generate_weighted (evt, probability) class(evt_hadrons_t), intent(inout) :: evt real(default), intent(inout) :: probability logical :: valid if (signal_is_pending ()) return evt%particle_set = evt%previous%particle_set if (evt%is_first_event) then call evt%first_event () end if call evt%hadrons%hadronize (evt%particle_set, valid) probability = 1 evt%particle_set_exists = valid end subroutine evt_hadrons_generate_weighted @ %def evt_hadrons_generate_weighted @ The factorization parameters are irrelevant. <>= procedure :: make_particle_set => evt_hadrons_make_particle_set <>= subroutine evt_hadrons_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_hadrons_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r logical :: valid call evt%hadrons%make_particle_set (evt%particle_set, evt%model, valid) evt%particle_set_exists = evt%particle_set_exists .and. valid end subroutine evt_hadrons_make_particle_set @ %def event_hadrons_make_particle_set @ Connect the process with the hadrons object. <>= procedure :: connect => evt_hadrons_connect <>= subroutine evt_hadrons_connect & (evt, process_instance, model, process_stack) class(evt_hadrons_t), intent(inout), target :: evt type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack call evt%base_connect (process_instance, model, process_stack) call evt%make_rng (evt%process) end subroutine evt_hadrons_connect @ %def evt_hadrons_connect @ Create RNG instances, spawned by the process object. <>= procedure :: make_rng => evt_hadrons_make_rng <>= subroutine evt_hadrons_make_rng (evt, process) class(evt_hadrons_t), intent(inout) :: evt type(process_t), intent(inout) :: process class(rng_t), allocatable :: rng call process%make_rng (rng) call evt%hadrons%import_rng (rng) end subroutine evt_hadrons_make_rng @ %def evt_hadrons_make_rng @ <>= procedure :: prepare_new_event => evt_hadrons_prepare_new_event <>= subroutine evt_hadrons_prepare_new_event (evt, i_mci, i_term) class(evt_hadrons_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () end subroutine evt_hadrons_prepare_new_event @ %def evt_hadrons_prepare_new_event @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Resonance Insertion} <<[[resonance_insertion.f90]]>>= <> module resonance_insertion <> <> use io_units use format_utils, only: write_separator use format_defs, only: FMT_12 use rng_base, only: rng_t use selectors, only: selector_t use sm_qcd use model_data use interactions, only: interaction_t use particles, only: particle_t, particle_set_t use subevents, only: PRT_RESONANT use models use resonances, only: resonance_history_set_t use resonances, only: resonance_tree_t use instances, only: process_instance_ptr_t use event_transforms <> <> <> contains <> end module resonance_insertion @ %def resonance_insertion @ \subsection{Resonance-Insertion Event Transform} This is the type for the event transform that applies resonance insertion. The resonance history set describe the resonance histories that we may consider. There is a process library with process objects that correspond to the resonance histories. Library creation, compilation etc.\ is done outside the scope of this module. <>= public :: evt_resonance_t <>= type, extends (evt_t) :: evt_resonance_t type(resonance_history_set_t), dimension(:), allocatable :: res_history_set integer, dimension(:), allocatable :: index_offset integer :: selected_component = 0 type(string_t) :: libname type(string_t), dimension(:), allocatable :: proc_id real(default) :: on_shell_limit = 0 real(default) :: on_shell_turnoff = 0 real(default) :: background_factor = 1 logical :: selector_active = .false. type(selector_t) :: selector integer :: selected_history = 0 type(process_instance_ptr_t), dimension(:), allocatable :: instance contains <> end type evt_resonance_t @ %def evt_resonance_t <>= procedure :: write_name => evt_resonance_write_name <>= subroutine evt_resonance_write_name (evt, unit) class(evt_resonance_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: resonance insertion" end subroutine evt_resonance_write_name @ %def evt_resonance_write_name @ Output. <>= procedure :: write => evt_resonance_write <>= subroutine evt_resonance_write (evt, unit, verbose, more_verbose, testflag) class(evt_resonance_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u, i u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u, 2) write (u, "(1x,A,A,A)") "Process library = '", char (evt%libname), "'" if (allocated (evt%res_history_set)) then do i = 1, size (evt%res_history_set) if (i == evt%selected_component) then write (u, "(1x,A,I0,A)") "Component #", i, ": *" else write (u, "(1x,A,I0,A)") "Component #", i, ":" end if call evt%res_history_set(i)%write (u, indent=1) end do end if call write_separator (u) if (allocated (evt%instance)) then write (u, "(1x,A)") "Subprocess instances: allocated" else write (u, "(1x,A)") "Subprocess instances: not allocated" end if if (evt%particle_set_exists) then if (evt%selected_history > 0) then write (u, "(1x,A,I0)") "Selected: resonance history #", & evt%selected_history else write (u, "(1x,A)") "Selected: no resonance history" end if else write (u, "(1x,A)") "Selected: [none]" end if write (u, "(1x,A,1x," // FMT_12 // ")") & "On-shell limit =", evt%on_shell_limit write (u, "(1x,A,1x," // FMT_12 // ")") & "On-shell turnoff =", evt%on_shell_turnoff write (u, "(1x,A,1x," // FMT_12 // ")") & "Background factor =", evt%background_factor call write_separator (u) if (evt%selector_active) then write (u, "(2x)", advance="no") call evt%selector%write (u, testflag=testflag) call write_separator (u) end if call evt%base_write (u, testflag = testflag, show_set = .false.) call write_separator (u) if (evt%particle_set_exists) then call evt%particle_set%write & (u, summary = .true., compressed = .true., testflag = testflag) call write_separator (u) end if end subroutine evt_resonance_write @ %def evt_resonance_write @ \subsection{Set contained data} Insert the resonance data, in form of a pre-generated resonance history set. Accumulate the number of histories for each set, to initialize an array of index offsets for lookup. <>= procedure :: set_resonance_data => evt_resonance_set_resonance_data <>= subroutine evt_resonance_set_resonance_data (evt, res_history_set) class(evt_resonance_t), intent(inout) :: evt type(resonance_history_set_t), dimension(:), intent(in) :: res_history_set integer :: i evt%res_history_set = res_history_set allocate (evt%index_offset (size (evt%res_history_set)), source = 0) do i = 2, size (evt%res_history_set) evt%index_offset(i) = & evt%index_offset(i-1) + evt%res_history_set(i-1)%get_n_history () end do end subroutine evt_resonance_set_resonance_data @ %def evt_resonance_set_resonance_data @ Set the library that contains the resonant subprocesses. <>= procedure :: set_library => evt_resonance_set_library <>= subroutine evt_resonance_set_library (evt, libname) class(evt_resonance_t), intent(inout) :: evt type(string_t), intent(in) :: libname evt%libname = libname end subroutine evt_resonance_set_library @ %def evt_resonance_set_library @ Assign pointers to subprocess instances. Once a subprocess has been selected, the instance is used for generating the particle set with valid quantum-number assignments, ready for resonance insertion. <>= procedure :: set_subprocess_instances & => evt_resonance_set_subprocess_instances <>= subroutine evt_resonance_set_subprocess_instances (evt, instance) class(evt_resonance_t), intent(inout) :: evt type(process_instance_ptr_t), dimension(:), intent(in) :: instance evt%instance = instance end subroutine evt_resonance_set_subprocess_instances @ %def evt_resonance_set_subprocess_instances @ Set the on-shell limit, the relative distance from a resonance that is still considered to be on-shell. The probability for being considered on-shell can be reduced by the turnoff parameter below. For details, see the [[resonances]] module. <>= procedure :: set_on_shell_limit => evt_resonance_set_on_shell_limit <>= subroutine evt_resonance_set_on_shell_limit (evt, on_shell_limit) class(evt_resonance_t), intent(inout) :: evt real(default), intent(in) :: on_shell_limit evt%on_shell_limit = on_shell_limit end subroutine evt_resonance_set_on_shell_limit @ %def evt_resonance_set_on_shell_limit @ Set the Gaussian on-shell turnoff parameter, the width of the weighting factor for the resonance squared matrix element. If the resonance is off shell, this factor reduces the weight of the matrix element in the selector, such that the probability for considered resonant is reduced. The factor is applied only if the offshellness is less than the [[on_shell_limit]] above. For details, see the [[resonances]] module. <>= procedure :: set_on_shell_turnoff => evt_resonance_set_on_shell_turnoff <>= subroutine evt_resonance_set_on_shell_turnoff (evt, on_shell_turnoff) class(evt_resonance_t), intent(inout) :: evt real(default), intent(in) :: on_shell_turnoff evt%on_shell_turnoff = on_shell_turnoff end subroutine evt_resonance_set_on_shell_turnoff @ %def evt_resonance_set_on_shell_turnoff @ Reweight (suppress) the background contribution if there is a resonance history that applies. The event will be registered as background if there is no applicable resonance history, or if the background configuration has been selected based on (reweighted) squared matrix elements. <>= procedure :: set_background_factor => evt_resonance_set_background_factor <>= subroutine evt_resonance_set_background_factor (evt, background_factor) class(evt_resonance_t), intent(inout) :: evt real(default), intent(in) :: background_factor evt%background_factor = background_factor end subroutine evt_resonance_set_background_factor @ %def evt_resonance_set_background_factor @ \subsection{Selector} Manually import a random-number generator object. This should be done only for testing purposes. The standard procedure is to [[connect]] a process to an event transform; this will create an appropriate [[rng]] from the RNG factory in the process object. <>= procedure :: import_rng => evt_resonance_import_rng <>= subroutine evt_resonance_import_rng (evt, rng) class(evt_resonance_t), intent(inout) :: evt class(rng_t), allocatable, intent(inout) :: rng call move_alloc (from = rng, to = evt%rng) end subroutine evt_resonance_import_rng @ %def evt_resonance_import_rng @ We use a standard selector object to choose from the available resonance histories. If the selector is inactive, we do not insert resonances. <>= procedure :: write_selector => evt_resonance_write_selector <>= subroutine evt_resonance_write_selector (evt, unit, testflag) class(evt_resonance_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (evt%selector_active) then call evt%selector%write (u, testflag) else write (u, "(1x,A)") "Selector: [inactive]" end if end subroutine evt_resonance_write_selector @ %def evt_resonance_write_selector @ The selector is initialized with relative weights of histories which need not be normalized. Channels with weight zero are ignored. The [[offset]] will normally be $-1$, so we count from zero, and zero is a valid result from the selector. Selecting the zero entry implies no resonance insertion. However, this behavior is not hard-coded here (without offset, no resonance is not possible as a result). <>= procedure :: init_selector => evt_resonance_init_selector <>= subroutine evt_resonance_init_selector (evt, weight, offset) class(evt_resonance_t), intent(inout) :: evt real(default), dimension(:), intent(in) :: weight integer, intent(in), optional :: offset if (any (weight > 0)) then call evt%selector%init (weight, offset = offset) evt%selector_active = .true. else evt%selector_active = .false. end if end subroutine evt_resonance_init_selector @ %def evt_resonance_init_selector @ Return all selector weights, for inspection. Note that the index counts from zero. <>= procedure :: get_selector_weights => evt_resonance_get_selector_weights <>= subroutine evt_resonance_get_selector_weights (evt, weight) class(evt_resonance_t), intent(in) :: evt real(default), dimension(0:), intent(out) :: weight integer :: i do i = 0, ubound (weight,1) weight(i) = evt%selector%get_weight (i) end do end subroutine evt_resonance_get_selector_weights @ %def evt_resonance_get_selector_weights @ \subsection{Runtime calculations} Use the associated master process instance and the subprocess instances to distribute the current momentum set, then compute the squared matrix elements weights for all subprocesses. NOTE: Procedures in this subsection are not covered by unit tests in this module, but by unit tests of the [[restricted_subprocesses]] module. Fill the particle set, so the momentum configuration can be used by the subprocess instances. The standard workflow is to copy from the previous particle set. <>= procedure :: fill_momenta => evt_resonance_fill_momenta <>= subroutine evt_resonance_fill_momenta (evt) class(evt_resonance_t), intent(inout) :: evt integer :: i, n if (associated (evt%previous)) then evt%particle_set = evt%previous%particle_set else if (associated (evt%process_instance)) then ! this branch only for unit test call evt%process_instance%get_trace & (evt%particle_set, i_term=1, n_incoming=evt%process%get_n_in ()) end if end subroutine evt_resonance_fill_momenta @ %def evt_resonance_fill_momenta @ Return the indices of those subprocesses which can be considered on-shell. The result depends on the stored particle set (outgoing momenta) and on the on-shell limit value. The index [[evt%selected_component]] identifies the particular history set that corresponds to the given process component. Recall that process components may have different external particles, so they have distinct history sets. <>= procedure :: determine_on_shell_histories & => evt_resonance_determine_on_shell_histories <>= subroutine evt_resonance_determine_on_shell_histories & (evt, index_array) class(evt_resonance_t), intent(in) :: evt integer, dimension(:), allocatable, intent(out) :: index_array integer :: i i = evt%selected_component call evt%res_history_set(i)%determine_on_shell_histories & (evt%particle_set%get_outgoing_momenta (), & evt%on_shell_limit, & index_array) end subroutine evt_resonance_determine_on_shell_histories @ %def evt_resonance_determine_on_shell_histories @ Evaluate selected subprocesses. (In actual operation, the ones that have been tagged as on-shell.) We assume that the MCI, term, and channel indices for the subprocesses can all be set to 1. <>= procedure :: evaluate_subprocess => evt_resonance_evaluate_subprocess <>= subroutine evt_resonance_evaluate_subprocess (evt, index_array) class(evt_resonance_t), intent(inout) :: evt integer, dimension(:), intent(in) :: index_array integer :: k, i if (allocated (evt%instance)) then do k = 1, size (index_array) i = index_array(k) associate (instance => evt%instance(i)%p) call instance%choose_mci (1) call instance%set_trace (evt%particle_set, 1, check_match=.false.) call instance%recover (channel = 1, i_term = 1, & update_sqme = .true., recover_phs = .false.) end associate end do end if end subroutine evt_resonance_evaluate_subprocess @ %def evt_resonance_evaluate_subprocess @ Return the current squared matrix-element value of the master process, and of the selected resonant subprocesses, respectively. <>= procedure :: get_master_sqme => evt_resonance_get_master_sqme procedure :: get_subprocess_sqme => evt_resonance_get_subprocess_sqme <>= function evt_resonance_get_master_sqme (evt) result (sqme) class(evt_resonance_t), intent(in) :: evt real(default) :: sqme sqme = evt%process_instance%get_sqme () end function evt_resonance_get_master_sqme subroutine evt_resonance_get_subprocess_sqme (evt, sqme, index_array) class(evt_resonance_t), intent(in) :: evt real(default), dimension(:), intent(out) :: sqme integer, dimension(:), intent(in), optional :: index_array integer :: k, i if (present (index_array)) then sqme = 0 do k = 1, size (index_array) call get_sqme (index_array(k)) end do else do i = 1, size (evt%instance) call get_sqme (i) end do end if contains subroutine get_sqme (i) integer, intent(in) :: i associate (instance => evt%instance(i)%p) sqme(i) = instance%get_sqme () end associate end subroutine get_sqme end subroutine evt_resonance_get_subprocess_sqme @ %def evt_resonance_get_master_sqme @ %def evt_resonance_get_subprocess_sqme @ Apply a turnoff factor for off-shell kinematics to the [[sqme]] values. The [[sqme]] array indices are offset from the resonance history set entries. <>= procedure :: apply_turnoff_factor => evt_resonance_apply_turnoff_factor <>= subroutine evt_resonance_apply_turnoff_factor (evt, sqme, index_array) class(evt_resonance_t), intent(in) :: evt real(default), dimension(:), intent(inout) :: sqme integer, dimension(:), intent(in) :: index_array integer :: k, i_res, i_prc do k = 1, size (index_array) i_res = evt%selected_component i_prc = index_array(k) + evt%index_offset(i_res) sqme(i_prc) = sqme(i_prc) & * evt%res_history_set(i_res)%evaluate_gaussian & & (evt%particle_set%get_outgoing_momenta (), & & evt%on_shell_turnoff, index_array(k)) end do end subroutine evt_resonance_apply_turnoff_factor @ %def evt_resonance_apply_turnoff_factor @ We use the calculations of resonant matrix elements to determine probabilities for all applicable resonance configurations. This method combines the steps implemented above. First, we determine the selected process component. TODO: the version below selects the first component which is found active. This make sense only for standard LO process components, where exactly one component corresponds to a MCI set. For the selected process component, we query the kinematics and determine the applicable resonance histories. We collect squared matrix elements for those resonance histories and compare them to the master-process squared matrix element. The result is the probability for each resonance history together with the probability for non-resonant background (zeroth entry). The latter is defined as the difference between the complete process result and the sum of the resonances, ignoring the possibility for interference. If the complete process result is actually undershooting the sum of resonances, we nevertheless count the background with positive probability. When looking up the subprocess sqme, we must add the [[index_offset]] to the resulting array, since the indices returned by the individual history set all count from one, while the subprocess instances that belong to process components are collected in one flat array. After determining matrix elements and background, we may reduce the weight of the matrix elements in the selector by applying a turnoff factor. The factor [[background_factor]] indicates whether to include the background contribution at all, as long as there is a nonvanishing resonance contribution. Note that instead of setting background to zero, we just multiply it by a very small number. This ensures that indices are assigned correctly, and that background will eventually be selected if smooth turnoff is chosen. <>= procedure :: compute_probabilities => evt_resonance_compute_probabilities <>= subroutine evt_resonance_compute_probabilities (evt) class(evt_resonance_t), intent(inout) :: evt integer, dimension(:), allocatable :: index_array real(default) :: sqme_master, sqme_sum, sqme_bg real(default), dimension(:), allocatable :: sqme_res integer :: n, ic if (.not. associated (evt%process_instance)) return n = size (evt%instance) call evt%select_component (0) FIND_ACTIVE_COMPONENT: do ic = 1, evt%process%get_n_components () if (evt%process%component_is_selected (ic)) then call evt%select_component (ic) exit FIND_ACTIVE_COMPONENT end if end do FIND_ACTIVE_COMPONENT if (evt%selected_component > 0) then call evt%determine_on_shell_histories (index_array) else allocate (index_array (0)) end if call evt%evaluate_subprocess & (index_array + evt%index_offset(evt%selected_component)) allocate (sqme_res (n), source = 0._default) call evt%get_subprocess_sqme & (sqme_res, index_array + evt%index_offset(evt%selected_component)) sqme_master = evt%get_master_sqme () sqme_sum = sum (sqme_res) sqme_bg = abs (sqme_master - sqme_sum) if (evt%on_shell_turnoff > 0) then call evt%apply_turnoff_factor (sqme_res, index_array) end if if (any (sqme_res > 0)) then sqme_bg = sqme_bg * evt%background_factor end if call evt%init_selector ([sqme_bg, sqme_res], offset = -1) end subroutine evt_resonance_compute_probabilities @ %def evt_resonance_compute_probabilities @ Set the selected component (unit tests). <>= procedure :: select_component => evt_resonance_select_component <>= subroutine evt_resonance_select_component (evt, i_component) class(evt_resonance_t), intent(inout) :: evt integer, intent(in) :: i_component evt%selected_component = i_component end subroutine evt_resonance_select_component @ %def evt_resonance_select_component @ \subsection{Sanity check} Check the color assignment, which may be wrong for the inserted resonances. Delegated to the particle-set component. Return offending particle indices and, optionally, particles as arrays. This is done in a unit test. The current algorithm, i.e., selecting the color assignment from the resonant-subprocess instance, should not generate invalid color assignments. <>= procedure :: find_prt_invalid_color => evt_resonance_find_prt_invalid_color <>= subroutine evt_resonance_find_prt_invalid_color (evt, index, prt) class(evt_resonance_t), intent(in) :: evt integer, dimension(:), allocatable, intent(out) :: index type(particle_t), dimension(:), allocatable, intent(out), optional :: prt if (evt%particle_set_exists) then call evt%particle_set%find_prt_invalid_color (index, prt) else allocate (prt (0)) end if end subroutine evt_resonance_find_prt_invalid_color @ %def evt_resonance_find_prt_invalid_color @ \subsection{API implementation} <>= procedure :: prepare_new_event => evt_resonance_prepare_new_event <>= subroutine evt_resonance_prepare_new_event (evt, i_mci, i_term) class(evt_resonance_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () end subroutine evt_resonance_prepare_new_event @ %def evt_resonance_prepare_new_event @ Select one of the histories, based on the momentum array from the current particle set. Compute the probabilities for all resonant subprocesses and initialize the selector accordingly. Then select one resonance history, or none. <>= procedure :: generate_weighted => evt_resonance_generate_weighted <>= subroutine evt_resonance_generate_weighted (evt, probability) class(evt_resonance_t), intent(inout) :: evt real(default), intent(inout) :: probability call evt%fill_momenta () call evt%compute_probabilities () call evt%selector%generate (evt%rng, evt%selected_history) probability = 1 end subroutine evt_resonance_generate_weighted @ %def evt_resonance_generate_weighted @ Here take the current particle set and insert resonance intermediate states if applicable. The resonance history has already been chosen by the generator above. If no resonance history applies, just retain the particle set. If a resonance history applies, we factorize the exclusive interaction of the selected (resonance-process) process instance. With a temporary particle set [[prt_set]] as workspace, we the insert the resonances, reinstate parent-child relations and set colors and momenta for the resonances. The temporary is then copied back. Taking the event data from the resonant subprocess instead of the master process, guarantees that all flavor, helicity, and color assignments are valid for the selected resonance history. Note that the transform may thus choose a quantum-number combination that is different from the one chosen by the master process. The [[i_term]] value for the selected subprocess instance is always 1. We support only LO process. For those, the master process may have several terms (= components) that correspond to different external states. The subprocesses are distinct, each one corresponds to a definite master component, and by itself it consists of a single component/term. However, if the selector chooses resonance history \#0, i.e., no resonance, we just copy the particle set from the previous (i.e., trivial) event transform and ignore all subprocess data. <>= procedure :: make_particle_set => evt_resonance_make_particle_set <>= subroutine evt_resonance_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_resonance_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r type(particle_set_t), target :: prt_set type(particle_t), dimension(:), allocatable :: prt integer :: n_beam, n_in, n_vir, n_res, n_out, i, i_res, i_term, i_tree type(interaction_t), pointer :: int_matrix, int_flows integer, dimension(:), allocatable :: map type(resonance_tree_t) :: res_tree if (associated (evt%previous)) then if (evt%previous%particle_set_exists) then if (evt%selected_history > 0) then if (allocated (evt%instance)) then associate (instance => evt%instance(evt%selected_history)%p) call instance%evaluate_event_data (weight = 1._default) i_term = 1 int_matrix => instance%get_matrix_int_ptr (i_term) int_flows => instance%get_flows_int_ptr (i_term) call evt%factorize_interactions (int_matrix, int_flows, & factorization_mode, keep_correlations, r) call evt%tag_incoming () end associate else ! this branch only for unit test evt%particle_set = evt%previous%particle_set end if i_tree = evt%selected_history & - evt%index_offset(evt%selected_component) call evt%res_history_set(evt%selected_component)%get_tree & (i_tree, res_tree) n_beam = evt%particle_set%get_n_beam () n_in = evt%particle_set%get_n_in () n_vir = evt%particle_set%get_n_vir () n_out = evt%particle_set%get_n_out () n_res = res_tree%get_n_resonances () allocate (map (n_beam + n_in + n_vir + n_out)) map(1:n_beam+n_in+n_vir) & = [(i, i = 1, n_beam+n_in+n_vir)] map(n_beam+n_in+n_vir+1:n_beam+n_in+n_vir+n_out) & = [(i + n_res, & & i = n_beam+n_in+n_vir+1, & & n_beam+n_in+n_vir+n_out)] call prt_set%transfer (evt%particle_set, n_res, map) do i = 1, n_res i_res = n_beam + n_in + n_vir + i call prt_set%insert (i_res, & PRT_RESONANT, & res_tree%get_flv (i), & res_tree%get_children (i, & & n_beam+n_in+n_vir, n_beam+n_in+n_vir+n_res)) end do do i = n_res, 1, -1 i_res = n_beam + n_in + n_vir + i call prt_set%recover_color (i_res) end do call prt_set%set_momentum & (map(:), evt%particle_set%get_momenta (), on_shell = .true.) do i = n_res, 1, -1 i_res = n_beam + n_in + n_vir + i call prt_set%recover_momentum (i_res) end do call evt%particle_set%final () evt%particle_set = prt_set call prt_set%final () evt%particle_set_exists = .true. else ! retain particle set, as copied from previous evt evt%particle_set_exists = .true. end if else evt%particle_set_exists = .false. end if else evt%particle_set_exists = .false. end if end subroutine evt_resonance_make_particle_set @ %def event_resonance_make_particle_set @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[resonance_insertion_ut.f90]]>>= <> module resonance_insertion_ut use unit_tests use resonance_insertion_uti <> <> contains <> end module resonance_insertion_ut @ %def resonance_insertion_ut @ <<[[resonance_insertion_uti.f90]]>>= <> module resonance_insertion_uti <> <> use format_utils, only: write_separator use os_interface use lorentz use rng_base, only: rng_t use flavors, only: flavor_t use colors, only: color_t use models, only: syntax_model_file_init, syntax_model_file_final use models, only: model_list_t, model_t use particles, only: particle_t, particle_set_t use resonances, only: resonance_info_t use resonances, only: resonance_history_t use resonances, only: resonance_history_set_t use event_transforms use resonance_insertion use rng_base_ut, only: rng_test_t <> <> contains <> end module resonance_insertion_uti @ %def resonance_insertion_uti @ API: driver for the unit tests below. <>= public :: resonance_insertion_test <>= subroutine resonance_insertion_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine resonance_insertion_test @ %def resonance_insertion_test @ \subsubsection{Test resonance insertion as event transform} Insert a resonance (W boson) into an event with momentum assignment. <>= call test (resonance_insertion_1, "resonance_insertion_1", & "simple resonance insertion", & u, results) <>= public :: resonance_insertion_1 <>= subroutine resonance_insertion_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance type(flavor_t) :: fw type(color_t) :: col real(default) :: mw, ew, pw type(vector4_t), dimension(5) :: p class(rng_t), allocatable :: rng real(default) :: probability integer, dimension(:), allocatable :: i_invalid type(particle_t), dimension(:), allocatable :: prt_invalid integer :: i write (u, "(A)") "* Test output: resonance_insertion_1" write (u, "(A)") "* Purpose: apply simple resonance insertion" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) ! reset slightly in order to avoid a rounding ambiguity call model%set_real (var_str ("mW"), 80.418_default) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 3, & pdg = [1, -1, 1, -2, 24], model = model) call fw%init (24, model) mw = fw%get_mass () ew = 200._default pw = sqrt (ew**2 - mw**2) p(1) = vector4_moving (ew, ew, 3) p(2) = vector4_moving (ew,-ew, 3) p(3) = vector4_moving (ew/2, vector3_moving ([pw/2, mw/2, 0._default])) p(4) = vector4_moving (ew/2, vector3_moving ([pw/2,-mw/2, 0._default])) p(5) = vector4_moving (ew, vector3_moving ([-pw, 0._default, 0._default])) call pset%set_momentum (p, on_shell = .true.) call col%init_col_acl (1,0) call pset%set_color (1, col) call col%init_col_acl (0,1) call pset%set_color (2, col) call col%init_col_acl (2,0) call pset%set_color (3, col) call col%init_col_acl (0,2) call pset%set_color (4, col) call col%init_col_acl (0,0) call pset%set_color (5, col) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, -24, model, 2) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default]) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") call evt_resonance%find_prt_invalid_color (i_invalid, prt_invalid) write (u, "(A)") "Particles with invalid color:" select case (size (prt_invalid)) case (0) write (u, "(2x,A)") "[none]" case default do i = 1, size (prt_invalid) write (u, "(1x,A,1x,I0)", advance="no") "Particle", i_invalid(i) call prt_invalid(i)%write (u) end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_1" end subroutine resonance_insertion_1 @ %def resonance_insertion_1 @ \subsubsection{Resonance insertion with color mismatch} Same as previous test (but no momenta); resonance insertion should fail because of color mismatch: W boson is color-neutral. <>= call test (resonance_insertion_2, "resonance_insertion_2", & "resonance color mismatch", & u, results) <>= public :: resonance_insertion_2 <>= subroutine resonance_insertion_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance type(color_t) :: col class(rng_t), allocatable :: rng real(default) :: probability type(particle_t), dimension(:), allocatable :: prt_invalid integer, dimension(:), allocatable :: i_invalid integer :: i write (u, "(A)") "* Test output: resonance_insertion_2" write (u, "(A)") "* Purpose: resonance insertion with color mismatch" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 3, & pdg = [1, -1, 1, -2, 24], model = model) call col%init_col_acl (1,0) call pset%set_color (1, col) call col%init_col_acl (0,2) call pset%set_color (2, col) call col%init_col_acl (1,0) call pset%set_color (3, col) call col%init_col_acl (0,2) call pset%set_color (4, col) call col%init_col_acl (0,0) call pset%set_color (5, col) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, -24, model, 2) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default]) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") call evt_resonance%find_prt_invalid_color (i_invalid, prt_invalid) write (u, "(A)") "Particles with invalid color:" select case (size (prt_invalid)) case (0) write (u, "(2x,A)") "[none]" case default do i = 1, size (prt_invalid) write (u, "(1x,A,1x,I0)", advance="no") "Particle", i_invalid(i) call prt_invalid(i)%write (u) end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_2" end subroutine resonance_insertion_2 @ %def resonance_insertion_2 @ \subsubsection{Complex resonance history} This is the resonance history $u\bar u \to (t\to W^+ b) + (\bar t\to (h \to b\bar b) + (\bar t^\ast \to W^-\bar b))$. <>= call test (resonance_insertion_3, "resonance_insertion_3", & "complex resonance history", & u, results) <>= public :: resonance_insertion_3 <>= subroutine resonance_insertion_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance type(color_t) :: col class(rng_t), allocatable :: rng real(default) :: probability type(particle_t), dimension(:), allocatable :: prt_invalid integer, dimension(:), allocatable :: i_invalid integer :: i write (u, "(A)") "* Test output: resonance_insertion_3" write (u, "(A)") "* Purpose: resonance insertion with color mismatch" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 6, & pdg = [2, -2, 24, 5, 5, -5, -24, -5], model = model) call col%init_col_acl (1,0) call pset%set_color (1, col) call col%init_col_acl (0,2) call pset%set_color (2, col) call col%init_col_acl (0,0) call pset%set_color (3, col) call col%init_col_acl (1,0) call pset%set_color (4, col) call col%init_col_acl (3,0) call pset%set_color (5, col) call col%init_col_acl (0,3) call pset%set_color (6, col) call col%init_col_acl (0,0) call pset%set_color (7, col) call col%init_col_acl (0,2) call pset%set_color (8, col) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, 6, model, 6) call res_history%add_resonance (res_info) call res_info%init (12, 25, model, 6) call res_history%add_resonance (res_info) call res_info%init (60, -6, model, 6) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default]) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") call evt_resonance%find_prt_invalid_color (i_invalid, prt_invalid) write (u, "(A)") "Particles with invalid color:" select case (size (prt_invalid)) case (0) write (u, "(2x,A)") "[none]" case default do i = 1, size (prt_invalid) write (u, "(1x,A,1x,I0)", advance="no") "Particle", i_invalid(i) call prt_invalid(i)%write (u) end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_3" end subroutine resonance_insertion_3 @ %def resonance_insertion_3 @ \subsubsection{Resonance history selection} Another test with zero momenta: select one of several resonant channels using the selector component. <>= call test (resonance_insertion_4, "resonance_insertion_4", & "resonance history selection", & u, results) <>= public :: resonance_insertion_4 <>= subroutine resonance_insertion_4 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance type(color_t) :: col class(rng_t), allocatable :: rng real(default) :: probability integer :: i write (u, "(A)") "* Test output: resonance_insertion_4" write (u, "(A)") "* Purpose: resonance history selection" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 4, & pdg = [1, -1, 1, -2, -3, 4], model = model) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, -24, model, 4) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_info%init (12, 24, model, 4) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_info%init (12, 24, model, 4) call res_history%add_resonance (res_info) call res_info%init (15, 25, model, 4) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") do i = 1, 6 write (u, "(A,1x,I0)") "* Event #", i write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default, 2._default, 1._default]) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") end do write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_4" end subroutine resonance_insertion_4 @ %def resonance_insertion_4 @ \subsubsection{Resonance history selection} Another test with zero momenta: select either a resonant channel or no resonance. <>= call test (resonance_insertion_5, "resonance_insertion_5", & "resonance history on/off", & u, results) <>= public :: resonance_insertion_5 <>= subroutine resonance_insertion_5 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance type(color_t) :: col class(rng_t), allocatable :: rng real(default) :: probability integer :: i write (u, "(A)") "* Test output: resonance_insertion_5" write (u, "(A)") "* Purpose: resonance history selection including no resonance" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 4, & pdg = [1, -1, 1, -2, -3, 4], model = model) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, -24, model, 4) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") do i = 1, 2 write (u, "(A,1x,I0)") "* Event #", i write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default, 3._default], offset = -1) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") end do write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_5" end subroutine resonance_insertion_5 @ %def resonance_insertion_5 @ \subsubsection{Resonance insertion with structured beams} Insert a resonance (W boson) into an event with beam and virtual particles. <>= call test (resonance_insertion_6, "resonance_insertion_6", & "resonance insertion with beam structure", & u, results) <>= public :: resonance_insertion_6 <>= subroutine resonance_insertion_6 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(particle_set_t) :: pset type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance class(rng_t), allocatable :: rng real(default) :: probability write (u, "(A)") "* Test output: resonance_insertion_6" write (u, "(A)") "* Purpose: resonance insertion with structured beams" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 11, -11, 22, 22, 13, -13], model = model) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, 23, model, 2) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default]) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_6" end subroutine resonance_insertion_6 @ %def resonance_insertion_6 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Recoil kinematics} <<[[recoil_kinematics.f90]]>>= <> module recoil_kinematics <> use constants, only: twopi use lorentz, only: vector4_t use lorentz, only: vector4_moving use lorentz, only: vector3_moving use lorentz, only: transverse_part use lorentz, only: lorentz_transformation_t use lorentz, only: inverse use lorentz, only: boost use lorentz, only: transformation use lorentz, only: operator(+) use lorentz, only: operator(-) use lorentz, only: operator(*) use lorentz, only: operator(**) <> <> <> <> contains <> end module recoil_kinematics @ %def recoil_kinematics @ \subsection{$\phi$ sampler} This is trivial. Generate an azimuthal angle, given a $(0,1)$ RNG parameter. <>= elemental subroutine generate_phi_recoil (r, phi) real(default), intent(in) :: r real(default), intent(out) :: phi phi = r * twopi end subroutine generate_phi_recoil @ %def generate_phi_recoil @ \subsection{$Q^2$ sampler} The dynamics of factorization suggests to generate a flat $Q^2$ distribution from a (random) number, event by event. At the lowest momentum transfer values, the particle (electron) mass sets a smooth cutoff. The formula can produce $Q$ values below the electron mass, down to zero, but with a power distribution that eventually evolves into the expected logarithmic distribution for $Q^2 > m^2$. We are talking about the absolute value here, so all $Q^2$ values are positive. For the actual momentum transfer, $q^2=-Q^2$. <>= public :: generate_q2_recoil <>= elemental subroutine generate_q2_recoil (s, x_bar, q2_max, m2, r, q2) real(default), intent(in) :: s real(default), intent(in) :: q2_max real(default), intent(in) :: x_bar real(default), intent(in) :: m2 real(default), intent(in) :: r real(default), intent(out) :: q2 real(default) :: q2_max_evt q2_max_evt = q2_max_event (s, x_bar, q2_max) q2 = m2 * (exp (r * log (1 + (q2_max_evt / m2))) - 1) end subroutine generate_q2_recoil @ %def generate_q_recoil @ The $Q$ distribution is cut off from above by the kinematic limit, which depends on the energy that is available for the radiated photon, or by a user-defined cutoff -- whichever is less. The kinematic limit fits the formulas for recoil momenta (see below), and it also implicitly enters the ISR collinear structure function, so the normalization of the distribution should be correct. <>= elemental function q2_max_event (s, x_bar, q2_max) result (q2) real(default), intent(in) :: s real(default), intent(in) :: x_bar real(default), intent(in) :: q2_max real(default) :: q2 q2 = min (x_bar * s, q2_max) end function q2_max_event @ %def q2_max_event @ \subsection{Kinematics functions} Given values for energies, $Q_{1,2}^2$, azimuthal angle, compute the matching polar angle of the radiating particle. The subroutine returns $\sin\theta$ and $\cos\theta$. <>= subroutine polar_angles (s, xb, rho, ee, q2, sin_th, cos_th, ok) real(default), intent(in) :: s real(default), intent(in) :: xb real(default), intent(in) :: rho real(default), dimension(2), intent(in) :: ee real(default), dimension(2), intent(in) :: q2 real(default), dimension(2), intent(out) :: sin_th real(default), dimension(2), intent(out) :: cos_th logical, intent(out) :: ok real(default), dimension(2) :: sin2_th_2 sin2_th_2 = q2 / (ee * rho * xb * s) if (all (sin2_th_2 <= 1)) then sin_th = 2 * sqrt (sin2_th_2 * (1 - sin2_th_2)) cos_th = 1 - 2 * sin2_th_2 ok = .true. else sin_th = 0 cos_th = 1 ok = .false. end if end subroutine polar_angles @ %def polar_angles @ Compute the acollinearity parameter $\lambda$ from azimuthal and polar angles. The result is a number between $0$ and $1$. <>= function lambda_factor (sin_th, cos_th, cphi) result (lambda) real(default), dimension(2), intent(in) :: sin_th real(default), dimension(2), intent(in) :: cos_th real(default), intent(in) :: cphi real(default) :: lambda lambda = (1 - cos_th(1) * cos_th(2) - cphi * sin_th(1) * sin_th(2)) / 2 end function lambda_factor @ %def lambda_factor @ Compute the factor that rescales photon energies, such that the radiation angles match the kinematics parameters. For small values of $\bar x/\cosh\eta$, we have to use the Taylor expansion if we do not want to lose precision. The optional argument allows for a unit test that compares exact and approximate. <>= function scale_factor (che, lambda, xb0, approximate) result (rho) real(default), intent(in) :: che real(default), intent(in) :: lambda real(default), intent(in) :: xb0 logical, intent(in), optional :: approximate real(default) :: rho real(default), parameter :: & e0 = (100 * epsilon (1._default)) ** (0.3_default) logical :: approx if (present (approximate)) then approx = approximate else approx = (xb0/che) < e0 end if if (approx) then rho = 1 - lambda * (xb0/(2*che)) * (1 + (1-lambda) * (xb0/che)) else rho = (che / ((1-lambda)*xb0)) & * (1 - sqrt (1 - 2 * (1-lambda) * (xb0/che) & & + (1-lambda) * (xb0 / che)**2)) end if end function scale_factor @ %def scale_factor @ The code snippet below is not used anywhere, but may be manually inserted in a unit test to numerically verify the approximation above. <>= write (u, "(A)") write (u, "(A)") "*** Table: scale factor calculation" write (u, "(A)") lambda = 0.25_default write (u, FMT1) "lambda =", lambda che = 4._default write (u, FMT1) "che =", che write (u, "(A)") " x0 rho(exact) rho(approx) rho(chosen)" xb0 = 1._default do i = 1, 30 xb0 = xb0 / 10 write (u, FMT4) xb0, & scale_factor (che, lambda, xb0, approximate=.false.), & scale_factor (che, lambda, xb0, approximate=.true.), & scale_factor (che, lambda, xb0) end do @ Compute the current values for the $x_{1,2}$ parameters, given the updated scale factor $\rho$ and the collinear parameters. <>= subroutine scaled_x (rho, ee, xb0, x, xb) real(default), intent(in) :: rho real(default), dimension(2), intent(in) :: ee real(default), intent(in) :: xb0 real(default), dimension(2), intent(out) :: x real(default), dimension(2), intent(out) :: xb xb = rho * ee * xb0 x = 1 - xb end subroutine scaled_x @ %def scaled_x @ \subsection{Iterative solution of kinematics constraints} Find a solution of the kinematics constraints. We know the parameters appropriate for collinear kinematics $\sqrt{s}$, $x^c_{1,2}$. We have picked values vor the momentum transfer $Q_{1,2}$ and the azimuthal angles $\phi_{1,2}$. The solution consists of modified energy fractions $x_{1,2}$ and polar angles $\theta_{1,2}$. If the computation fails, which can happen for large momentum transfer, the flag [[ok]] will indicate this. <>= public :: solve_recoil <>= subroutine solve_recoil (sqrts, xc, xcb, phi, q2, x, xb, cos_th, sin_th, ok) real(default), intent(in) :: sqrts real(default), dimension(2), intent(in) :: xc real(default), dimension(2), intent(in) :: xcb real(default), dimension(2), intent(in) :: phi real(default), dimension(2), intent(in) :: q2 real(default), dimension(2), intent(out) :: x real(default), dimension(2), intent(out) :: xb real(default), dimension(2), intent(out) :: cos_th real(default), dimension(2), intent(out) :: sin_th logical, intent(out) :: ok real(default) :: s real(default), dimension(2) :: ee real(default), dimension(2) :: th real(default) :: xb0, cphi real(default) :: che, lambda real(default) :: rho_new, rho, rho_old real(default) :: dr_old, dr_new real(default), parameter :: dr_limit = 100 * epsilon (1._default) integer, parameter :: n_it_max = 20 integer :: i ok = .true. s = sqrts**2 ee = sqrt ([xcb(1)/xcb(2), xcb(2)/xcb(1)]) che = sum (ee) / 2 xb0 = sqrt (xcb(1) * xcb(2)) cphi = cos (phi(1) - phi(2)) rho_old = 10 rho = 1 th = 0 sin_th = sin (th) cos_th = cos (th) lambda = lambda_factor (sin_th, cos_th, cphi) call scaled_x (rho, ee, xb0, x, xb) iterate_loop: do i = 1, n_it_max call polar_angles (s, xb0, rho, ee, q2, sin_th, cos_th, ok) if (.not. ok) return th = atan2 (sin_th, cos_th) lambda = lambda_factor (sin_th, cos_th, cphi) rho_new = scale_factor (che, lambda, xb0) call scaled_x (rho_new, ee, xb0, x, xb) dr_old = abs (rho - rho_old) dr_new = abs (rho_new - rho) rho_old = rho rho = rho_new if (dr_new < dr_limit .or. dr_new >= dr_old) exit iterate_loop end do iterate_loop end subroutine solve_recoil @ %def solve_recoil @ With all kinematics parameters known, construct actual four-vectors for the recoil momenta, the off-shell (spacelike) parton momenta, and on-shell projected parton momenta. <>= public :: recoil_momenta <>= subroutine recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, km, qm, qo) real(default), intent(in) :: sqrts real(default), dimension(2), intent(in) :: xc real(default), dimension(2), intent(in) :: xb real(default), dimension(2), intent(in) :: cos_th real(default), dimension(2), intent(in) :: sin_th real(default), dimension(2), intent(in) :: phi type(vector4_t), dimension(2), intent(out) :: km type(vector4_t), dimension(2), intent(out) :: qm type(vector4_t), dimension(2), intent(out) :: qo type(vector4_t), dimension(2) :: pm type(lorentz_transformation_t) :: lt real(default) :: sqsh pm(1) = & vector4_moving (sqrts/2, & vector3_moving ([0._default, 0._default, sqrts/2])) pm(2) = & vector4_moving (sqrts/2, & vector3_moving ([0._default, 0._default,-sqrts/2])) km(1) = xb(1) * (sqrts/2) * vector4_moving ( & 1._default, & vector3_moving ([ & & sin_th(1) * cos (phi(1)), & & sin_th(1) * sin (phi(1)), & & cos_th(1)]) & ) km(2) = xb(2) * (sqrts/2) * vector4_moving ( & 1._default, & vector3_moving ([ & & -sin_th(2) * cos (phi(2)), & & -sin_th(2) * sin (phi(2)), & & -cos_th(2)]) & ) qm(1) = pm(1) - km(1) qm(2) = pm(2) - km(2) sqsh = sqrt (xc(1)*xc(2)) * sqrts lt = transformation (3, qm(1), qm(2), sqsh) qo(1) = lt * vector4_moving (sqsh/2, sqsh/2, 3) qo(2) = lt * vector4_moving (sqsh/2,-sqsh/2, 3) end subroutine recoil_momenta @ %def recoil_momenta @ Compute the Lorentz transformation that we can use to transform any outgoing momenta into the new c.m.\ system of the incoming partons. Not relying on the previous calculations, we determine the transformation that transforms the original collinear partons into their c.m.\ system, and then transform this to the new c.m.\ system. <>= public :: recoil_transformation <>= subroutine recoil_transformation (sqrts, xc, qo, lt) real(default), intent(in) :: sqrts real(default), dimension(2), intent(in) :: xc type(vector4_t), dimension(2), intent(in) :: qo type(lorentz_transformation_t), intent(out) :: lt real(default) :: sqsh type(vector4_t), dimension(2) :: qc type(lorentz_transformation_t) :: ltc, lto qc(1) = xc(1) * vector4_moving (sqrts/2, sqrts/2, 3) qc(2) = xc(2) * vector4_moving (sqrts/2,-sqrts/2, 3) sqsh = sqrt (xc(1) * xc(2)) * sqrts ltc = transformation (3, qc(1), qc(2), sqsh) lto = transformation (3, qo(1), qo(2), sqsh) lt = lto * inverse (ltc) end subroutine recoil_transformation @ %def recoil_transformation @ Compute the Lorentz boost that transforms the c.m.\ frame of the momenta into the lab frame where they are given. Also return their common invariant mass, $\sqrt{s}$. If the initial momenta are not collinear, [[ok]] is set false. <>= public :: initial_transformation <>= subroutine initial_transformation (p, sqrts, lt, ok) type(vector4_t), dimension(2), intent(in) :: p real(default), intent(out) :: sqrts type(lorentz_transformation_t), intent(out) :: lt logical, intent(out) :: ok ok = all (transverse_part (p) == 0) sqrts = (p(1) + p(2)) ** 1 lt = boost (p(1) + p(2), sqrts) end subroutine initial_transformation @ %def initial_transformation @ \subsection{Generate recoil event} Combine the above kinematics calculations. First generate azimuthal angles and momentum transfer, solve kinematics and compute momenta for the radiated photons and the on-shell projected, recoiling partons. If [[ok]] is false, the data point has failed and we should repeat the procedure for a new set of RNG parameters [[r]]. <>= public :: generate_recoil <>= subroutine generate_recoil (sqrts, q_max, m, xc, xcb, r, km, qm, qo, ok) real(default), intent(in) :: sqrts real(default), intent(in), dimension(2) :: q_max real(default), intent(in), dimension(2) :: m real(default), intent(in), dimension(2) :: xc real(default), intent(in), dimension(2) :: xcb real(default), intent(in), dimension(4) :: r type(vector4_t), dimension(2), intent(out) :: km type(vector4_t), dimension(2), intent(out) :: qm type(vector4_t), dimension(2), intent(out) :: qo logical, intent(out) :: ok real(default), dimension(2) :: q2 real(default), dimension(2) :: phi real(default), dimension(2) :: x real(default), dimension(2) :: xb real(default), dimension(2) :: cos_th real(default), dimension(2) :: sin_th call generate_q2_recoil (sqrts**2, xcb, q_max**2, m**2, r(1:2), q2) call generate_phi_recoil (r(3:4), phi) call solve_recoil (sqrts, xc, xcb, phi, q2, x, xb, cos_th, sin_th, ok) if (ok) then call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, km, qm, qo) end if end subroutine generate_recoil @ %def generate_recoil @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[recoil_kinematics_ut.f90]]>>= <> module recoil_kinematics_ut use unit_tests use recoil_kinematics_uti <> <> contains <> end module recoil_kinematics_ut @ %def recoil_kinematics_ut @ <<[[recoil_kinematics_uti.f90]]>>= <> module recoil_kinematics_uti <> use constants, only: twopi use constants, only: degree use lorentz, only: vector4_t use lorentz, only: vector4_moving use lorentz, only: lorentz_transformation_t use lorentz, only: inverse use lorentz, only: operator(+) use lorentz, only: operator(*) use lorentz, only: operator(**) use lorentz, only: pacify use recoil_kinematics, only: solve_recoil use recoil_kinematics, only: recoil_momenta use recoil_kinematics, only: recoil_transformation use recoil_kinematics, only: initial_transformation use recoil_kinematics, only: generate_q2_recoil use recoil_kinematics, only: generate_recoil <> <> contains <> end module recoil_kinematics_uti @ %def recoil_kinematics_uti @ API: driver for the unit tests below. <>= public :: recoil_kinematics_test <>= subroutine recoil_kinematics_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine recoil_kinematics_test @ %def recoil_kinematics_test @ \subsubsection{Recoil kinematics} For a set of input data, solve the kinematics constraints and generate momenta accordingly. <>= call test (recoil_kinematics_1, "recoil_kinematics_1", & "iterative solution of non-collinear kinematics", & u, results) <>= public :: recoil_kinematics_1 <>= subroutine recoil_kinematics_1 (u) integer, intent(in) :: u real(default) :: sqrts real(default), dimension(2) :: xc, xcb real(default), dimension(2) :: q real(default), dimension(2) :: phi real(default), dimension(2) :: cos_th, sin_th real(default), dimension(2) :: x real(default), dimension(2) :: xb type(vector4_t), dimension(2) :: km type(vector4_t), dimension(2) :: qm type(vector4_t), dimension(2) :: qo integer :: i logical :: ok character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT2 = "(1x,A,9(1x,F10.5))" character(*), parameter :: FMT4 = "(3x,ES8.1,9(1x,ES19.12))" write (u, "(A)") "* Test output: recoil_kinematics_1" write (u, "(A)") "* Purpose: compute kinematics for various input data" write (u, "(A)") sqrts = 100 write (u, FMT1) "sqrts =", sqrts write (u, "(A)") write (u, "(A)") "*** collinear data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = 0 call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call show_results call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, km, qm, qo) call show_momenta write (u, "(A)") write (u, "(A)") "*** moderate data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = [0.2_default, 0.05_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call show_results call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, km, qm, qo) call show_momenta write (u, "(A)") write (u, "(A)") "*** semi-soft data set" write (u, "(A)") xcb= [0.1_default, 0.0001_default] xc = 1 - xcb phi = [0.1_default, 0.2_default] * twopi q = [0.2_default, 0.00001_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call show_results call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, km, qm, qo) call show_momenta write (u, "(A)") write (u, "(A)") "*** hard-soft data set" write (u, "(A)") xcb= [0.1_default, 1.e-30_default] xc = 1 - xcb phi = [0.1_default, 0.2_default] * twopi q = [0.2_default, 1.e-35_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call show_results call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, km, qm, qo) call show_momenta write (u, "(A)") write (u, "(A)") "*** hard data set" write (u, "(A)") xc = [0.2_default, 0.4_default] xcb = 1 - xc phi = [0.1_default, 0.8_default] * twopi q = [0.74_default, 0.3_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call show_results call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, km, qm, qo) call show_momenta write (u, "(A)") write (u, "(A)") "*** failing data set" write (u, "(A)") xc = [0.2_default, 0.4_default] xcb = 1 - xc phi = [0.1_default, 0.8_default] * twopi q = [0.9_default, 0.3_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) if (.not. ok) then write (u, "(A)") write (u, "(A)") "Failed as expected." end if write (u, "(A)") write (u, "(A)") "* Test output end: recoil_kinematics_1" contains subroutine show_data write (u, FMT1) "sqs_h =", sqrt (xc(1) * xc(2)) * sqrts write (u, FMT1) "xc =", xc write (u, FMT1) "xcb =", xcb write (u, FMT1) "Q =", Q write (u, FMT1) "phi/D =", phi / degree end subroutine show_data subroutine show_results write (u, "(A)") write (u, "(A)") "Result:" write (u, FMT1) "th/D =", atan2 (sin_th, cos_th) / degree write (u, FMT1) "x =", x write (u, "(A)") end subroutine show_results subroutine show_momenta type(vector4_t) :: qm0, qo0 real(default), parameter :: tol = 1.e-7_default call pacify (km, tol) call pacify (qm, tol) call pacify (qo, tol) write (u, "(A)") "Momenta: k" call km(1)%write (u, testflag=.true.) call km(2)%write (u, testflag=.true.) write (u, FMT1) "k^2 =", abs (km(1)**2), abs (km(2)**2) write (u, "(A)") write (u, "(A)") "Momenta: q" call qm(1)%write (u, testflag=.true.) call qm(2)%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "Momenta: q(os)" call qo(1)%write (u, testflag=.true.) call qo(2)%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "Check: parton momentum sum: q vs q(os)" qm0 = qm(1) + qm(2) call qm0%write (u, testflag=.true.) qo0 = qo(1) + qo(2) call qo0%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Check: momentum transfer (off-shell/on-shell)" write (u, FMT2) "|q| =", abs (qm(1)**1), abs (qm(2)**1) write (u, FMT2) "Q =", q write (u, FMT2) "|qo|=", abs (qo(1)**1), abs (qo(2)**1) write (u, "(A)") write (u, "(A)") "* Check: sqrts, sqrts_hat" write (u, FMT1) "|p| =", (km(1)+km(2)+qm(1)+qm(2))**1, (qm(1)+qm(2))**1 write (u, FMT1) "sqs =", sqrts, sqrt (product (xc)) * sqrts write (u, FMT1) "|po|=", abs ((km(1)+km(2)+qo(1)+qo(2))**1), abs ((qo(1)+qo(2))**1) end subroutine show_momenta end subroutine recoil_kinematics_1 @ %def recoil_kinematics_1 @ \subsubsection{Recoil $Q$ distribution} Sample the $Q$ distribution for equidistant bins in the input variable. <>= call test (recoil_kinematics_2, "recoil_kinematics_2", & "Q distribution", & u, results) <>= public :: recoil_kinematics_2 <>= subroutine recoil_kinematics_2 (u) integer, intent(in) :: u real(default) :: sqrts real(default) :: q_max real(default) :: m real(default) :: x_bar real(default) :: r real(default) :: q2, q2_old integer :: i integer :: n_bin character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT3 = "(2x,9(1x,F10.5))" write (u, "(A)") "* Test output: recoil_kinematics_2" write (u, "(A)") "* Purpose: compute Q distribution" write (u, "(A)") n_bin = 20 write (u, "(A)") "* No Q cutoff, xbar = 1" write (u, "(A)") sqrts = 100 q_max = sqrts m = 0.511e-3_default x_bar = 1._default call show_table write (u, "(A)") write (u, "(A)") "* With Q cutoff, xbar = 1" write (u, "(A)") q_max = 10 call show_table write (u, "(A)") write (u, "(A)") "* No Q cutoff, xbar = 0.01" write (u, "(A)") q_max = sqrts x_bar = 0.01_default call show_table write (u, "(A)") write (u, "(A)") "* Test output end: recoil_kinematics_2" contains subroutine show_table write (u, FMT1) "sqrts =", sqrts write (u, FMT1) "q_max =", q_max write (u, FMT1) "m =", m write (u, FMT1) "x_bar =", x_bar write (u, "(A)") write (u, "(1x,A)") "Table: r |Q| |Q_i/Q_(i-1)|" q2_old = 0 do i = 0, n_bin r = real (i, default) / n_bin call generate_q2_recoil (sqrts**2, x_bar, q_max**2, m**2, r, q2) if (q2_old > 0) then write (u, FMT3) r, sqrt (q2), sqrt (q2 / q2_old) else write (u, FMT3) r, sqrt (q2) end if q2_old = q2 end do end subroutine show_table end subroutine recoil_kinematics_2 @ %def recoil_kinematics_2 @ \subsubsection{Generate recoil event} Combine $Q^2$ sampling with momentum generation. <>= call test (recoil_kinematics_3, "recoil_kinematics_3", & "generate recoil event", & u, results) <>= public :: recoil_kinematics_3 <>= subroutine recoil_kinematics_3 (u) integer, intent(in) :: u real(default) :: sqrts real(default), dimension(2) :: q_max real(default), dimension(2) :: m real(default), dimension(2) :: xc, xcb real(default), dimension(4) :: r type(vector4_t), dimension(2) :: km type(vector4_t), dimension(2) :: qm type(vector4_t), dimension(2) :: qo logical :: ok character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT2 = "(1x,A,9(1x,F10.5))" write (u, "(A)") "* Test output: recoil_kinematics_3" write (u, "(A)") "* Purpose: generate momenta from RNG parameters" write (u, "(A)") write (u, "(A)") "*** collinear data set" write (u, "(A)") sqrts = 100 q_max = sqrts m = 0.511e-3_default xc = [0.6_default, 0.9_default] xcb = 1 - xc r = [0._default, 0._default, 0._default, 0._default] call show_data call generate_recoil (sqrts, q_max, m, xc, xcb, r, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** moderate data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc r = [0.8_default, 0.2_default, 0.1_default, 0.2_default] call show_data call generate_recoil (sqrts, q_max, m, xc, xcb, r, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** failing data set" write (u, "(A)") xc = [0.2_default, 0.4_default] xcb = 1 - xc r = [0.9999_default, 0.3_default, 0.1_default, 0.8_default] call show_data call generate_recoil (sqrts, q_max, m, xc, xcb, r, km, qm, qo, ok) if (.not. ok) then write (u, "(A)") write (u, "(A)") "Failed as expected." else call show_momenta end if contains subroutine show_data write (u, FMT1) "sqrts =", sqrts write (u, FMT1) "q_max =", q_max write (u, FMT1) "m =", m write (u, FMT1) "xc =", xc write (u, FMT1) "xcb =", xcb write (u, FMT1) "r =", r end subroutine show_data subroutine show_momenta real(default), parameter :: tol = 1.e-7_default call pacify (km, tol) call pacify (qo, tol) write (u, "(A)") write (u, "(A)") "* Momenta: k" call km(1)%write (u, testflag=.true.) call km(2)%write (u, testflag=.true.) write (u, FMT1) "k^2 =", abs (km(1)**2), abs (km(2)**2) write (u, "(A)") write (u, "(A)") "* Momenta: q(os)" call qo(1)%write (u, testflag=.true.) call qo(2)%write (u, testflag=.true.) write (u, FMT1) "q^2 =", abs (qo(1)**2), abs (qo(2)**2) write (u, "(A)") write (u, "(A)") "* Check: momentum transfer (off-shell/on-shell)" write (u, FMT2) "Q =", q_check (1), q_check (2) write (u, FMT2) "|q| =", abs (qm(1)**1), abs (qm(2)**1) write (u, "(A)") write (u, "(A)") "* Check: sqrts, sqrts_hat" write (u, FMT1) "sqs =", sqrts, sqrt (product (xc)) * sqrts write (u, FMT1) "|po|=", abs ((km(1)+km(2)+qo(1)+qo(2))**1), abs ((qo(1)+qo(2))**1) end subroutine show_momenta function q_check (i) result (q) integer, intent(in) :: i real(default) :: q real(default) :: q2 call generate_q2_recoil (sqrts**2, xcb(i), q_max(i)**2, m(i)**2, r(i), q2) q = sqrt (q2) end function q_check end subroutine recoil_kinematics_3 @ %def recoil_kinematics_3 @ \subsubsection{Transformation after recoil} Given a solution to recoil kinematics, compute the Lorentz transformation that transforms the old collinear parton momenta into the new parton momenta. <>= call test (recoil_kinematics_4, "recoil_kinematics_4", & "reference frame", & u, results) <>= public :: recoil_kinematics_4 <>= subroutine recoil_kinematics_4 (u) integer, intent(in) :: u real(default) :: sqrts real(default), dimension(2) :: xc, xcb real(default), dimension(2) :: q real(default), dimension(2) :: phi real(default), dimension(2) :: cos_th, sin_th real(default), dimension(2) :: x real(default), dimension(2) :: xb type(vector4_t), dimension(2) :: km type(vector4_t), dimension(2) :: qm type(vector4_t), dimension(2) :: qo type(lorentz_transformation_t) :: lt logical :: ok character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT2 = "(1x,A,9(1x,F10.5))" write (u, "(A)") "* Test output: recoil_kinematics_4" write (u, "(A)") "* Purpose: check Lorentz transformation for recoil" write (u, "(A)") sqrts = 100 write (u, FMT1) "sqrts =", sqrts write (u, "(A)") write (u, "(A)") "*** collinear data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = 0 call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, km, qm, qo) call recoil_transformation (sqrts, xc, qo, lt) call show_transformation write (u, "(A)") write (u, "(A)") "*** moderate data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = [0.2_default, 0.05_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, km, qm, qo) call recoil_transformation (sqrts, xc, qo, lt) call show_transformation write (u, "(A)") write (u, "(A)") "* Test output end: recoil_kinematics_4" contains subroutine show_data write (u, FMT1) "sqs_h =", sqrt (xc(1) * xc(2)) * sqrts write (u, FMT1) "xc =", xc write (u, FMT1) "xcb =", xcb write (u, FMT1) "Q =", Q write (u, FMT1) "phi/D =", phi / degree end subroutine show_data subroutine show_transformation type(vector4_t), dimension(2) :: qc type(vector4_t), dimension(2) :: qct real(default), parameter :: tol = 1.e-7_default qc(1) = xc(1) * vector4_moving (sqrts/2, sqrts/2, 3) qc(2) = xc(2) * vector4_moving (sqrts/2,-sqrts/2, 3) qct = lt * qc call pacify (qct, tol) write (u, "(A)") write (u, "(A)") "Momenta: q(os)" call qo(1)%write (u, testflag=.true.) call qo(2)%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "Momenta: LT * qc" call qct(1)%write (u, testflag=.true.) call qct(2)%write (u, testflag=.true.) end subroutine show_transformation end subroutine recoil_kinematics_4 @ %def recoil_kinematics_4 @ \subsubsection{Transformation before recoil} Given a pair of incoming `beam' partons (i.e., before ISR splitting), compute the transformation that transforms their common c.m.\ frame into the lab frame. <>= call test (recoil_kinematics_5, "recoil_kinematics_5", & "initial reference frame", & u, results) <>= public :: recoil_kinematics_5 <>= subroutine recoil_kinematics_5 (u) integer, intent(in) :: u real(default) :: sqrts real(default) :: sqrtsi real(default), dimension(2) :: x type(vector4_t), dimension(2) :: p type(vector4_t), dimension(2) :: pi type(vector4_t), dimension(2) :: p0 type(lorentz_transformation_t) :: lt logical :: ok character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT2 = "(1x,A,9(1x,F10.5))" write (u, "(A)") "* Test output: recoil_kinematics_5" write (u, "(A)") "* Purpose: determine initial Lorentz transformation" write (u, "(A)") sqrts = 100 write (u, FMT1) "sqrts =", sqrts x = [0.6_default, 0.9_default] p(1) = x(1) * vector4_moving (sqrts/2, sqrts/2, 3) p(2) = x(2) * vector4_moving (sqrts/2,-sqrts/2, 3) call show_data call initial_transformation (p, sqrtsi, lt, ok) pi(1) = vector4_moving (sqrtsi/2, sqrtsi/2, 3) pi(2) = vector4_moving (sqrtsi/2,-sqrtsi/2, 3) p0 = inverse (lt) * p call show_momenta write (u, "(A)") write (u, "(A)") "* Test output end: recoil_kinematics_5" contains subroutine show_data write (u, FMT1) "sqrts =", sqrts write (u, FMT1) "x =", x end subroutine show_data subroutine show_momenta real(default), parameter :: tol = 1.e-7_default write (u, "(A)") write (u, "(A)") "* Momenta: p_in(c.m.)" call pi(1)%write (u, testflag=.true.) call pi(2)%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Momenta: inv(LT) * p_in(lab)" call p0(1)%write (u, testflag=.true.) call p0(2)%write (u, testflag=.true.) end subroutine show_momenta end subroutine recoil_kinematics_5 @ %def recoil_kinematics_5 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Transverse momentum for the ISR and EPA approximations} The ISR and EPA handler takes an event with a single radiated collinear particle (photon for ISR, beam particle for EPA) for each beam, respectively, and inserts transverse momentum for both. The four-particle kinematics allows us to generate $Q^2$ and azimuthal angles independently, without violating energy-momentum conservation. The $Q^2$ distribution is logarithmic, as required by the effective particle approximation, and reflected in the inclusive ISR/EPA structure functions. We also conserve the invariant mass of the partonic systm after radiation. The total transverse-momentum kick is applied in form of a Lorentz transformation to the elementary process, both in- and out-particles. In fact, the incoming partons (beam particle for ISR, photon for EPA) which would be virtual space-like in the exact kinematics configuration, are replaced by on-shell incoming partons, such that energy, momentum, and invariant mass $\sqrt{\hat s}$ are conserved. Regarding kinematics, we treat all particles as massless. The beam-particle mass only appears as the parameter [[isr_mass]] or [[epa_mass]], respectively, and cuts off the logarithmic distribution. The upper cutoff is [[isr_q_max]] ([[epa_q_max]]), which defaults to the available energy $\sqrt{s}$. The only differences between ISR and EPA, in this context, are the particle types, and an extra $\bar x$ factor in the lower cutoff for EPA, see below. <<[[isr_epa_handler.f90]]>>= <> module isr_epa_handler <> <> use diagnostics, only: msg_fatal use diagnostics, only: msg_bug use io_units use format_defs, only: FMT_12, FMT_19 use format_utils, only: write_separator use format_utils, only: pac_fmt use physics_defs, only: PHOTON use lorentz, only: vector4_t use lorentz, only: energy use lorentz, only: lorentz_transformation_t use lorentz, only: identity use lorentz, only: inverse use lorentz, only: operator(*) use sm_qcd use flavors, only: flavor_t use particles, only: particle_t use model_data use models use rng_base, only: rng_t use event_transforms use recoil_kinematics, only: initial_transformation use recoil_kinematics, only: generate_recoil use recoil_kinematics, only: recoil_transformation <> <> <> <> contains <> end module isr_epa_handler @ %def isr_epa_handler @ \subsection{Event transform type} Convention: [[beam]] are the incoming partons before ISR -- not necessarily the actual beams, need not be in c.m.\ frame. [[radiated]] are the radiated particles (photon for ISR), and [[parton]] are the remainders which initiate the elementary process. These particles are copied verbatim from the event record, and must be collinear. The kinematical parameters are [[sqrts]] = invariant mass of the [[beam]] particles, [[q_max]] and [[m]] determining the $Q^2$ distribution, and [[xc]]/[[xcb]] as the energy fraction (complement) of the partons, relative to the beams. Transformations: [[lti]] is the Lorentz transformation that would boosts [[pi]] (c.m. frame) back to the original [[beam]] momenta (lab frame). [[lto]] is the recoil transformation, transforming the partons after ISR from the collinear frame to the recoiling frame. [[lt]] is the combination of both, which is to be applied to all particles after the hard interaction. Momenta: [[pi]] are the beams transformed to their common c.m.\ frame. [[ki]] and [[qi]] are the photon/parton momenta in the [[pi]] c.m.\ frame. [[km]] and [[qm]] are the photon/parton momenta with the $Q$ distribution applied, and finally [[qo]] are the partons [[qm]] projected on-shell. <>= public :: evt_isr_epa_t <>= type, extends (evt_t) :: evt_isr_epa_t private integer :: mode = ISR_TRIVIAL_COLLINEAR logical :: isr_active = .false. logical :: epa_active = .false. real(default) :: isr_q_max = 0 real(default) :: epa_q_max = 0 real(default) :: isr_mass = 0 real(default) :: epa_mass = 0 real(default) :: sqrts = 0 integer, dimension(2) :: rad_mode = BEAM_RAD_NONE real(default), dimension(2) :: q_max = 0 real(default), dimension(2) :: m = 0 real(default), dimension(2) :: xc = 0 real(default), dimension(2) :: xcb = 0 type(lorentz_transformation_t) :: lti = identity type(lorentz_transformation_t) :: lto = identity type(lorentz_transformation_t) :: lt = identity integer, dimension(2) :: i_beam = 0 type(particle_t), dimension(2) :: beam type(vector4_t), dimension(2) :: pi integer, dimension(2) :: i_radiated = 0 type(particle_t), dimension(2) :: radiated type(vector4_t), dimension(2) :: ki type(vector4_t), dimension(2) :: km integer, dimension(2) :: i_parton = 0 type(particle_t), dimension(2) :: parton type(vector4_t), dimension(2) :: qi type(vector4_t), dimension(2) :: qm type(vector4_t), dimension(2) :: qo contains <> end type evt_isr_epa_t @ %def evt_isr_epa_t @ \subsection{ISR/EPA distinction} <>= integer, parameter, public :: BEAM_RAD_NONE = 0 integer, parameter, public :: BEAM_RAD_ISR = 1 integer, parameter, public :: BEAM_RAD_EPA = 2 @ %def BEAM_RAD_NONE @ %def BEAM_RAD_ISR @ %def BEAM_RAD_EPA <>= function rad_mode_string (mode) result (string) type(string_t) :: string integer, intent(in) :: mode select case (mode) case (BEAM_RAD_NONE); string = "---" case (BEAM_RAD_ISR); string = "ISR" case (BEAM_RAD_EPA); string = "EPA" case default; string = "???" end select end function rad_mode_string @ %def rad_mode_string @ \subsection{Photon insertion modes} <>= integer, parameter, public :: ISR_TRIVIAL_COLLINEAR = 0 integer, parameter, public :: ISR_PAIR_RECOIL = 1 @ %def ISR_TRIVIAL_COLLINEAR ISR_PAIR_RECOIL @ <>= procedure :: get_mode_string => evt_isr_epa_get_mode_string <>= function evt_isr_epa_get_mode_string (evt) result (string) type(string_t) :: string class(evt_isr_epa_t), intent(in) :: evt select case (evt%mode) case (ISR_TRIVIAL_COLLINEAR) string = "trivial, collinear" case (ISR_PAIR_RECOIL) string = "pair recoil" case default string = "[undefined]" end select end function evt_isr_epa_get_mode_string @ %def evt_isr_epa_get_mode_string @ Set the numerical mode ID from a user-level string representation. <>= procedure :: set_mode_string => evt_isr_epa_set_mode_string <>= subroutine evt_isr_epa_set_mode_string (evt, string) class(evt_isr_epa_t), intent(inout) :: evt type(string_t), intent(in) :: string select case (char (string)) case ("trivial") evt%mode = ISR_TRIVIAL_COLLINEAR case ("recoil") evt%mode = ISR_PAIR_RECOIL case default call msg_fatal ("ISR handler: mode '" // char (string) & // "' is undefined") end select end subroutine evt_isr_epa_set_mode_string @ %def evt_isr_epa_set_mode_string @ \subsection{Output} <>= procedure :: write_name => evt_isr_epa_write_name <>= subroutine evt_isr_epa_write_name (evt, unit) class(evt_isr_epa_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: ISR/EPA handler" end subroutine evt_isr_epa_write_name @ %def evt_isr_epa_write_name @ The overall recoil-handling mode. <>= procedure :: write_mode => evt_isr_epa_write_mode <>= subroutine evt_isr_epa_write_mode (evt, unit) class(evt_isr_epa_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A,1x,I0,':',1x,A)") "Insertion mode =", evt%mode, & char (evt%get_mode_string ()) end subroutine evt_isr_epa_write_mode @ %def evt_isr_epa_write_mode @ The input data for ISR and EPA, respectively. <>= procedure :: write_input => evt_isr_epa_write_input <>= subroutine evt_isr_epa_write_input (evt, unit, testflag) class(evt_isr_epa_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag character(len=7) :: fmt integer :: u u = given_output_unit (unit) call pac_fmt (fmt, FMT_19, FMT_12, testflag) if (evt%isr_active) then write (u, "(3x,A,1x," // fmt // ")") "ISR: Q_max =", evt%isr_q_max write (u, "(3x,A,1x," // fmt // ")") " m =", evt%isr_mass else write (u, "(3x,A)") "ISR: [inactive]" end if if (evt%epa_active) then write (u, "(3x,A,1x," // fmt // ")") "EPA: Q_max =", evt%epa_q_max write (u, "(3x,A,1x," // fmt // ")") " m =", evt%epa_mass else write (u, "(3x,A)") "EPA: [inactive]" end if end subroutine evt_isr_epa_write_input @ %def evt_isr_epa_write_input @ The trivial mode does not depend on any data, since it does nothing to the event. <>= procedure :: write_data => evt_isr_epa_write_data <>= subroutine evt_isr_epa_write_data (evt, unit, testflag) class(evt_isr_epa_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag character(len=7), parameter :: FMTL_19 = "A3,16x" character(len=7), parameter :: FMTL_12 = "A3,9x" character(len=7) :: fmt, fmtl integer :: u u = given_output_unit (unit) call pac_fmt (fmt, FMT_19, FMT_12, testflag) call pac_fmt (fmtl, FMTL_19, FMTL_12, testflag) select case (evt%mode) case (ISR_PAIR_RECOIL) write (u, "(1x,A)") "Event:" write (u, "(3x,A,2(1x," // fmtl // "))") & "mode = ", & char (rad_mode_string (evt%rad_mode(1))), & char (rad_mode_string (evt%rad_mode(2))) write (u, "(3x,A,2(1x," // fmt // "))") "Q_max =", evt%q_max write (u, "(3x,A,2(1x," // fmt // "))") "m =", evt%m write (u, "(3x,A,2(1x," // fmt // "))") "x =", evt%xc write (u, "(3x,A,2(1x," // fmt // "))") "xb =", evt%xcb write (u, "(3x,A,1x," // fmt // ")") "sqrts =", evt%sqrts call write_separator (u) write (u, "(A)") "Lorentz boost (partons before radiation & &c.m. -> lab) =" call evt%lti%write (u, testflag) write (u, "(A)") "Lorentz transformation (collinear partons & &-> partons with recoil in c.m.) =" call evt%lto%write (u, testflag) write (u, "(A)") "Combined transformation (partons & &-> partons with recoil in lab frame) =" call evt%lt%write (u, testflag) end select end subroutine evt_isr_epa_write_data @ %def evt_isr_epa_write_data @ Output method. <>= procedure :: write => evt_isr_epa_write <>= subroutine evt_isr_epa_write (evt, unit, verbose, more_verbose, testflag) class(evt_isr_epa_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag logical :: show_mass integer :: u, i u = given_output_unit (unit) if (present (testflag)) then show_mass = .not. testflag else show_mass = .true. end if call write_separator (u, 2) call evt%write_name (u) call write_separator (u, 2) call evt%write_mode (u) call evt%write_input (u, testflag=testflag) call evt%write_data (u, testflag=testflag) call write_separator (u) call evt%base_write (u, testflag = testflag, show_set = .false.) if (all (evt%i_beam > 0)) then call write_separator (u) write (u, "(A,2(1x,I0))") "Partons before radiation:", evt%i_beam do i = 1, 2 call evt%beam(i)%write (u, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... boosted to c.m.:" do i = 1, 2 call evt%pi(i)%write (u, show_mass=show_mass, testflag=testflag) end do end if if (all (evt%i_radiated > 0)) then call write_separator (u) write (u, "(A,2(1x,I0))") "Radiated particles, collinear:", & evt%i_radiated do i = 1, 2 call evt%radiated(i)%write (u, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... boosted to c.m.:" do i = 1, 2 call evt%ki(i)%write (u, show_mass=show_mass, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... with kT:" do i = 1, 2 call evt%km(i)%write (u, show_mass=show_mass, testflag=testflag) end do end if if (all (evt%i_parton > 0)) then call write_separator (u) write (u, "(A,2(1x,I0))") "Partons after radiation, collinear:", & evt%i_parton do i = 1, 2 call evt%parton(i)%write (u, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... boosted to c.m.:" do i = 1, 2 call evt%qi(i)%write (u, show_mass=show_mass, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... with qT, off-shell:" do i = 1, 2 call evt%qm(i)%write (u, show_mass=show_mass, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... projected on-shell:" do i = 1, 2 call evt%qo(i)%write (u, show_mass=show_mass, testflag=testflag) end do call write_separator (u) end if if (evt%particle_set_exists) & call evt%particle_set%write & (u, summary = .true., compressed = .true., testflag = testflag) call write_separator (u) end subroutine evt_isr_epa_write @ %def evt_isr_epa_write @ \subsection{Initialization} Manually import a random-number generator object. This should be done only for testing purposes. The standard procedure is to [[connect]] a process to an event transform; this will create an appropriate [[rng]] from the RNG factory in the process object. <>= procedure :: import_rng => evt_isr_epa_import_rng <>= subroutine evt_isr_epa_import_rng (evt, rng) class(evt_isr_epa_t), intent(inout) :: evt class(rng_t), allocatable, intent(inout) :: rng call move_alloc (from = rng, to = evt%rng) end subroutine evt_isr_epa_import_rng @ %def evt_isr_epa_import_rng @ Set constant kinematics limits and initialize for ISR. Note that [[sqrts]] is used only as the fallback value for [[q_max]]. The actual [[sqrts]] value for the transform object is inferred from the incoming particles, event by event. <>= procedure :: set_data_isr => evt_isr_epa_set_data_isr <>= subroutine evt_isr_epa_set_data_isr (evt, sqrts, q_max, m) class(evt_isr_epa_t), intent(inout) :: evt real(default), intent(in) :: sqrts real(default), intent(in) :: q_max real(default), intent(in) :: m if (sqrts <= 0) then call msg_fatal ("ISR handler: sqrts value must be positive") end if if (q_max <= 0 .or. q_max > sqrts) then evt%isr_q_max = sqrts else evt%isr_q_max = q_max end if if (m > 0) then evt%isr_mass = m else call msg_fatal ("ISR handler: ISR_mass value must be positive") end if evt%isr_active = .true. end subroutine evt_isr_epa_set_data_isr @ %def evt_isr_epa_set_data_isr @ Set constant kinematics limits and initialize for EPA. Note that [[sqrts]] is used only as the fallback value for [[q_max]]. The actual [[sqrts]] value for the transform object is inferred from the incoming particles, event by event. <>= procedure :: set_data_epa => evt_isr_epa_set_data_epa <>= subroutine evt_isr_epa_set_data_epa (evt, sqrts, q_max, m) class(evt_isr_epa_t), intent(inout) :: evt real(default), intent(in) :: sqrts real(default), intent(in) :: q_max real(default), intent(in) :: m if (sqrts <= 0) then call msg_fatal ("EPA handler: sqrts value must be positive") end if if (q_max <= 0 .or. q_max > sqrts) then evt%epa_q_max = sqrts else evt%epa_q_max = q_max end if if (m > 0) then evt%epa_mass = m else call msg_fatal ("EPA handler: EPA_mass value must be positive") end if evt%epa_active = .true. end subroutine evt_isr_epa_set_data_epa @ %def evt_isr_epa_set_data_epa @ \subsection{Fetch event data} Identify the radiated particles and the recoil momenta in the particle set. Without much sophistication, start from the end and find particles with the ``remnant'' status. Their parents should point to the recoiling parton. If successful, set the particle indices in the [[evt]] object, for further processing. <>= procedure, private :: identify_radiated <>= subroutine identify_radiated (evt) class(evt_isr_epa_t), intent(inout) :: evt integer :: i, k k = 2 FIND_LAST_RADIATED: do i = evt%particle_set%get_n_tot (), 1, -1 associate (prt => evt%particle_set%prt(i)) if (prt%is_beam_remnant ()) then evt%i_radiated(k) = i evt%radiated(k) = prt k = k - 1 if (k == 0) exit FIND_LAST_RADIATED end if end associate end do FIND_LAST_RADIATED if (k /= 0) call err_count contains subroutine err_count call evt%particle_set%write () call msg_fatal ("ISR/EPA handler: & &event does not contain two radiated particles") end subroutine err_count end subroutine identify_radiated @ %def identify_radiated @ When the radiated particles are known, we can fetch their parent particles and ask for the other child, the incoming parton. <>= procedure, private :: identify_partons <>= subroutine identify_partons (evt) class(evt_isr_epa_t), intent(inout) :: evt integer, dimension(:), allocatable :: parent, child integer :: i, j if (all (evt%i_radiated > 0)) then do i = 1, 2 parent = evt%radiated(i)%get_parents () if (size (parent) /= 1) call err_mismatch evt%i_beam(i) = parent(1) evt%beam(i) = evt%particle_set%prt(parent(1)) associate (prt => evt%beam(i)) child = prt%get_children () if (size (child) /= 2) call err_mismatch do j = 1, 2 if (child(j) /= evt%i_radiated(i)) then evt%i_parton(i) = child(j) evt%parton(i) = evt%particle_set%prt(child(j)) end if end do end associate end do end if contains subroutine err_mismatch call evt%particle_set%write () call msg_bug ("ISR/EPA handler: mismatch in parent-child relations") end subroutine err_mismatch end subroutine identify_partons @ %def identify_partons @ Check whether the radiated particle is a photon, or the incoming parton is a photon. Then set the ISR/EPA switch appropriately, for each beam. <>= procedure :: check_radiation => evt_isr_epa_check_radiation <>= subroutine evt_isr_epa_check_radiation (evt) class(evt_isr_epa_t), intent(inout) :: evt type(flavor_t) :: flv integer :: i do i = 1, 2 flv = evt%radiated(i)%get_flv () if (flv%get_pdg () == PHOTON) then if (evt%isr_active) then evt%rad_mode(i) = BEAM_RAD_ISR else call err_isr_init end if else flv = evt%parton(i)%get_flv () if (flv%get_pdg () == PHOTON) then if (evt%epa_active) then evt%rad_mode(i) = BEAM_RAD_EPA else call err_epa_init end if else call err_no_photon end if end if end do contains subroutine err_isr_init call evt%particle_set%write () call msg_fatal ("ISR/EPA handler: & &event contains radiated photon, but ISR is not initialized") end subroutine err_isr_init subroutine err_epa_init call evt%particle_set%write () call msg_fatal ("ISR/EPA handler: & &event contains incoming photon, but EPA is not initialized") end subroutine err_epa_init subroutine err_no_photon call evt%particle_set%write () call msg_fatal ("ISR/EPA handler: & &event does not appear to be ISR or EPA - missing photon") end subroutine err_no_photon end subroutine evt_isr_epa_check_radiation @ %def evt_isr_epa_check_radiation @ Internally set the appropriate parameters (ISR/EPA) for the two beams in the recoil mode. <>= procedure :: set_recoil_parameters => evt_isr_epa_set_recoil_parameters <>= subroutine evt_isr_epa_set_recoil_parameters (evt) class(evt_isr_epa_t), intent(inout) :: evt integer :: i do i = 1, 2 select case (evt%rad_mode(i)) case (BEAM_RAD_ISR) evt%q_max(i) = evt%isr_q_max evt%m(i) = evt%isr_mass case (BEAM_RAD_EPA) evt%q_max(i) = evt%epa_q_max evt%m(i) = evt%epa_mass end select end do end subroutine evt_isr_epa_set_recoil_parameters @ %def evt_isr_epa_set_recoil_parameters @ Boost the particles that participate in ISR to their proper c.m.\ frame, copying the momenta to [[pi]], [[ki]], [[qi]]. Also assign [[sqrts]] properly. <>= procedure, private :: boost_to_cm <>= subroutine boost_to_cm (evt) class(evt_isr_epa_t), intent(inout) :: evt type(vector4_t), dimension(2) :: p type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q logical :: ok p = evt%beam%get_momentum () k = evt%radiated%get_momentum () q = evt%parton%get_momentum () call initial_transformation (p, evt%sqrts, evt%lti, ok) if (.not. ok) call err_non_collinear evt%pi = inverse (evt%lti) * p evt%ki = inverse (evt%lti) * k evt%qi = inverse (evt%lti) * q contains subroutine err_non_collinear call evt%particle_set%write () call msg_fatal ("ISR/EPA handler: & &partons before radiation are not collinear") end subroutine err_non_collinear end subroutine boost_to_cm @ %def boost_to_cm @ We can infer the $x$ and $\bar x$ values of the event by looking at the energy fractions of the radiated particles and incoming partons, respectively, relative to their parents. Of course, we must assume that they are all collinear, and that energy is conserved. <>= procedure, private :: infer_x <>= subroutine infer_x (evt) class(evt_isr_epa_t), intent(inout) :: evt real(default) :: E_parent, E_radiated, E_parton integer :: i if (all (evt%i_radiated > 0)) then do i = 1, 2 E_parent = energy (evt%pi(i)) E_radiated = energy (evt%ki(i)) E_parton = energy (evt%qi(i)) if (E_parent > 0) then evt%xc(i) = E_parton / E_parent evt%xcb(i)= E_radiated / E_parent else call err_energy end if end do end if contains subroutine err_energy call evt%particle_set%write () call msg_bug ("ISR/EPA handler: non-positive energy in splitting") end subroutine err_energy end subroutine infer_x @ %def infer_x @ \subsection{Two-parton recoil} For transforming partons into recoil momenta, we make use of the routines in the [[recoil_kinematics]] module. In addition to the collinear momenta, we use the $x$ energy fractions, and four numbers from the RNG. There is one subtle difference w.r.t.\ ISR case: the EPA mass parameter is multiplied by the energy fraction $x$, separately for each beam. This is the effective lower $Q$ cutoff. For certain kinematics, close to the $Q_\text{max}$ endpoint, this may fail, and [[ok]] is set to false. In that case, we should generate new recoil momenta for the same event. This is handled by the generic unweighting procedure. <>= procedure, private :: generate_recoil => evt_generate_recoil <>= subroutine evt_generate_recoil (evt, ok) class(evt_isr_epa_t), intent(inout) :: evt logical, intent(out) :: ok real(default), dimension(4) :: r real(default), dimension(2) :: m integer :: i call evt%rng%generate (r) do i = 1, 2 select case (evt%rad_mode(i)) case (BEAM_RAD_ISR); m(i) = evt%m(i) case (BEAM_RAD_EPA); m(i) = evt%xc(i) * evt%m(i) case default; m(i) = 0 end select end do call generate_recoil (evt%sqrts, evt%q_max, m, evt%xc, evt%xcb, r, & evt%km, evt%qm, evt%qo, ok) end subroutine evt_generate_recoil @ %def evt_generate_recoil @ Replace the collinear radiated (incoming) parton momenta by the momenta that we have generated, respectively. Recall that the recoil has been applied in the c.m.\ system of the partons before ISR, so we apply the stored Lorentz transformation to boost them to the lab frame. <>= procedure, private :: replace_radiated procedure, private :: replace_partons <>= subroutine replace_radiated (evt) class(evt_isr_epa_t), intent(inout) :: evt integer :: i do i = 1, 2 associate (prt => evt%particle_set%prt(evt%i_radiated(i))) call prt%set_momentum (evt%lti * evt%km(i)) end associate end do end subroutine replace_radiated subroutine replace_partons (evt) class(evt_isr_epa_t), intent(inout) :: evt integer :: i do i = 1, 2 associate (prt => evt%particle_set%prt(evt%i_parton(i))) call prt%set_momentum (evt%lti * evt%qo(i)) end associate end do end subroutine replace_partons @ %def replace_radiated @ %def replace_partons @ \subsection{Transform the event} Knowing the new incoming partons for the elementary process, we can make use of another procedure in [[recoil_kinematics]] to determine the Lorentz transformation that transforms the collinear frame into the frame with transverse momentum. We apply this transformation, recursively, to all particles that originate from those incoming partons in the original particle set. We have to allow for the pre-ISR partons being not in their common c.m.\ frame. Taking into account non-commutativity, we actually have to first transform the outgoing particles to that c.m.\ frame, then apply the recoil transformation, then boost back to the lab frame. The [[mask]] keep track of particles that we transform, just in case the parent-child tree is multiply connected. <>= procedure :: transform_outgoing => evt_transform_outgoing <>= subroutine evt_transform_outgoing (evt) class(evt_isr_epa_t), intent(inout) :: evt logical, dimension(:), allocatable :: mask call recoil_transformation (evt%sqrts, evt%xc, evt%qo, evt%lto) evt%lt = evt%lti * evt%lto * inverse (evt%lti) allocate (mask (evt%particle_set%get_n_tot ()), source=.false.) call transform_children (evt%i_parton(1)) contains recursive subroutine transform_children (i) integer, intent(in) :: i integer :: j, n_child, c integer, dimension(:), allocatable :: child child = evt%particle_set%prt(i)%get_children () do j = 1, size (child) c = child(j) if (.not. mask(c)) then associate (prt => evt%particle_set%prt(c)) call prt%set_momentum (evt%lt * prt%get_momentum ()) mask(c) = .true. call transform_children (c) end associate end if end do end subroutine transform_children end subroutine evt_transform_outgoing @ %def evt_transform_outgoing @ \subsection{Implemented methods} Here we take the particle set from the previous event transform and copy it, then generate the transverse momentum for the radiated particles and for the incoming partons. If this fails (rarely, for large $p_T$), return zero for the probability, to trigger another try. NOTE: The boost for the initial partonic system, if not in the c.m.\ frame, has not been implemented yet. <>= procedure :: generate_weighted => & evt_isr_epa_generate_weighted <>= subroutine evt_isr_epa_generate_weighted (evt, probability) class(evt_isr_epa_t), intent(inout) :: evt real(default), intent(inout) :: probability logical :: valid call evt%particle_set%final () evt%particle_set = evt%previous%particle_set evt%particle_set_exists = .true. select case (evt%mode) case (ISR_TRIVIAL_COLLINEAR) probability = 1 valid = .true. case (ISR_PAIR_RECOIL) call evt%identify_radiated () call evt%identify_partons () call evt%check_radiation () call evt%set_recoil_parameters () call evt%boost_to_cm () call evt%infer_x () call evt%generate_recoil (valid) if (valid) then probability = 1 else probability = 0 end if case default call msg_bug ("ISR/EPA handler: generate weighted: unsupported mode") end select evt%particle_set_exists = .false. end subroutine evt_isr_epa_generate_weighted @ %def evt_isr_epa_generate_weighted @ Insert the generated radiated particles and incoming partons with $p_T$ in their respective places. The factorization parameters are irrelevant. <>= procedure :: make_particle_set => & evt_isr_epa_make_particle_set <>= subroutine evt_isr_epa_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_isr_epa_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r select case (evt%mode) case (ISR_TRIVIAL_COLLINEAR) case (ISR_PAIR_RECOIL) call evt%replace_radiated () call evt%replace_partons () call evt%transform_outgoing () case default call msg_bug ("ISR/EPA handler: make particle set: unsupported mode") end select evt%particle_set_exists = .true. end subroutine evt_isr_epa_make_particle_set @ %def event_isr_epa_handler_make_particle_set @ <>= procedure :: prepare_new_event => & evt_isr_epa_prepare_new_event <>= subroutine evt_isr_epa_prepare_new_event (evt, i_mci, i_term) class(evt_isr_epa_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () end subroutine evt_isr_epa_prepare_new_event @ %def evt_isr_epa_prepare_new_event @ \subsection{Unit tests: ISR} Test module, followed by the corresponding implementation module. This test module differs from most of the other test modules, since it contains two test subroutines: one for ISR and one for EPA below. <<[[isr_epa_handler_ut.f90]]>>= <> module isr_epa_handler_ut use unit_tests use isr_epa_handler_uti <> <> contains <> end module isr_epa_handler_ut @ %def isr_epa_handler_ut @ <<[[isr_epa_handler_uti.f90]]>>= <> module isr_epa_handler_uti <> <> use format_utils, only: write_separator use os_interface use lorentz, only: vector4_t, vector4_moving, operator(*) use rng_base, only: rng_t use models, only: syntax_model_file_init, syntax_model_file_final use models, only: model_list_t, model_t use particles, only: particle_set_t use event_transforms use isr_epa_handler, only: evt_isr_epa_t use rng_base_ut, only: rng_test_t <> <> contains <> end module isr_epa_handler_uti @ %def isr_epa_handler_uti @ API: driver for the unit tests below. <>= public :: isr_handler_test <>= subroutine isr_handler_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine isr_handler_test @ %def isr_handler_test @ \subsubsection{Trivial case} Handle photons resulting from ISR radiation. This test is for the trivial case where the event is kept collinear. <>= call test (isr_handler_1, "isr_handler_1", & "collinear case, no modification", & u, results) <>= public :: isr_handler_1 <>= subroutine isr_handler_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x, xb real(default) :: probability write (u, "(A)") "* Test output: isr_handler_1" write (u, "(A)") "* Purpose: apply photon handler trivially (no-op)" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 11, -11, 22, 22, 13, -13], model = model) sqrts = 100._default x = [0.6_default, 0.9_default] xb= 1 - x p(1) = vector4_moving (sqrts/2, sqrts/2, 3) p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize ISR handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%write (u) write (u, "(A)") write (u, "(A)") "* Fill ISR handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: isr_handler_1" end subroutine isr_handler_1 @ %def isr_handler_1 @ \subsubsection{Photon pair with recoil} Handle photons resulting from ISR radiation. This test invokes the two-photon recoil mechanism. Both photons acquire transverse momentum, the parton momenta recoil, such that total energy-momentum is conserved, and all outgoing photons and partons are on-shell (massless). <>= call test (isr_handler_2, "isr_handler_2", & "two-photon recoil", & u, results) <>= public :: isr_handler_2 <>= subroutine isr_handler_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x, xb class(rng_t), allocatable :: rng real(default) :: probability write (u, "(A)") "* Test output: isr_handler_2" write (u, "(A)") "* Purpose: apply photon handler with two-photon recoil" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 11, -11, 22, 22, 13, -13], model = model) sqrts = 100._default x = [0.6_default, 0.9_default] xb= 1 - x p(1) = vector4_moving (sqrts/2, sqrts/2, 3) p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize ISR handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%set_mode_string (var_str ("recoil")) call evt_isr_epa%set_data_isr ( & sqrts = sqrts, & q_max = sqrts, & m = 511.e-3_default & ) allocate (rng_test_t :: rng) call rng%init (3) ! default would produce pi for azimuthal angle call evt_isr_epa%import_rng (rng) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill ISR handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: isr_handler_2" end subroutine isr_handler_2 @ %def isr_handler_2 @ \subsubsection{Boosted beams} Handle photons resulting from ISR radiation. This test invokes the two-photon recoil mechanism, in the case that the partons before ISR are not in their c.m.\ frame (but collinear). <>= call test (isr_handler_3, "isr_handler_3", & "two-photon recoil with boost", & u, results) <>= public :: isr_handler_3 <>= subroutine isr_handler_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x0 real(default), dimension(2) :: x, xb class(rng_t), allocatable :: rng real(default) :: probability write (u, "(A)") "* Test output: isr_handler_3" write (u, "(A)") "* Purpose: apply photon handler for boosted beams & &and two-photon recoil" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 11, -11, 22, 22, 13, -13], model = model) write (u, "(A)") "* Event data" write (u, "(A)") sqrts = 100._default write (u, "(A,2(1x,F12.7))") "sqrts =", sqrts x0 = [0.9_default, 0.4_default] write (u, "(A,2(1x,F12.7))") "x0 =", x0 write (u, "(A)") write (u, "(A,2(1x,F12.7))") "sqs_hat =", sqrts * sqrt (product (x0)) x = [0.6_default, 0.9_default] xb= 1 - x write (u, "(A,2(1x,F12.7))") "x =", x write (u, "(A)") write (u, "(A,2(1x,F12.7))") "x0 * x =", x0 * x p(1) = x0(1) * vector4_moving (sqrts/2, sqrts/2, 3) p(2) = x0(2) * vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize ISR handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%set_mode_string (var_str ("recoil")) call evt_isr_epa%set_data_isr ( & sqrts = sqrts, & q_max = sqrts, & m = 511.e-3_default & ) allocate (rng_test_t :: rng) call rng%init (3) ! default would produce pi for azimuthal angle call evt_isr_epa%import_rng (rng) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill ISR handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: isr_handler_3" end subroutine isr_handler_3 @ %def isr_handler_3 @ \subsection{Unit tests: EPA} API: Extra driver for the unit tests below. <>= public :: epa_handler_test <>= subroutine epa_handler_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine epa_handler_test @ %def epa_handler_test @ \subsubsection{Trivial case} Handle events resulting from the EPA approximation. This test is for the trivial case where the event is kept collinear. <>= call test (epa_handler_1, "epa_handler_1", & "collinear case, no modification", & u, results) <>= public :: epa_handler_1 <>= subroutine epa_handler_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x, xb real(default) :: probability write (u, "(A)") "* Test output: epa_handler_1" write (u, "(A)") "* Purpose: apply beam handler trivially (no-op)" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct & (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 22, 22, 11, -11, 13, -13], & model = model) sqrts = 100._default x = [0.6_default, 0.9_default] xb= 1 - x p(1) = vector4_moving (sqrts/2, sqrts/2, 3) p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize EPA handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%write (u) write (u, "(A)") write (u, "(A)") "* Fill EPA handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: epa_handler_1" end subroutine epa_handler_1 @ %def epa_handler_1 @ \subsubsection{Beam pair with recoil} Handle beams resulting from the EPA approximation. This test invokes the two-beam recoil mechanism. Both beam remnants acquire transverse momentum, the photon momenta recoil, such that total energy-momentum is conserved, and all outgoing beam remnants and photons are on-shell (massless). <>= call test (epa_handler_2, "epa_handler_2", & "two-beam recoil", & u, results) <>= public :: epa_handler_2 <>= subroutine epa_handler_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x, xb class(rng_t), allocatable :: rng real(default) :: probability write (u, "(A)") "* Test output: epa_handler_2" write (u, "(A)") "* Purpose: apply beam handler with two-beam recoil" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 22, 22, 11, -11, 13, -13], model = model) sqrts = 100._default x = [0.6_default, 0.9_default] xb= 1 - x p(1) = vector4_moving (sqrts/2, sqrts/2, 3) p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize EPA handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%set_mode_string (var_str ("recoil")) call evt_isr_epa%set_data_epa ( & sqrts = sqrts, & q_max = sqrts, & m = 511.e-3_default & ) allocate (rng_test_t :: rng) call rng%init (3) ! default would produce pi for azimuthal angle call evt_isr_epa%import_rng (rng) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill EPA handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: epa_handler_2" end subroutine epa_handler_2 @ %def epa_handler_2 @ \subsubsection{Boosted beams} Handle radiated beam remnants resulting from EPA radiation. This test invokes the two-beam recoil mechanism, in the case that the partons before EPA are not in their c.m.\ frame (but collinear). <>= call test (epa_handler_3, "epa_handler_3", & "two-beam recoil with boost", & u, results) <>= public :: epa_handler_3 <>= subroutine epa_handler_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x0 real(default), dimension(2) :: x, xb class(rng_t), allocatable :: rng real(default) :: probability write (u, "(A)") "* Test output: epa_handler_3" write (u, "(A)") "* Purpose: apply beam handler for boosted beams & &and two-beam recoil" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 22, 22, 11, -11, 13, -13], model = model) write (u, "(A)") "* Event data" write (u, "(A)") sqrts = 100._default write (u, "(A,2(1x,F12.7))") "sqrts =", sqrts x0 = [0.9_default, 0.4_default] write (u, "(A,2(1x,F12.7))") "x0 =", x0 write (u, "(A)") write (u, "(A,2(1x,F12.7))") "sqs_hat =", sqrts * sqrt (product (x0)) x = [0.6_default, 0.9_default] xb= 1 - x write (u, "(A,2(1x,F12.7))") "x =", x write (u, "(A)") write (u, "(A,2(1x,F12.7))") "x0 * x =", x0 * x p(1) = x0(1) * vector4_moving (sqrts/2, sqrts/2, 3) p(2) = x0(2) * vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize EPA handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%set_mode_string (var_str ("recoil")) call evt_isr_epa%set_data_epa ( & sqrts = sqrts, & q_max = sqrts, & m = 511.e-3_default & ) allocate (rng_test_t :: rng) call rng%init (3) ! default would produce pi for azimuthal angle call evt_isr_epa%import_rng (rng) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill EPA handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: epa_handler_3" end subroutine epa_handler_3 @ %def epa_handler_3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Decays} <<[[decays.f90]]>>= <> module decays <> <> use io_units use format_utils, only: write_indent, write_separator use format_defs, only: FMT_15 use numeric_utils use diagnostics use flavors use helicities use quantum_numbers use interactions use evaluators use variables, only: var_list_t use model_data use rng_base use selectors use parton_states use process, only: process_t use instances, only: process_instance_t, pacify use process_stacks use event_transforms <> <> <> <> contains <> end module decays @ %def decays @ \subsection{Final-State Particle Configuration} A final-state particle may be either stable or unstable. Here is an empty abstract type as the parent of both, with holds just the flavor information. <>= type, abstract :: any_config_t private contains <> end type any_config_t @ %def any_config_t @ Finalizer, depends on the implementation. <>= procedure (any_config_final), deferred :: final <>= interface subroutine any_config_final (object) import class(any_config_t), intent(inout) :: object end subroutine any_config_final end interface @ %def any_config_final @ The output is also deferred: <>= procedure (any_config_write), deferred :: write <>= interface subroutine any_config_write (object, unit, indent, verbose) import class(any_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose end subroutine any_config_write end interface @ %def any_config_write @ This is a container for a stable or unstable particle configurator. We need this wrapper for preparing arrays that mix stable and unstable particles. <>= type :: particle_config_t private class(any_config_t), allocatable :: c end type particle_config_t @ %def particle_config_t @ \subsection{Final-State Particle} In theory, for the particle instance we only need to consider the unstable case. However, it is more straightforward to treat configuration and instance on the same footing, and to introduce a wrapper for particle objects as above. This also works around a compiler bug in gfortran. <>= type, abstract :: any_t private contains <> end type any_t @ %def any_t @ Finalizer, depends on the implementation. <>= procedure (any_final), deferred :: final <>= interface subroutine any_final (object) import class(any_t), intent(inout) :: object end subroutine any_final end interface @ %def any_final @ The output is also deferred: <>= procedure (any_write), deferred :: write <>= interface subroutine any_write (object, unit, indent) import class(any_t), intent(in) :: object integer, intent(in), optional :: unit, indent end subroutine any_write end interface @ %def any_write @ This is a container for a stable or unstable outgoing particle. We need this wrapper for preparing arrays that mix stable and unstable particles. <>= type :: particle_out_t private class(any_t), allocatable :: c end type particle_out_t @ %def particle_config_t @ \subsection{Decay Term Configuration} A decay term is a distinct final state, corresponding to a process term. Each decay process may give rise to several terms with, possibly, differing flavor content. <>= type :: decay_term_config_t private type(particle_config_t), dimension(:), allocatable :: prt contains <> end type decay_term_config_t @ %def decay_term_config_t @ Finalizer, recursive. <>= procedure :: final => decay_term_config_final <>= recursive subroutine decay_term_config_final (object) class(decay_term_config_t), intent(inout) :: object integer :: i if (allocated (object%prt)) then do i = 1, size (object%prt) if (allocated (object%prt(i)%c)) call object%prt(i)%c%final () end do end if end subroutine decay_term_config_final @ %def decay_term_config_final @ Output, with optional indentation <>= procedure :: write => decay_term_config_write <>= recursive subroutine decay_term_config_write (object, unit, indent, verbose) class(decay_term_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: i, j, u, ind logical :: verb u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent verb = .true.; if (present (verbose)) verb = verbose call write_indent (u, ind) write (u, "(1x,A)", advance="no") "Final state:" do i = 1, size (object%prt) select type (prt_config => object%prt(i)%c) type is (stable_config_t) write (u, "(1x,A)", advance="no") & char (prt_config%flv(1)%get_name ()) do j = 2, size (prt_config%flv) write (u, "(':',A)", advance="no") & char (prt_config%flv(j)%get_name ()) end do type is (unstable_config_t) write (u, "(1x,A)", advance="no") & char (prt_config%flv%get_name ()) end select end do write (u, *) if (verb) then do i = 1, size (object%prt) call object%prt(i)%c%write (u, ind) end do end if end subroutine decay_term_config_write @ %def decay_term_config_write @ Initialize, given a set of flavors. For each flavor, we must indicate whether the particle is stable. The second index of the flavor array runs over alternatives for each decay product; alternatives are allowed only if the decay product is itself stable. <>= procedure :: init => decay_term_config_init <>= recursive subroutine decay_term_config_init & (term, flv, stable, model, process_stack, var_list) class(decay_term_config_t), intent(out) :: term type(flavor_t), dimension(:,:), intent(in) :: flv logical, dimension(:), intent(in) :: stable class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(var_list_t), intent(in), optional :: var_list type(string_t), dimension(:), allocatable :: decay integer :: i allocate (term%prt (size (flv, 1))) do i = 1, size (flv, 1) associate (prt => term%prt(i)) if (stable(i)) then allocate (stable_config_t :: prt%c) else allocate (unstable_config_t :: prt%c) end if select type (prt_config => prt%c) type is (stable_config_t) call prt_config%init (flv(i,:)) type is (unstable_config_t) if (all (flv(i,:) == flv(i,1))) then call prt_config%init (flv(i,1)) call flv(i,1)%get_decays (decay) call prt_config%init_decays & (decay, model, process_stack, var_list) else call prt_config%write () call msg_fatal ("Decay configuration: & &unstable product must be unique") end if end select end associate end do end subroutine decay_term_config_init @ %def decay_term_config_init @ Recursively compute widths and branching ratios for all unstable particles. <>= procedure :: compute => decay_term_config_compute <>= recursive subroutine decay_term_config_compute (term) class(decay_term_config_t), intent(inout) :: term integer :: i do i = 1, size (term%prt) select type (unstable_config => term%prt(i)%c) type is (unstable_config_t) call unstable_config%compute () end select end do end subroutine decay_term_config_compute @ %def decay_term_config_compute @ \subsection{Decay Term} A decay term instance is selected when we generate an event for the associated process instance. When evaluated, it triggers further decays down the chain. Only unstable products are allocated as child particles. <>= type :: decay_term_t private type(decay_term_config_t), pointer :: config => null () type(particle_out_t), dimension(:), allocatable :: particle_out contains <> end type decay_term_t @ %def decay_term_t @ Finalizer. <>= procedure :: final => decay_term_final <>= recursive subroutine decay_term_final (object) class(decay_term_t), intent(inout) :: object integer :: i if (allocated (object%particle_out)) then do i = 1, size (object%particle_out) call object%particle_out(i)%c%final () end do end if end subroutine decay_term_final @ %def decay_term_final @ Output. <>= procedure :: write => decay_term_write <>= recursive subroutine decay_term_write (object, unit, indent) class(decay_term_t), intent(in) :: object integer, intent(in), optional :: unit, indent integer :: i, u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call object%config%write (u, ind, verbose = .false.) do i = 1, size (object%particle_out) call object%particle_out(i)%c%write (u, ind) end do end subroutine decay_term_write @ %def decay_term_write @ Recursively write the embedded process instances. <>= procedure :: write_process_instances => decay_term_write_process_instances <>= recursive subroutine decay_term_write_process_instances (term, unit, verbose) class(decay_term_t), intent(in) :: term integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call unstable%write_process_instances (unit, verbose) end select end do end subroutine decay_term_write_process_instances @ %def decay_term_write_process_instances @ Initialization, using the configuration object. We allocate particle objects in parallel to the particle configuration objects which we use to initialize them, one at a time. <>= procedure :: init => decay_term_init <>= recursive subroutine decay_term_init (term, config) class(decay_term_t), intent(out) :: term type(decay_term_config_t), intent(in), target :: config integer :: i term%config => config allocate (term%particle_out (size (config%prt))) do i = 1, size (config%prt) select type (prt_config => config%prt(i)%c) type is (stable_config_t) allocate (stable_t :: term%particle_out(i)%c) select type (stable => term%particle_out(i)%c) type is (stable_t) call stable%init (prt_config) end select type is (unstable_config_t) allocate (unstable_t :: term%particle_out(i)%c) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call unstable%init (prt_config) end select end select end do end subroutine decay_term_init @ %def decay_term_init @ Implement a RNG instance, spawned by the process object. <>= procedure :: make_rng => decay_term_make_rng <>= subroutine decay_term_make_rng (term, process) class(decay_term_t), intent(inout) :: term type(process_t), intent(inout) :: process class(rng_t), allocatable :: rng integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call process%make_rng (rng) call unstable%import_rng (rng) end select end do end subroutine decay_term_make_rng @ %def decay_term_make_rng @ Link the interactions for unstable decay products to the interaction of the parent process. <>= procedure :: link_interactions => decay_term_link_interactions <>= recursive subroutine decay_term_link_interactions (term, trace) class(decay_term_t), intent(inout) :: term type(interaction_t), intent(in), target :: trace integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call unstable%link_interactions (i, trace) end select end do end subroutine decay_term_link_interactions @ %def decay_term_link_interactions @ Recursively generate a decay chain, for each of the unstable particles in the final state. <>= procedure :: select_chain => decay_term_select_chain <>= recursive subroutine decay_term_select_chain (term) class(decay_term_t), intent(inout) :: term integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call unstable%select_chain () end select end do end subroutine decay_term_select_chain @ %def decay_term_select_chain @ Recursively generate a decay event, for each of the unstable particles in the final state. <>= procedure :: generate => decay_term_generate <>= recursive subroutine decay_term_generate (term) class(decay_term_t), intent(inout) :: term integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call unstable%generate () end select end do end subroutine decay_term_generate @ %def decay_term_generate @ \subsection{Decay Root Configuration} At the root of a decay chain, there is a parent process. The decay root stores a pointer to the parent process and the set of decay configurations. <>= public :: decay_root_config_t <>= type :: decay_root_config_t private type(string_t) :: process_id type(process_t), pointer :: process => null () class(model_data_t), pointer :: model => null () type(decay_term_config_t), dimension(:), allocatable :: term_config contains <> end type decay_root_config_t @ %def decay_root_config_t @ The finalizer is recursive since there may be cascade decays. <>= procedure :: final => decay_root_config_final <>= recursive subroutine decay_root_config_final (object) class(decay_root_config_t), intent(inout) :: object integer :: i if (allocated (object%term_config)) then do i = 1, size (object%term_config) call object%term_config(i)%final () end do end if end subroutine decay_root_config_final @ %def decay_root_config_final @ The output routine is also recursive, and it contains an adjustable indentation. <>= procedure :: write => decay_root_config_write procedure :: write_header => decay_root_config_write_header procedure :: write_terms => decay_root_config_write_terms <>= recursive subroutine decay_root_config_write (object, unit, indent, verbose) class(decay_root_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) write (u, "(1x,A)") "Final-state decay tree:" call object%write_header (unit, indent) call object%write_terms (unit, indent, verbose) end subroutine decay_root_config_write subroutine decay_root_config_write_header (object, unit, indent) class(decay_root_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) if (associated (object%process)) then write (u, 3) "process ID =", char (object%process_id), "*" else write (u, 3) "process ID =", char (object%process_id) end if 3 format (3x,A,2(1x,A)) end subroutine decay_root_config_write_header recursive subroutine decay_root_config_write_terms & (object, unit, indent, verbose) class(decay_root_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: i, u, ind logical :: verb u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent verb = .true.; if (present (verbose)) verb = verbose if (verb .and. allocated (object%term_config)) then do i = 1, size (object%term_config) call object%term_config(i)%write (u, ind + 1) end do end if end subroutine decay_root_config_write_terms @ %def decay_root_config_write @ Initialize for a named process and (optionally) a pre-determined number of terms. <>= procedure :: init => decay_root_config_init <>= subroutine decay_root_config_init (decay, model, process_id, n_terms) class(decay_root_config_t), intent(out) :: decay class(model_data_t), intent(in), target :: model type(string_t), intent(in) :: process_id integer, intent(in), optional :: n_terms decay%model => model decay%process_id = process_id if (present (n_terms)) then allocate (decay%term_config (n_terms)) end if end subroutine decay_root_config_init @ %def decay_root_config_init @ Declare a decay term, given an array of flavors. <>= procedure :: init_term => decay_root_config_init_term <>= recursive subroutine decay_root_config_init_term & (decay, i, flv, stable, model, process_stack, var_list) class(decay_root_config_t), intent(inout) :: decay integer, intent(in) :: i type(flavor_t), dimension(:,:), intent(in) :: flv logical, dimension(:), intent(in) :: stable class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(var_list_t), intent(in), optional, target :: var_list call decay%term_config(i)%init (flv, stable, model, process_stack, var_list) end subroutine decay_root_config_init_term @ %def decay_root_config_init_term @ Connect the decay root configuration with a process object (which should represent the parent process). This includes initialization, therefore intent(out). The flavor state is retrieved from the process term object. However, we have to be careful: the flavor object points to the model instance that is stored in the process object. This model instance may not contain the current setting for unstable particles and decay. Therefore, we assign the model directly. If the [[process_instance]] argument is provided, we use this for the flavor state. This applies to the decay root only, where the process can be entangled with a beam setup, and the latter contains beam remnants as further outgoing particles. These must be included in the set of outgoing flavors, since the decay application is also done on the connected state. Infer stability from the particle properties, using the first row in the set of flavor states. For unstable particles, we look for decays, recursively, available from the process stack (if present). For the unstable particles, we have to check whether their masses match between the production and the decay. Fortunately, both versions are available for comparison. The optional [[var_list]] argument may override integral/error values for decay processes. <>= procedure :: connect => decay_root_config_connect <>= recursive subroutine decay_root_config_connect & (decay, process, model, process_stack, process_instance, var_list) class(decay_root_config_t), intent(out) :: decay type(process_t), intent(in), target :: process class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(process_instance_t), intent(in), optional, target :: process_instance type(var_list_t), intent(in), optional, target :: var_list type(connected_state_t), pointer :: connected_state type(interaction_t), pointer :: int type(flavor_t), dimension(:,:), allocatable :: flv logical, dimension(:), allocatable :: stable real(default), dimension(:), allocatable :: m_prod, m_dec integer :: i call decay%init (model, process%get_id (), process%get_n_terms ()) do i = 1, size (decay%term_config) if (present (process_instance)) then connected_state => process_instance%get_connected_state_ptr (i) int => connected_state%get_matrix_int_ptr () call interaction_get_flv_out (int, flv) else call process%get_term_flv_out (i, flv) end if allocate (m_prod (size (flv(:,1)%get_mass ()))) m_prod = flv(:,1)%get_mass () call flv%set_model (model) allocate (m_dec (size (flv(:,1)%get_mass ()))) m_dec = flv(:,1)%get_mass () allocate (stable (size (flv, 1))) stable = flv(:,1)%is_stable () call check_masses () call decay%init_term (i, flv, stable, model, process_stack, var_list) deallocate (flv, stable, m_prod, m_dec) end do decay%process => process contains subroutine check_masses () integer :: i logical :: ok ok = .true. do i = 1, size (m_prod) if (.not. stable(i)) then if (.not. nearly_equal (m_prod(i), m_dec(i))) then write (msg_buffer, "(A,A,A)") "particle '", & char (flv(i,1)%get_name ()), "':" call msg_message write (msg_buffer, & "(2x,A,1x," // FMT_15 // ",3x,A,1x," // FMT_15 // ")") & "m_prod =", m_prod(i), "m_dec =", m_dec(i) call msg_message ok = .false. end if end if end do if (.not. ok) call msg_fatal & ("Particle mass mismatch between production and decay") end subroutine check_masses end subroutine decay_root_config_connect @ %def decay_root_config_connect @ Recursively compute widths, errors, and branching ratios. <>= procedure :: compute => decay_root_config_compute <>= recursive subroutine decay_root_config_compute (decay) class(decay_root_config_t), intent(inout) :: decay integer :: i do i = 1, size (decay%term_config) call decay%term_config(i)%compute () end do end subroutine decay_root_config_compute @ %def decay_root_config_compute @ \subsection{Decay Root Instance} This is the common parent type for decay and decay root. The process instance points to the parent process. The model pointer is separate because particle settings may be updated w.r.t.\ the parent process object. <>= type, abstract :: decay_gen_t private type(decay_term_t), dimension(:), allocatable :: term type(process_instance_t), pointer :: process_instance => null () integer :: selected_mci = 0 integer :: selected_term = 0 contains <> end type decay_gen_t @ %def decay_gen_t @ The decay root represents the parent process. When an event is generated, the generator selects the term to which the decay chain applies (if possible). The process instance is just a pointer. <>= public :: decay_root_t <>= type, extends (decay_gen_t) :: decay_root_t private type(decay_root_config_t), pointer :: config => null () contains <> end type decay_root_t @ %def decay_root_t @ The finalizer has to recursively finalize the terms, but we can skip the process instance which is not explicitly allocated. <>= procedure :: base_final => decay_gen_final <>= recursive subroutine decay_gen_final (object) class(decay_gen_t), intent(inout) :: object integer :: i if (allocated (object%term)) then do i = 1, size (object%term) call object%term(i)%final () end do end if end subroutine decay_gen_final @ %def decay_gen_final @ No extra finalization for the decay root. <>= procedure :: final => decay_root_final <>= subroutine decay_root_final (object) class(decay_root_t), intent(inout) :: object call object%base_final () end subroutine decay_root_final @ %def decay_gen_final @ Output. <>= procedure :: write => decay_root_write <>= subroutine decay_root_write (object, unit) class(decay_root_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (associated (object%config)) then call object%config%write (unit, verbose = .false.) else write (u, "(1x,A)") "Final-state decay tree: [not configured]" end if if (object%selected_mci > 0) then write (u, "(3x,A,I0)") "Selected MCI = ", object%selected_mci else write (u, "(3x,A)") "Selected MCI = [undefined]" end if if (object%selected_term > 0) then write (u, "(3x,A,I0)") "Selected term = ", object%selected_term call object%term(object%selected_term)%write (u, 1) else write (u, "(3x,A)") "Selected term = [undefined]" end if end subroutine decay_root_write @ %def decay_root_write @ Write the process instances, recursively. <>= procedure :: write_process_instances => decay_gen_write_process_instances <>= recursive subroutine decay_gen_write_process_instances (decay, unit, verbose) class(decay_gen_t), intent(in) :: decay integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical :: verb verb = .true.; if (present (verbose)) verb = verbose if (associated (decay%process_instance)) then if (verb) then call decay%process_instance%write (unit) else call decay%process_instance%write_header (unit) end if end if if (decay%selected_term > 0) then call decay%term(decay%selected_term)%write_process_instances (unit, verb) end if end subroutine decay_gen_write_process_instances @ %def decay_gen_write_process_instances @ Generic initializer. All can be done recursively. <>= procedure :: base_init => decay_gen_init <>= recursive subroutine decay_gen_init (decay, term_config) class(decay_gen_t), intent(out) :: decay type(decay_term_config_t), dimension(:), intent(in), target :: term_config integer :: i allocate (decay%term (size (term_config))) do i = 1, size (decay%term) call decay%term(i)%init (term_config(i)) end do end subroutine decay_gen_init @ %def decay_gen_init @ Specific initializer. We assign the configuration object, which should correspond to a completely initialized decay configuration tree. We also connect to an existing process instance. Then, we recursively link the child interactions to the parent process. <>= procedure :: init => decay_root_init <>= subroutine decay_root_init (decay_root, config, process_instance) class(decay_root_t), intent(out) :: decay_root type(decay_root_config_t), intent(in), target :: config type(process_instance_t), intent(in), target :: process_instance call decay_root%base_init (config%term_config) decay_root%config => config decay_root%process_instance => process_instance call decay_root%make_term_rng (config%process) call decay_root%link_term_interactions () end subroutine decay_root_init @ %def decay_root_init @ Explicitly set/get mci and term indices. (Used in unit test.) <>= procedure :: set_mci => decay_gen_set_mci procedure :: set_term => decay_gen_set_term procedure :: get_mci => decay_gen_get_mci procedure :: get_term => decay_gen_get_term <>= subroutine decay_gen_set_mci (decay, i) class(decay_gen_t), intent(inout) :: decay integer, intent(in) :: i decay%selected_mci = i end subroutine decay_gen_set_mci subroutine decay_gen_set_term (decay, i) class(decay_gen_t), intent(inout) :: decay integer, intent(in) :: i decay%selected_term = i end subroutine decay_gen_set_term function decay_gen_get_mci (decay) result (i) class(decay_gen_t), intent(inout) :: decay integer :: i i = decay%selected_mci end function decay_gen_get_mci function decay_gen_get_term (decay) result (i) class(decay_gen_t), intent(inout) :: decay integer :: i i = decay%selected_term end function decay_gen_get_term @ %def decay_gen_set_mci @ %def decay_gen_set_term @ %def decay_gen_get_mci @ %def decay_gen_get_term @ Implement random-number generators for unstable decay selection in all terms. This is not recursive. We also make use of the fact that [[process]] is a pointer; the (state of the RNG factory inside the) target process will be modified by the rng-spawning method, but not the pointer. <>= procedure :: make_term_rng => decay_gen_make_term_rng <>= subroutine decay_gen_make_term_rng (decay, process) class(decay_gen_t), intent(inout) :: decay type(process_t), intent(in), pointer :: process integer :: i do i = 1, size (decay%term) call decay%term(i)%make_rng (process) end do end subroutine decay_gen_make_term_rng @ %def decay_gen_make_term_rng @ Recursively link interactions of the enclosed decay terms to the corresponding terms in the current process instance. Note: A bug in nagfor requires the extra [[i_term]] variable. <>= procedure :: link_term_interactions => decay_gen_link_term_interactions <>= recursive subroutine decay_gen_link_term_interactions (decay) class(decay_gen_t), intent(inout) :: decay integer :: i, i_term type(interaction_t), pointer :: trace associate (instance => decay%process_instance) do i = 1, size (decay%term) i_term = i trace => instance%get_trace_int_ptr (i_term) call decay%term(i_term)%link_interactions (trace) end do end associate end subroutine decay_gen_link_term_interactions @ %def decay_gen_link_term_interactions @ Select a decay chain: decay modes and process components. <>= procedure :: select_chain => decay_root_select_chain <>= subroutine decay_root_select_chain (decay_root) class(decay_root_t), intent(inout) :: decay_root if (decay_root%selected_term > 0) then call decay_root%term(decay_root%selected_term)%select_chain () else call msg_bug ("Decays: no term selected for parent process") end if end subroutine decay_root_select_chain @ %def decay_root_select_chain @ Generate a decay tree, i.e., for the selected term in the parent process, recursively generate a decay event for all unstable particles. Factor out the trace of the connected state of the parent process. This trace should not be taken into account for unweighting the decay chain, since it was already used for unweighting the parent event, or it determines the overall event weight. <>= procedure :: generate => decay_root_generate <>= subroutine decay_root_generate (decay_root) class(decay_root_t), intent(inout) :: decay_root type(connected_state_t), pointer :: connected_state if (decay_root%selected_term > 0) then connected_state => decay_root%process_instance%get_connected_state_ptr & (decay_root%selected_term) call connected_state%normalize_matrix_by_trace () call decay_root%term(decay_root%selected_term)%generate () else call msg_bug ("Decays: no term selected for parent process") end if end subroutine decay_root_generate @ %def decay_root_generate @ \subsection{Decay Configuration} A decay configuration describes a distinct decay mode of a particle. Each decay mode may include several terms, which correspond to the terms in the associated process. In addition to the base type, the decay configuration object contains the integral of the parent process and the selector for the MCI group inside this process. The flavor component should be identical to the flavor component of the parent particle ([[unstable]] object). <>= type, extends (decay_root_config_t) :: decay_config_t private type(flavor_t) :: flv real(default) :: weight = 0 real(default) :: integral = 0 real(default) :: abs_error = 0 real(default) :: rel_error = 0 type(selector_t) :: mci_selector contains <> end type decay_config_t @ %def decay_config_t @ The output routine extends the decay-root writer by listing numerical component values. <>= procedure :: write => decay_config_write <>= recursive subroutine decay_config_write (object, unit, indent, verbose) class(decay_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) write (u, "(1x,A)") "Decay:" call object%write_header (unit, indent) call write_indent (u, ind) write (u, 2) "branching ratio =", object%weight * 100 call write_indent (u, ind) write (u, 1) "partial width =", object%integral call write_indent (u, ind) write (u, 1) "error (abs) =", object%abs_error call write_indent (u, ind) write (u, 1) "error (rel) =", object%rel_error 1 format (3x,A,ES19.12) 2 format (3x,A,F11.6,1x,'%') call object%write_terms (unit, indent, verbose) end subroutine decay_config_write @ %def decay_config_write @ Connect a decay configuration with a process object (which should represent the decay). This includes initialization, therefore intent(out). We first connect the process itself, then do initializations that are specific for this decay. Infer stability from the particle properties, using the first row in the set of flavor states. Once we can deal with predetermined decay chains, they should be used instead. If there is an optional [[var_list]], check if the stored values for the decay partial width and error have been overridden there. <>= procedure :: connect => decay_config_connect <>= recursive subroutine decay_config_connect & (decay, process, model, process_stack, process_instance, var_list) class(decay_config_t), intent(out) :: decay type(process_t), intent(in), target :: process class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(process_instance_t), intent(in), optional, target :: process_instance type(var_list_t), intent(in), optional, target :: var_list real(default), dimension(:), allocatable :: integral_mci type(string_t) :: process_id integer :: i, n_mci call decay%decay_root_config_t%connect & (process, model, process_stack, var_list=var_list) process_id = process%get_id () if (process%cm_frame ()) then call msg_fatal ("Decay process " // char (process_id) & // ": unusable because rest frame is fixed.") end if decay%integral = process%get_integral () decay%abs_error = process%get_error () if (present (var_list)) then call update (decay%integral, "integral(" // process_id // ")") call update (decay%abs_error, "error(" // process_id // ")") end if n_mci = process%get_n_mci () allocate (integral_mci (n_mci)) do i = 1, n_mci integral_mci(i) = process%get_integral_mci (i) end do call decay%mci_selector%init (integral_mci) contains subroutine update (var, var_name) real(default), intent(inout) :: var type(string_t), intent(in) :: var_name if (var_list%contains (var_name)) then var = var_list%get_rval (var_name) end if end subroutine update end subroutine decay_config_connect @ %def decay_config_connect @ Set the flavor entry, which repeats the flavor of the parent unstable particle. <>= procedure :: set_flv => decay_config_set_flv <>= subroutine decay_config_set_flv (decay, flv) class(decay_config_t), intent(inout) :: decay type(flavor_t), intent(in) :: flv decay%flv = flv end subroutine decay_config_set_flv @ %def decay_config_set_flv @ Compute embedded branchings and the relative error. This method does not apply to the decay root. <>= procedure :: compute => decay_config_compute <>= recursive subroutine decay_config_compute (decay) class(decay_config_t), intent(inout) :: decay call decay%decay_root_config_t%compute () if (.not. vanishes (decay%integral)) then decay%rel_error = decay%abs_error / decay%integral else decay%rel_error = 0 end if end subroutine decay_config_compute @ %def decay_config_compute @ \subsection{Decay Instance} The decay contains a collection of terms. One of them is selected when the decay is evaluated. This is similar to the decay root, but we implement it independently. The process instance object is allocated via a pointer, so it automatically behaves as a target. <>= type, extends (decay_gen_t) :: decay_t private type(decay_config_t), pointer :: config => null () class(rng_t), allocatable :: rng contains <> end type decay_t @ %def decay_t @ The finalizer is recursive. <>= procedure :: final => decay_final <>= recursive subroutine decay_final (object) class(decay_t), intent(inout) :: object integer :: i call object%base_final () do i = 1, object%config%process%get_n_mci () call object%process_instance%final_simulation (i) end do call object%process_instance%final () deallocate (object%process_instance) end subroutine decay_final @ %def decay_final @ Output. <>= procedure :: write => decay_write <>= recursive subroutine decay_write (object, unit, indent, recursive) class(decay_t), intent(in) :: object integer, intent(in), optional :: unit, indent, recursive integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call object%config%write (unit, indent, verbose = .false.) if (allocated (object%rng)) then call object%rng%write (u, ind + 1) end if call write_indent (u, ind) if (object%selected_mci > 0) then write (u, "(3x,A,I0)") "Selected MCI = ", object%selected_mci else write (u, "(3x,A)") "Selected MCI = [undefined]" end if call write_indent (u, ind) if (object%selected_term > 0) then write (u, "(3x,A,I0)") "Selected term = ", object%selected_term call object%term(object%selected_term)%write (u, ind + 1) else write (u, "(3x,A)") "Selected term = [undefined]" end if end subroutine decay_write @ %def decay_write @ Initializer. Base initialization is done recursively. Then, we prepare the current process instance and allocate a random-number generator for term selection. For all unstable particles, we also allocate a r.n.g. as spawned by the current process. <>= procedure :: init => decay_init <>= recursive subroutine decay_init (decay, config) class(decay_t), intent(out) :: decay type(decay_config_t), intent(in), target :: config integer :: i call decay%base_init (config%term_config) decay%config => config allocate (decay%process_instance) call decay%process_instance%init (decay%config%process) call decay%process_instance%setup_event_data (decay%config%model) do i = 1, decay%config%process%get_n_mci () call decay%process_instance%init_simulation (i) end do call decay%config%process%make_rng (decay%rng) call decay%make_term_rng (decay%config%process) end subroutine decay_init @ %def decay_init @ Link interactions to the parent process. [[i_prt]] is the index of the current outgoing particle in the parent interaction, for which we take the trace evaluator. We link it to the beam particle in the beam interaction of the decay process instance. Then, repeat the procedure for the outgoing particles. <>= procedure :: link_interactions => decay_link_interactions <>= recursive subroutine decay_link_interactions (decay, i_prt, trace) class(decay_t), intent(inout) :: decay integer, intent(in) :: i_prt type(interaction_t), intent(in), target :: trace type(interaction_t), pointer :: beam_int integer :: n_in, n_vir beam_int => decay%process_instance%get_beam_int_ptr () n_in = trace%get_n_in () n_vir = trace%get_n_vir () call beam_int%set_source_link (1, trace, & n_in + n_vir + i_prt) call decay%link_term_interactions () end subroutine decay_link_interactions @ %def decay_link_interactions @ Determine a decay chain. For each unstable particle we select one of the possible decay modes, and for each decay process we select one of the possible decay MCI components, calling the random-number generators. We do not generate momenta, yet. <>= procedure :: select_chain => decay_select_chain <>= recursive subroutine decay_select_chain (decay) class(decay_t), intent(inout) :: decay real(default) :: x integer :: i call decay%rng%generate (x) decay%selected_mci = decay%config%mci_selector%select (x) call decay%process_instance%choose_mci (decay%selected_mci) decay%selected_term = decay%process_instance%select_i_term () do i = 1, size (decay%term) call decay%term(i)%select_chain () end do end subroutine decay_select_chain @ %def decay_select_chain @ Generate a decay. We first receive the beam momenta from the parent process (assuming that this is properly linked), then call the associated process object for a new event. Factor out the trace of the helicity density matrix of the isolated state (the one that will be used for the decay chain). The trace is taken into account for unweighting the individual decay event and should therefore be ignored for unweighting the correlated decay chain afterwards. <>= procedure :: generate => decay_generate <>= recursive subroutine decay_generate (decay) class(decay_t), intent(inout) :: decay type(isolated_state_t), pointer :: isolated_state integer :: i call decay%process_instance%receive_beam_momenta () call decay%process_instance%generate_unweighted_event (decay%selected_mci) if (signal_is_pending ()) return call decay%process_instance%evaluate_event_data () isolated_state => & decay%process_instance%get_isolated_state_ptr (decay%selected_term) call isolated_state%normalize_matrix_by_trace () do i = 1, size (decay%term) call decay%term(i)%generate () if (signal_is_pending ()) return end do end subroutine decay_generate @ %def decay_generate @ \subsection{Stable Particles} This is a stable particle. The flavor can be ambiguous (e.g., partons). <>= type, extends (any_config_t) :: stable_config_t private type(flavor_t), dimension(:), allocatable :: flv contains <> end type stable_config_t @ %def stable_config_t @ The finalizer is empty: <>= procedure :: final => stable_config_final <>= subroutine stable_config_final (object) class(stable_config_t), intent(inout) :: object end subroutine stable_config_final @ %def stable_config_final @ Output. <>= procedure :: write => stable_config_write <>= recursive subroutine stable_config_write (object, unit, indent, verbose) class(stable_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: u, i, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) write (u, "(1x,'+',1x,A)", advance = "no") "Stable:" write (u, "(1x,A)", advance = "no") char (object%flv(1)%get_name ()) do i = 2, size (object%flv) write (u, "(':',A)", advance = "no") & char (object%flv(i)%get_name ()) end do write (u, *) end subroutine stable_config_write @ %def stable_config_write @ Initializer. We are presented with an array of flavors, but there may be double entries which we remove, so we store only the distinct flavors. <>= procedure :: init => stable_config_init <>= subroutine stable_config_init (config, flv) class(stable_config_t), intent(out) :: config type(flavor_t), dimension(:), intent(in) :: flv integer, dimension (size (flv)) :: pdg logical, dimension (size (flv)) :: mask integer :: i pdg = flv%get_pdg () mask(1) = .true. forall (i = 2 : size (pdg)) mask(i) = all (pdg(i) /= pdg(1:i-1)) end forall allocate (config%flv (count (mask))) config%flv = pack (flv, mask) end subroutine stable_config_init @ %def stable_config_init @ Here is the corresponding object instance. Except for the pointer to the configuration, there is no content. <>= type, extends (any_t) :: stable_t private type(stable_config_t), pointer :: config => null () contains <> end type stable_t @ %def stable_t @ The finalizer does nothing. <>= procedure :: final => stable_final <>= subroutine stable_final (object) class(stable_t), intent(inout) :: object end subroutine stable_final @ %def stable_final @ We can delegate output to the configuration object. <>= procedure :: write => stable_write <>= subroutine stable_write (object, unit, indent) class(stable_t), intent(in) :: object integer, intent(in), optional :: unit, indent call object%config%write (unit, indent) end subroutine stable_write @ %def stable_write @ Initializer: just assign the configuration. <>= procedure :: init => stable_init <>= subroutine stable_init (stable, config) class(stable_t), intent(out) :: stable type(stable_config_t), intent(in), target :: config stable%config => config end subroutine stable_init @ %def stable_init @ \subsection{Unstable Particles} A branching configuration enables us to select among distinct decay modes of a particle. We store the particle flavor (with its implicit link to a model), an array of decay configurations, and a selector object. The total width, absolute and relative error are stored as [[integral]], [[abs_error]], and [[rel_error]], respectively. The flavor must be unique in this case. <>= public :: unstable_config_t <>= type, extends (any_config_t) :: unstable_config_t private type(flavor_t) :: flv real(default) :: integral = 0 real(default) :: abs_error = 0 real(default) :: rel_error = 0 type(selector_t) :: selector type(decay_config_t), dimension(:), allocatable :: decay_config contains <> end type unstable_config_t @ %def unstable_config_t @ Finalizer. The branching configuration can be a recursive structure. <>= procedure :: final => unstable_config_final <>= recursive subroutine unstable_config_final (object) class(unstable_config_t), intent(inout) :: object integer :: i if (allocated (object%decay_config)) then do i = 1, size (object%decay_config) call object%decay_config(i)%final () end do end if end subroutine unstable_config_final @ %def unstable_config_final @ Output. Since this may be recursive, we include indentation. <>= procedure :: write => unstable_config_write <>= recursive subroutine unstable_config_write (object, unit, indent, verbose) class(unstable_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: u, i, ind logical :: verb u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent verb = .true.; if (present (verbose)) verb = verbose call write_indent (u, ind) write (u, "(1x,'+',1x,A,1x,A)") "Unstable:", & char (object%flv%get_name ()) call write_indent (u, ind) write (u, 1) "total width =", object%integral call write_indent (u, ind) write (u, 1) "error (abs) =", object%abs_error call write_indent (u, ind) write (u, 1) "error (rel) =", object%rel_error 1 format (5x,A,ES19.12) if (verb .and. allocated (object%decay_config)) then do i = 1, size (object%decay_config) call object%decay_config(i)%write (u, ind + 1) end do end if end subroutine unstable_config_write @ %def unstable_config_write @ Initializer. For the unstable particle, the flavor is unique. <>= procedure :: init => unstable_config_init <>= subroutine unstable_config_init (unstable, flv, set_decays, model) class(unstable_config_t), intent(out) :: unstable type(flavor_t), intent(in) :: flv logical, intent(in), optional :: set_decays class(model_data_t), intent(in), optional, target :: model type(string_t), dimension(:), allocatable :: decay unstable%flv = flv if (present (set_decays)) then call unstable%flv%get_decays (decay) call unstable%init_decays (decay, model) end if end subroutine unstable_config_init @ %def unstable_config_init @ Further initialization: determine the number of decay modes. We can assume that the flavor of the particle has been set already. If the process stack is given, we can delve recursively into actually assigning decay processes. Otherwise, we just initialize with decay process names. <>= procedure :: init_decays => unstable_config_init_decays <>= recursive subroutine unstable_config_init_decays & (unstable, decay_id, model, process_stack, var_list) class(unstable_config_t), intent(inout) :: unstable type(string_t), dimension(:), intent(in) :: decay_id class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(var_list_t), intent(in), optional :: var_list integer :: i allocate (unstable%decay_config (size (decay_id))) do i = 1, size (decay_id) associate (decay => unstable%decay_config(i)) if (present (process_stack)) then call decay%connect (process_stack%get_process_ptr (decay_id(i)), & model, process_stack, var_list=var_list) else call decay%init (model, decay_id(i)) end if call decay%set_flv (unstable%flv) end associate end do end subroutine unstable_config_init_decays @ %def unstable_config_init @ Explicitly connect a specific decay with a process. This is used only in unit tests. <>= procedure :: connect_decay => unstable_config_connect_decay <>= subroutine unstable_config_connect_decay (unstable, i, process, model) class(unstable_config_t), intent(inout) :: unstable integer, intent(in) :: i type(process_t), intent(in), target :: process class(model_data_t), intent(in), target :: model associate (decay => unstable%decay_config(i)) call decay%connect (process, model) end associate end subroutine unstable_config_connect_decay @ %def unstable_config_connect_decay @ Compute the total width and branching ratios, initializing the decay selector. <>= procedure :: compute => unstable_config_compute <>= recursive subroutine unstable_config_compute (unstable) class(unstable_config_t), intent(inout) :: unstable integer :: i do i = 1, size (unstable%decay_config) call unstable%decay_config(i)%compute () end do unstable%integral = sum (unstable%decay_config%integral) if (unstable%integral <= 0) then call unstable%write () call msg_fatal ("Decay configuration: computed total width is zero") end if unstable%abs_error = sqrt (sum (unstable%decay_config%abs_error ** 2)) unstable%rel_error = unstable%abs_error / unstable%integral call unstable%selector%init (unstable%decay_config%integral) do i = 1, size (unstable%decay_config) unstable%decay_config(i)%weight & = unstable%selector%get_weight (i) end do end subroutine unstable_config_compute @ %def unstable_config_compute @ Now we define the instance of an unstable particle. <>= public :: unstable_t <>= type, extends (any_t) :: unstable_t private type(unstable_config_t), pointer :: config => null () class(rng_t), allocatable :: rng integer :: selected_decay = 0 type(decay_t), dimension(:), allocatable :: decay contains <> end type unstable_t @ %def unstable_t @ Recursive finalizer. <>= procedure :: final => unstable_final <>= recursive subroutine unstable_final (object) class(unstable_t), intent(inout) :: object integer :: i if (allocated (object%decay)) then do i = 1, size (object%decay) call object%decay(i)%final () end do end if end subroutine unstable_final @ %def unstable_final @ Output. <>= procedure :: write => unstable_write <>= recursive subroutine unstable_write (object, unit, indent) class(unstable_t), intent(in) :: object integer, intent(in), optional :: unit, indent integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call object%config%write (u, ind, verbose=.false.) if (allocated (object%rng)) then call object%rng%write (u, ind + 2) end if call write_indent (u, ind) if (object%selected_decay > 0) then write (u, "(5x,A,I0)") "Sel. decay = ", object%selected_decay call object%decay(object%selected_decay)%write (u, ind + 1) else write (u, "(5x,A)") "Sel. decay = [undefined]" end if end subroutine unstable_write @ %def unstable_write @ Write the embedded process instances. <>= procedure :: write_process_instances => unstable_write_process_instances <>= recursive subroutine unstable_write_process_instances & (unstable, unit, verbose) class(unstable_t), intent(in) :: unstable integer, intent(in), optional :: unit logical, intent(in), optional :: verbose if (unstable%selected_decay > 0) then call unstable%decay(unstable%selected_decay)% & write_process_instances (unit, verbose) end if end subroutine unstable_write_process_instances @ %def unstable_write_process_instances @ Initialization, using the configuration object. <>= procedure :: init => unstable_init <>= recursive subroutine unstable_init (unstable, config) class(unstable_t), intent(out) :: unstable type(unstable_config_t), intent(in), target :: config integer :: i unstable%config => config allocate (unstable%decay (size (config%decay_config))) do i = 1, size (config%decay_config) call unstable%decay(i)%init (config%decay_config(i)) end do end subroutine unstable_init @ %def unstable_init @ Recursively link interactions to the parent process. [[i_prt]] is the index of the current outgoing particle in the parent interaction. <>= procedure :: link_interactions => unstable_link_interactions <>= recursive subroutine unstable_link_interactions (unstable, i_prt, trace) class(unstable_t), intent(inout) :: unstable integer, intent(in) :: i_prt type(interaction_t), intent(in), target :: trace integer :: i do i = 1, size (unstable%decay) call unstable%decay(i)%link_interactions (i_prt, trace) end do end subroutine unstable_link_interactions @ %def unstable_link_interactions @ Import the random-number generator state. <>= procedure :: import_rng => unstable_import_rng <>= subroutine unstable_import_rng (unstable, rng) class(unstable_t), intent(inout) :: unstable class(rng_t), intent(inout), allocatable :: rng call move_alloc (from = rng, to = unstable%rng) end subroutine unstable_import_rng @ %def unstable_import_rng @ Generate a decay chain. First select a decay mode, then call the [[select_chain]] method of the selected mode. <>= procedure :: select_chain => unstable_select_chain <>= recursive subroutine unstable_select_chain (unstable) class(unstable_t), intent(inout) :: unstable real(default) :: x call unstable%rng%generate (x) unstable%selected_decay = unstable%config%selector%select (x) call unstable%decay(unstable%selected_decay)%select_chain () end subroutine unstable_select_chain @ %def unstable_select_chain @ Generate a decay event. <>= procedure :: generate => unstable_generate <>= recursive subroutine unstable_generate (unstable) class(unstable_t), intent(inout) :: unstable call unstable%decay(unstable%selected_decay)%generate () end subroutine unstable_generate @ %def unstable_generate @ \subsection{Decay Chain} While the decay configuration tree and the decay tree are static entities (during a simulation run), the decay chain is dynamically generated for each event. The reason is that with the possibility of several decay modes for each particle, and several terms for each process, the total number of distinct decay chains is not under control. Each entry in the decay chain is a connected parton state. The origin of the chain is a connected state in the parent process (not part of the chain itself). For each decay, mode and term chosen, we convolute this with the isolated (!) state of the current decay, to generate a new connected state. We accumulate this chain by recursively traversing the allocated decay tree. Whenever a particle decays, it becomes virtual and is replaced by its decay product, while all other particles stay in the parton state as spectators. Technically, we implement the decay chain as a stack structure and include information from the associated decay object for easier debugging. This is a decay chain entry: <>= type, extends (connected_state_t) :: decay_chain_entry_t private integer :: index = 0 type(decay_config_t), pointer :: config => null () integer :: selected_mci = 0 integer :: selected_term = 0 type(decay_chain_entry_t), pointer :: previous => null () end type decay_chain_entry_t @ %def decay_chain_entry_t @ This is the complete chain; we need just a pointer to the last entry. We also include a pointer to the master process instance, which serves as the seed for the decay chain. The evaluator [[correlated_trace]] traces over all quantum numbers for the final spin-correlated (but color-summed) evaluator of the decay chain. This allows us to compute the probability for a momentum configuration, given that all individual density matrices (of the initial process and the subsequent decays) have been normalized to one. Note: This trace is summed over color, so color is treated exactly when computing spin correlations. However, we do not keep non-diagonal color correlations. When an event is accepted, we compute probabilities for all color states and can choose one of them. <>= public :: decay_chain_t <>= type :: decay_chain_t private type(process_instance_t), pointer :: process_instance => null () integer :: selected_term = 0 type(evaluator_t) :: correlated_trace type(decay_chain_entry_t), pointer :: last => null () contains <> end type decay_chain_t @ %def decay_chain_t @ The finalizer recursively deletes and deallocates the entries. <>= procedure :: final => decay_chain_final <>= subroutine decay_chain_final (object) class(decay_chain_t), intent(inout) :: object type(decay_chain_entry_t), pointer :: entry do while (associated (object%last)) entry => object%last object%last => entry%previous call entry%final () deallocate (entry) end do call object%correlated_trace%final () end subroutine decay_chain_final @ %def decay_chain_final @ Doing output recursively allows us to display the chain in chronological order. <>= procedure :: write => decay_chain_write <>= subroutine decay_chain_write (object, unit) class(decay_chain_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call write_separator (u, 2) write (u, "(1x,A)") "Decay chain:" call write_entries (object%last) call write_separator (u, 2) write (u, "(1x,A)") "Evaluator (correlated trace of the decay chain):" call write_separator (u) call object%correlated_trace%write (u) call write_separator (u, 2) contains recursive subroutine write_entries (entry) type(decay_chain_entry_t), intent(in), pointer :: entry if (associated (entry)) then call write_entries (entry%previous) call write_separator (u, 2) write (u, "(1x,A,I0)") "Decay #", entry%index call entry%config%write_header (u) write (u, "(3x,A,I0)") "Selected MCI = ", entry%selected_mci write (u, "(3x,A,I0)") "Selected term = ", entry%selected_term call entry%config%term_config(entry%selected_term)%write (u, indent=1) call entry%write (u) end if end subroutine write_entries end subroutine decay_chain_write @ %def decay_chain_write @ Build a decay chain, recursively following the selected decays and terms in a decay tree. Before start, we finalize the chain, deleting any previous contents. <>= procedure :: build => decay_chain_build <>= subroutine decay_chain_build (chain, decay_root) class(decay_chain_t), intent(inout), target :: chain type(decay_root_t), intent(in) :: decay_root type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask type(interaction_t), pointer :: int_last_decay call chain%final () if (decay_root%selected_term > 0) then chain%process_instance => decay_root%process_instance chain%selected_term = decay_root%selected_term call chain%build_term_entries (decay_root%term(decay_root%selected_term)) end if int_last_decay => chain%last%get_matrix_int_ptr () allocate (qn_mask (int_last_decay%get_n_tot ())) call qn_mask%init (mask_f = .true., mask_c = .true., mask_h = .true.) call chain%correlated_trace%init_qn_sum (int_last_decay, qn_mask) end subroutine decay_chain_build @ %def decay_chain_build @ Build the entries that correspond to a decay term. We have to scan all unstable particles. <>= procedure :: build_term_entries => decay_chain_build_term_entries <>= recursive subroutine decay_chain_build_term_entries (chain, term) class(decay_chain_t), intent(inout) :: chain type(decay_term_t), intent(in) :: term integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) if (unstable%selected_decay > 0) then call chain%build_decay_entries & (unstable%decay(unstable%selected_decay)) end if end select end do end subroutine decay_chain_build_term_entries @ %def decay_chain_build_term_entries @ Build the entries that correspond to a specific decay. The decay term should have been determined, so we allocate a decay chain entry and fill it, then proceed to child decays. For the first entry, we convolute the connected state of the parent process instance with the isolated state of the current decay (which does not contain an extra beam entry for the parent). For subsequent entries, we take the previous entry as first factor. In principle, each chain entry (as a parton state) is capable of holding a subevent object and associated expressions. We currently do not make use of that feature. Before generating the decays, factor out the trace of the helicity density matrix of the parent parton state. This trace has been used for unweighting the original event (unweighted case) or it determines the overall weight, so it should not be taken into account in the decay chain generation. <>= procedure :: build_decay_entries => decay_chain_build_decay_entries <>= recursive subroutine decay_chain_build_decay_entries (chain, decay) class(decay_chain_t), intent(inout) :: chain type(decay_t), intent(in) :: decay type(decay_chain_entry_t), pointer :: entry type(connected_state_t), pointer :: previous_state type(isolated_state_t), pointer :: current_decay type(helicity_t) :: hel type(quantum_numbers_t) :: qn_filter_conn allocate (entry) if (associated (chain%last)) then entry%previous => chain%last entry%index = entry%previous%index + 1 previous_state => entry%previous%connected_state_t else entry%index = 1 previous_state => & chain%process_instance%get_connected_state_ptr (chain%selected_term) end if entry%config => decay%config entry%selected_mci = decay%selected_mci entry%selected_term = decay%selected_term current_decay => decay%process_instance%get_isolated_state_ptr & (decay%selected_term) call entry%setup_connected_trace & (current_decay, previous_state%get_trace_int_ptr (), resonant=.true.) if (entry%config%flv%has_decay_helicity ()) then call hel%init (entry%config%flv%get_decay_helicity ()) call qn_filter_conn%init (hel) call entry%setup_connected_matrix & (current_decay, previous_state%get_matrix_int_ptr (), & resonant=.true., qn_filter_conn = qn_filter_conn) call entry%setup_connected_flows & (current_decay, previous_state%get_flows_int_ptr (), & resonant=.true., qn_filter_conn = qn_filter_conn) else call entry%setup_connected_matrix & (current_decay, previous_state%get_matrix_int_ptr (), & resonant=.true.) call entry%setup_connected_flows & (current_decay, previous_state%get_flows_int_ptr (), & resonant=.true.) end if chain%last => entry call chain%build_term_entries (decay%term(decay%selected_term)) end subroutine decay_chain_build_decay_entries @ %def decay_chain_build_decay_entries @ Recursively fill the decay chain with momenta and evaluate the matrix elements. Since all evaluators should have correct source entries at this point, momenta are automatically retrieved from the appropriate process instance. Like we did above for the parent process, factor out the trace for each subsequent decay (the helicity density matrix in the isolated state, which is taken for the convolution). <>= procedure :: evaluate => decay_chain_evaluate <>= subroutine decay_chain_evaluate (chain) class(decay_chain_t), intent(inout) :: chain call evaluate (chain%last) call chain%correlated_trace%receive_momenta () call chain%correlated_trace%evaluate () contains recursive subroutine evaluate (entry) type(decay_chain_entry_t), intent(inout), pointer :: entry if (associated (entry)) then call evaluate (entry%previous) call entry%receive_kinematics () call entry%evaluate_trace () call entry%evaluate_event_data () end if end subroutine evaluate end subroutine decay_chain_evaluate @ %def decay_chain_evaluate @ Return the probability of a decay chain. This is given as the trace of the density matrix with intermediate helicity correlations, normalized by the product of the uncorrelated density matrix traces. This works only if an event has been evaluated and the [[correlated_trace]] evaluator is filled. By definition, this evaluator has only one matrix element, and this must be real. <>= procedure :: get_probability => decay_chain_get_probability <>= function decay_chain_get_probability (chain) result (x) class(decay_chain_t), intent(in) :: chain real(default) :: x x = real (chain%correlated_trace%get_matrix_element (1)) end function decay_chain_get_probability @ %def decay_chain_get_probability @ \subsection{Decay as Event Transform} The [[evt_decay]] object combines decay configuration, decay tree, and chain in a single object, as an implementation of the [[evt]] (event transform) abstract type. The [[var_list]] may be a pointer to the user variable list, which could contain overridden parameters for the decay processes. <>= public :: evt_decay_t <>= type, extends (evt_t) :: evt_decay_t private type(decay_root_config_t) :: decay_root_config type(decay_root_t) :: decay_root type(decay_chain_t) :: decay_chain type(var_list_t), pointer :: var_list => null () contains <> end type evt_decay_t @ %def evt_decay_t @ <>= procedure :: write_name => evt_decay_write_name <>= subroutine evt_decay_write_name (evt, unit) class(evt_decay_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: partonic decays" end subroutine evt_decay_write_name @ %def evt_decay_write_name @ Output. We display the currently selected decay tree, which includes configuration data, and the decay chain, i.e., the evaluators. <>= procedure :: write => evt_decay_write <>= subroutine evt_decay_write (evt, unit, verbose, more_verbose, testflag) class(evt_decay_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag logical :: verb, verb2 integer :: u u = given_output_unit (unit) verb = .true.; if (present (verbose)) verb = verbose verb2 = .false.; if (present (more_verbose)) verb2 = more_verbose call write_separator (u, 2) call evt%write_name (u) call write_separator (u, 2) call evt%base_write (u, testflag = testflag) if (associated (evt%var_list)) then call write_separator (u) write (u, "(1x,A)") "Variable list for simulation: & &[associated, not shown]" end if if (verb) then call write_separator (u) call evt%decay_root%write (u) if (verb2) then call evt%decay_chain%write (u) call evt%decay_root%write_process_instances (u, verb) end if else call write_separator (u, 2) end if end subroutine evt_decay_write @ %def evt_decay_write @ Set the pointer to a user variable list. <>= procedure :: set_var_list => evt_decay_set_var_list <>= subroutine evt_decay_set_var_list (evt, var_list) class(evt_decay_t), intent(inout) :: evt type(var_list_t), intent(in), target :: var_list evt%var_list => var_list end subroutine evt_decay_set_var_list @ %def evt_decay_set_var_list @ Connect with a process instance and process. This initializes the decay configuration. The process stack is used to look for process objects that implement daughter decays. When all processes are assigned, configure the decay tree instance, using the decay tree configuration. First obtain the branching ratios, then allocate the decay tree. This is done once for all events. <>= procedure :: connect => evt_decay_connect <>= subroutine evt_decay_connect (evt, process_instance, model, process_stack) class(evt_decay_t), intent(inout), target :: evt type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack call evt%base_connect (process_instance, model) if (associated (evt%var_list)) then call evt%decay_root_config%connect (process_instance%process, & model, process_stack, process_instance, evt%var_list) else call evt%decay_root_config%connect (process_instance%process, & model, process_stack, process_instance) end if call evt%decay_root_config%compute () call evt%decay_root%init (evt%decay_root_config, evt%process_instance) end subroutine evt_decay_connect @ %def evt_decay_connect @ Prepare a new event: Select a decay chain and build the corresponding chain object. <>= procedure :: prepare_new_event => evt_decay_prepare_new_event <>= subroutine evt_decay_prepare_new_event (evt, i_mci, i_term) class(evt_decay_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () evt%decay_root%selected_mci = i_mci evt%decay_root%selected_term = i_term call evt%decay_root%select_chain () call evt%decay_chain%build (evt%decay_root) end subroutine evt_decay_prepare_new_event @ %def evt_decay_prepare_new_event @ Generate a weighted event and assign the resulting weight (probability). We use a chain initialized by the preceding subroutine, fill it with momenta and evaluate. <>= procedure :: generate_weighted => evt_decay_generate_weighted <>= subroutine evt_decay_generate_weighted (evt, probability) class(evt_decay_t), intent(inout) :: evt real(default), intent(inout) :: probability call evt%decay_root%generate () if (signal_is_pending ()) return call evt%decay_chain%evaluate () probability = evt%decay_chain%get_probability () end subroutine evt_decay_generate_weighted @ %def evt_decay_generate_weighted @ To create a usable event, we have to transform the interaction into a particle set; this requires factorization for the correlated density matrix, according to the factorization mode. <>= procedure :: make_particle_set => evt_decay_make_particle_set <>= subroutine evt_decay_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_decay_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r type(interaction_t), pointer :: int_matrix, int_flows type(decay_chain_entry_t), pointer :: last_entry last_entry => evt%decay_chain%last int_matrix => last_entry%get_matrix_int_ptr () int_flows => last_entry%get_flows_int_ptr () call evt%factorize_interactions (int_matrix, int_flows, & factorization_mode, keep_correlations, r) call evt%tag_incoming () end subroutine evt_decay_make_particle_set @ %def event_decay_make_particle_set @ \subsubsection{Auxiliary} Eliminate numerical noise for the associated process instances. <>= public :: pacify <>= interface pacify module procedure pacify_decay module procedure pacify_decay_gen module procedure pacify_term module procedure pacify_unstable end interface pacify <>= subroutine pacify_decay (evt) class(evt_decay_t), intent(inout) :: evt call pacify_decay_gen (evt%decay_root) end subroutine pacify_decay recursive subroutine pacify_decay_gen (decay) class(decay_gen_t), intent(inout) :: decay if (associated (decay%process_instance)) then call pacify (decay%process_instance) end if if (decay%selected_term > 0) then call pacify_term (decay%term(decay%selected_term)) end if end subroutine pacify_decay_gen recursive subroutine pacify_term (term) class(decay_term_t), intent(inout) :: term integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t); call pacify_unstable (unstable) end select end do end subroutine pacify_term recursive subroutine pacify_unstable (unstable) class(unstable_t), intent(inout) :: unstable if (unstable%selected_decay > 0) then call pacify_decay_gen (unstable%decay(unstable%selected_decay)) end if end subroutine pacify_unstable @ %def pacify @ Prepare specific configurations for use in unit tests. <>= procedure :: init_test_case1 procedure :: init_test_case2 <>= subroutine init_test_case1 (unstable, i, flv, integral, relerr, model) class(unstable_config_t), intent(inout) :: unstable integer, intent(in) :: i type(flavor_t), dimension(:,:), intent(in) :: flv real(default), intent(in) :: integral real(default), intent(in) :: relerr class(model_data_t), intent(in), target :: model associate (decay => unstable%decay_config(i)) allocate (decay%term_config (1)) call decay%init_term (1, flv, stable = [.true., .true.], model=model) decay%integral = integral decay%abs_error = integral * relerr end associate end subroutine init_test_case1 subroutine init_test_case2 (unstable, flv1, flv21, flv22, model) class(unstable_config_t), intent(inout) :: unstable type(flavor_t), dimension(:,:), intent(in) :: flv1, flv21, flv22 class(model_data_t), intent(in), target :: model associate (decay => unstable%decay_config(1)) decay%integral = 1.e-3_default decay%abs_error = decay%integral * .01_default allocate (decay%term_config (1)) call decay%init_term (1, flv1, stable = [.false., .true.], model=model) select type (w => decay%term_config(1)%prt(1)%c) type is (unstable_config_t) associate (w_decay => w%decay_config(1)) w_decay%integral = 2._default allocate (w_decay%term_config (1)) call w_decay%init_term (1, flv21, stable = [.true., .true.], & model=model) end associate associate (w_decay => w%decay_config(2)) w_decay%integral = 1._default allocate (w_decay%term_config (1)) call w_decay%init_term (1, flv22, stable = [.true., .true.], & model=model) end associate call w%compute () end select end associate end subroutine init_test_case2 @ %def init_test_case1 @ %def init_test_case2 @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[decays_ut.f90]]>>= <> module decays_ut use unit_tests use decays_uti <> <> <> contains <> end module decays_ut @ %def decays_ut @ <<[[decays_uti.f90]]>>= <> module decays_uti <> <> use os_interface use sm_qcd use model_data use models use state_matrices, only: FM_IGNORE_HELICITY use interactions, only: reset_interaction_counter use flavors use process_libraries use rng_base use mci_base use mci_midpoint use phs_base use phs_single use prc_core use prc_test, only: prc_test_create_library use process, only: process_t use instances, only: process_instance_t use process_stacks use decays use rng_base_ut, only: rng_test_t, rng_test_factory_t <> <> <> contains <> <> end module decays_uti @ %def decays_uti @ API: driver for the unit tests below. <>= public :: decays_test <>= subroutine decays_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine decays_test @ %def decays_test @ \subsubsection{Testbed} As a variation of the [[prepare_test_process]] routine used elsewhere, we define here a routine that creates two processes (scattering $ss\to ss$ and decay $s\to f\bar f$), compiles and integrates them and prepares for event generation. <>= public :: prepare_testbed <>= subroutine prepare_testbed & (lib, process_stack, prefix, os_data, & scattering, decay, decay_rest_frame) type(process_library_t), intent(out), target :: lib type(process_stack_t), intent(out) :: process_stack type(string_t), intent(in) :: prefix type(os_data_t), intent(in) :: os_data logical, intent(in) :: scattering, decay logical, intent(in), optional :: decay_rest_frame type(model_t), target :: model type(model_t), target :: model_copy type(string_t) :: libname, procname1, procname2 type(process_entry_t), pointer :: process type(process_instance_t), allocatable, target :: process_instance class(phs_config_t), allocatable :: phs_config_template type(field_data_t), pointer :: field_data real(default) :: sqrts libname = prefix // "_lib" procname1 = prefix // "_p" procname2 = prefix // "_d" call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) if (scattering .and. decay) then field_data => model%get_field_ptr (25) call field_data%set (p_is_stable = .false.) end if call prc_test_create_library (libname, lib, & scattering = .true., decay = .true., & procname1 = procname1, procname2 = procname2) call reset_interaction_counter () allocate (phs_single_config_t :: phs_config_template) if (scattering) then call model_copy%init (model%get_name (), & model%get_n_real (), & model%get_n_complex (), & model%get_n_field (), & model%get_n_vtx ()) call model_copy%copy_from (model) allocate (process) call process%init (procname1, lib, os_data, model_copy) call process%setup_test_cores () call process%init_components (phs_config_template) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test_midpoint) call process%setup_terms () allocate (process_instance) call process_instance%init (process%process_t) call process_instance%integrate (1, n_it = 1, n_calls = 100) call process%final_integration (1) call process_instance%final () deallocate (process_instance) call process%prepare_simulation (1) call process_stack%push (process) end if if (decay) then call model_copy%init (model%get_name (), & model%get_n_real (), & model%get_n_complex (), & model%get_n_field (), & model%get_n_vtx ()) call model_copy%copy_from (model) allocate (process) call process%init (procname2, lib, os_data, model_copy) call process%setup_test_cores () call process%init_components (phs_config_template) if (present (decay_rest_frame)) then call process%setup_beams_decay (rest_frame = decay_rest_frame, i_core = 1) else call process%setup_beams_decay (rest_frame = .not. scattering, i_core = 1) end if call process%configure_phs () call process%setup_mci (dispatch_mci_test_midpoint) call process%setup_terms () allocate (process_instance) call process_instance%init (process%process_t) call process_instance%integrate (1, n_it=1, n_calls=100) call process%final_integration (1) call process_instance%final () deallocate (process_instance) call process%prepare_simulation (1) call process_stack%push (process) end if call model%final () call model_copy%final () end subroutine prepare_testbed @ %def prepare_testbed @ MCI record prepared for midpoint integrator. <>= subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo) use variables, only: var_list_t class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_midpoint_t :: mci) end subroutine dispatch_mci_test_midpoint @ %def dispatch_mci_test_midpoint @ \subsubsection{Simple decay configuration} We define a branching configuration with two decay modes. We set the integral values by hand, so we do not need to evaluate processes, yet. <>= call test (decays_1, "decays_1", & "branching and decay configuration", & u, results) <>= public :: decays_1 <>= subroutine decays_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t) :: flv_h type(flavor_t), dimension(2,1) :: flv_hbb, flv_hgg type(unstable_config_t), allocatable :: unstable write (u, "(A)") "* Test output: decays_1" write (u, "(A)") "* Purpose: Set up branching and decay configuration" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call os_data%init () call model%init_sm_test () call flv_h%init (25, model) call flv_hbb(:,1)%init ([5, -5], model) call flv_hgg(:,1)%init ([22, 22], model) write (u, "(A)") "* Set up branching and decay" write (u, "(A)") allocate (unstable) call unstable%init (flv_h) call unstable%init_decays ([var_str ("h_bb"), var_str ("h_gg")], model) call unstable%init_test_case1 & (1, flv_hbb, 1.234e-3_default, .02_default, model) call unstable%init_test_case1 & (2, flv_hgg, 3.085e-4_default, .08_default, model) call unstable%compute () call unstable%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call unstable%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_1" end subroutine decays_1 @ %def decays_1 @ \subsubsection{Cascade decay configuration} We define a branching configuration with one decay, which is followed by another branching. <>= call test (decays_2, "decays_2", & "cascade decay configuration", & u, results) <>= public :: decays_2 <>= subroutine decays_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t) :: flv_h, flv_wp, flv_wm type(flavor_t), dimension(2,1) :: flv_hww, flv_wud, flv_wen type(unstable_config_t), allocatable :: unstable write (u, "(A)") "* Test output: decays_2" write (u, "(A)") "* Purpose: Set up cascade branching" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call os_data%init () call model%init_sm_test () call model%set_unstable (25, [var_str ("h_ww")]) call model%set_unstable (24, [var_str ("w_ud"), var_str ("w_en")]) call flv_h%init (25, model) call flv_hww(:,1)%init ([24, -24], model) call flv_wp%init (24, model) call flv_wm%init (-24, model) call flv_wud(:,1)%init ([2, -1], model) call flv_wen(:,1)%init ([-11, 12], model) write (u, "(A)") "* Set up branching and decay" write (u, "(A)") allocate (unstable) call unstable%init (flv_h, set_decays=.true., model=model) call unstable%init_test_case2 (flv_hww, flv_wud, flv_wen, model) call unstable%compute () call unstable%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call unstable%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_2" end subroutine decays_2 @ %def decays_2 @ \subsubsection{Decay and Process Object} We define a branching configuration with one decay and connect this with an actual process object. <>= call test (decays_3, "decays_3", & "associate process", & u, results) <>= public :: decays_3 <>= subroutine decays_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_library_t), target :: lib type(string_t) :: prefix type(string_t) :: procname2 type(process_stack_t) :: process_stack type(process_t), pointer :: process type(unstable_config_t), allocatable :: unstable type(flavor_t) :: flv write (u, "(A)") "* Test output: decays_3" write (u, "(A)") "* Purpose: Connect a decay configuration & &with a process" write (u, "(A)") write (u, "(A)") "* Initialize environment and integrate process" write (u, "(A)") call os_data%init () prefix = "decays_3" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.false., decay=.true., decay_rest_frame=.false.) procname2 = prefix // "_d" process => process_stack%get_process_ptr (procname2) model => process%get_model_ptr () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Set up branching and decay" write (u, "(A)") call flv%init (25, model) allocate (unstable) call unstable%init (flv) call unstable%init_decays ([procname2], model) write (u, "(A)") "* Connect decay with process object" write (u, "(A)") call unstable%connect_decay (1, process, model) call unstable%compute () call unstable%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call unstable%final () call process_stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_3" end subroutine decays_3 @ %def decays_3 @ \subsubsection{Decay and Process Object} Building upon the previous test, we set up a decay instance and generate a decay event. <>= call test (decays_4, "decays_4", & "decay instance", & u, results) <>= public :: decays_4 <>= subroutine decays_4 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_library_t), target :: lib type(string_t) :: prefix, procname2 class(rng_t), allocatable :: rng type(process_stack_t) :: process_stack type(process_t), pointer :: process type(unstable_config_t), allocatable, target :: unstable type(flavor_t) :: flv type(unstable_t), allocatable :: instance write (u, "(A)") "* Test output: decays_4" write (u, "(A)") "* Purpose: Create a decay process and evaluate & &an instance" write (u, "(A)") write (u, "(A)") "* Initialize environment, process, & &and decay configuration" write (u, "(A)") call os_data%init () prefix = "decays_4" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.false., decay=.true., decay_rest_frame = .false.) procname2 = prefix // "_d" process => process_stack%get_process_ptr (procname2) model => process%get_model_ptr () call flv%init (25, model) allocate (unstable) call unstable%init (flv) call unstable%init_decays ([procname2], model) call model%set_unstable (25, [procname2]) call unstable%connect_decay (1, process, model) call unstable%compute () allocate (rng_test_t :: rng) allocate (instance) call instance%init (unstable) call instance%import_rng (rng) call instance%select_chain () call instance%generate () call instance%write (u) write (u, *) call instance%write_process_instances (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call instance%final () call process_stack%final () call unstable%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_4" end subroutine decays_4 @ %def decays_4 @ \subsubsection{Decay with Parent Process} We define a scattering process $ss\to ss$ and subsequent decays $s\to f\bar f$. <>= call test (decays_5, "decays_5", & "parent process and decay", & u, results) <>= public :: decays_5 <>= subroutine decays_5 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_library_t), target :: lib type(string_t) :: prefix, procname1, procname2 type(process_stack_t) :: process_stack type(process_t), pointer :: process type(process_instance_t), allocatable, target :: process_instance type(decay_root_config_t), target :: decay_root_config type(decay_root_t) :: decay_root type(decay_chain_t) :: decay_chain write (u, "(A)") "* Test output: decays_5" write (u, "(A)") "* Purpose: Handle a process with subsequent decays" write (u, "(A)") write (u, "(A)") "* Initialize environment and parent process" write (u, "(A)") call os_data%init () prefix = "decays_5" procname1 = prefix // "_p" procname2 = prefix // "_d" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.true., decay=.true.) write (u, "(A)") "* Initialize decay process" write (u, "(A)") process => process_stack%get_process_ptr (procname1) model => process%get_model_ptr () call model%set_unstable (25, [procname2]) write (u, "(A)") "* Initialize decay tree configuration" write (u, "(A)") call decay_root_config%connect (process, model, process_stack) call decay_root_config%compute () call decay_root_config%write (u) write (u, "(A)") write (u, "(A)") "* Initialize decay tree" allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () call process_instance%init_simulation (1) call decay_root%init (decay_root_config, process_instance) write (u, "(A)") write (u, "(A)") "* Select decay chain" write (u, "(A)") call decay_root%set_mci (1) !!! Not yet implemented; there is only one term anyway: ! call process_instance%select_i_term (decay_root%selected_term) call decay_root%set_term (1) call decay_root%select_chain () call decay_chain%build (decay_root) call decay_root%write (u) write (u, "(A)") write (u, "(A)") "* Generate event" write (u, "(A)") call process_instance%generate_unweighted_event (decay_root%get_mci ()) call process_instance%evaluate_event_data () call decay_root%generate () call pacify (decay_root) write (u, "(A)") "* Process instances" write (u, "(A)") call decay_root%write_process_instances (u) write (u, "(A)") write (u, "(A)") "* Generate decay chain" write (u, "(A)") call decay_chain%evaluate () call decay_chain%write (u) write (u, *) write (u, "(A,ES19.12)") "chain probability =", & decay_chain%get_probability () write (u, "(A)") write (u, "(A)") "* Cleanup" call decay_chain%final () call decay_root%final () call decay_root_config%final () call process_instance%final () deallocate (process_instance) call process_stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_5" end subroutine decays_5 @ %def decays_5 @ \subsubsection{Decay as Event Transform} Again, we define a scattering process $ss\to ss$ and subsequent decays $s\to f\bar f$. <>= call test (decays_6, "decays_6", & "evt_decay object", & u, results) <>= public :: decays_6 <>= subroutine decays_6 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_library_t), target :: lib type(string_t) :: prefix, procname1, procname2 type(process_stack_t) :: process_stack type(process_t), pointer :: process type(process_instance_t), allocatable, target :: process_instance type(evt_decay_t), target :: evt_decay integer :: factorization_mode logical :: keep_correlations write (u, "(A)") "* Test output: decays_6" write (u, "(A)") "* Purpose: Handle a process with subsequent decays" write (u, "(A)") write (u, "(A)") "* Initialize environment and parent process" write (u, "(A)") call os_data%init () prefix = "decays_6" procname1 = prefix // "_p" procname2 = prefix // "_d" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.true., decay=.true.) write (u, "(A)") "* Initialize decay process" process => process_stack%get_process_ptr (procname1) model => process%get_model_ptr () call model%set_unstable (25, [procname2]) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () call process_instance%init_simulation (1) write (u, "(A)") write (u, "(A)") "* Initialize decay object" call evt_decay%connect (process_instance, model, process_stack) write (u, "(A)") write (u, "(A)") "* Generate scattering event" call process_instance%generate_unweighted_event (1) call process_instance%evaluate_event_data () write (u, "(A)") write (u, "(A)") "* Select decay chain and generate event" write (u, "(A)") call evt_decay%prepare_new_event (1, 1) call evt_decay%generate_unweighted () factorization_mode = FM_IGNORE_HELICITY keep_correlations = .false. call evt_decay%make_particle_set (factorization_mode, keep_correlations) call evt_decay%write (u, verbose = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_decay%final () call process_instance%final () deallocate (process_instance) call process_stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_6" end subroutine decays_6 @ %def decays_6 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Tau decays} <<[[tau_decays.f90]]>>= <> module tau_decays <> use io_units use format_utils, only: write_separator use sm_qcd use model_data use models use event_transforms <> <> <> contains <> end module tau_decays @ %def tau_decays \subsection{Tau Decays Event Transform} This is the type for the tau decay event transform. <>= public :: evt_tau_decays_t <>= type, extends (evt_t) :: evt_tau_decays_t type(model_t), pointer :: model_hadrons => null() type(qcd_t) :: qcd contains <> end type evt_tau_decays_t @ %def evt_tau_decays_t <>= procedure :: write_name => evt_tau_decays_write_name <>= subroutine evt_tau_decays_write_name (evt, unit) class(evt_tau_decays_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: tau decays" end subroutine evt_tau_decays_write_name @ %def evt_tau_decays_write_name @ Output. <>= procedure :: write => evt_tau_decays_write <>= subroutine evt_tau_decays_write (evt, unit, verbose, more_verbose, testflag) class(evt_tau_decays_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u) call evt%base_write (u, testflag = testflag, show_set = .false.) if (evt%particle_set_exists) & call evt%particle_set%write & (u, summary = .true., compressed = .true., testflag = testflag) call write_separator (u) end subroutine evt_tau_decays_write @ %def evt_tau_decays_write @ Here we take the particle set from the previous event transform and apply the tau decays. What probability should be given back, the product of branching ratios of the corresponding tau decays? <>= procedure :: generate_weighted => evt_tau_decays_generate_weighted <>= subroutine evt_tau_decays_generate_weighted (evt, probability) class(evt_tau_decays_t), intent(inout) :: evt real(default), intent(inout) :: probability logical :: valid evt%particle_set = evt%previous%particle_set !!! To be checked or expanded probability = 1 valid = .true. evt%particle_set_exists = valid end subroutine evt_tau_decays_generate_weighted @ %def evt_tau_decays_generate_weighted @ The factorization parameters are irrelevant. <>= procedure :: make_particle_set => evt_tau_decays_make_particle_set <>= subroutine evt_tau_decays_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_tau_decays_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r logical :: valid !!! to be checked and expanded valid = .true. evt%particle_set_exists = evt%particle_set_exists .and. valid end subroutine evt_tau_decays_make_particle_set @ %def event_tau_decays_make_particle_set @ <>= procedure :: prepare_new_event => evt_tau_decays_prepare_new_event <>= subroutine evt_tau_decays_prepare_new_event (evt, i_mci, i_term) class(evt_tau_decays_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () end subroutine evt_tau_decays_prepare_new_event @ %def evt_tau_decays_prepare_new_event @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Shower} We might use matrix elements of LO and NLO to increase the accuracy of the shower in the sense of matching as well as merging. <<[[shower.f90]]>>= <> module shower <> <> use io_units use format_utils, only: write_separator use system_defs, only: LF use os_interface use diagnostics use lorentz use pdf use subevents, only: PRT_BEAM_REMNANT, PRT_INCOMING, PRT_OUTGOING use shower_base use matching_base use powheg_matching, only: powheg_matching_t use sm_qcd use model_data use rng_base use event_transforms use models use hep_common use process, only: process_t use instances, only: process_instance_t use process_stacks <> <> <> <> contains <> end module shower @ %def shower @ \subsection{Configuration Parameters} [[POWHEG_TESTING]] allows to disable the parton shower for validation and testing of the POWHEG procedure. <>= logical, parameter :: POWHEG_TESTING = .false. @ %def POWHEG_TESTING @ \subsection{Event Transform} The event transforms can do more than mere showering. Especially, it may reweight showered events to fixed-order matrix elements. The [[model_hadrons]] is supposed to be the SM variant that contains all hadrons that can be generated in the shower. <>= public :: evt_shower_t <>= type, extends (evt_t) :: evt_shower_t class(shower_base_t), allocatable :: shower class(matching_t), allocatable :: matching type(model_t), pointer :: model_hadrons => null () type(qcd_t) :: qcd type(pdf_data_t) :: pdf_data type(os_data_t) :: os_data logical :: is_first_event contains <> end type evt_shower_t @ %def evt_shower_t @ <>= procedure :: write_name => evt_shower_write_name <>= subroutine evt_shower_write_name (evt, unit) class(evt_shower_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: shower" end subroutine evt_shower_write_name @ %def evt_shower_write_name @ Output. <>= procedure :: write => evt_shower_write <>= subroutine evt_shower_write (evt, unit, verbose, more_verbose, testflag) class(evt_shower_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u) call evt%base_write (u, testflag = testflag, show_set = .false.) if (evt%particle_set_exists) call evt%particle_set%write & (u, summary = .true., compressed = .true., testflag = testflag) call write_separator (u) call evt%shower%settings%write (u) end subroutine evt_shower_write @ %def evt_shower_write <>= procedure :: connect => evt_shower_connect <>= subroutine evt_shower_connect & (evt, process_instance, model, process_stack) class(evt_shower_t), intent(inout), target :: evt type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack call evt%base_connect (process_instance, model, process_stack) call evt%make_rng (evt%process) if (allocated (evt%matching)) then call evt%matching%connect (process_instance, model, evt%shower) end if end subroutine evt_shower_connect @ %def evt_shower_connect @ Initialize the event transformation. This will be executed once during dispatching. The [[model_hadrons]] is supposed to be the SM variant that contains all hadrons that may be generated in the shower. <>= procedure :: init => evt_shower_init <>= subroutine evt_shower_init (evt, model_hadrons, os_data) class(evt_shower_t), intent(out) :: evt type(model_t), intent(in), target :: model_hadrons type(os_data_t), intent(in) :: os_data evt%os_data = os_data evt%model_hadrons => model_hadrons evt%is_first_event = .true. end subroutine evt_shower_init @ %def evt_shower_init @ Create RNG instances, spawned by the process object. <>= procedure :: make_rng => evt_shower_make_rng <>= subroutine evt_shower_make_rng (evt, process) class(evt_shower_t), intent(inout) :: evt type(process_t), intent(inout) :: process class(rng_t), allocatable :: rng call process%make_rng (rng) call evt%shower%import_rng (rng) if (allocated (evt%matching)) then call process%make_rng (rng) call evt%matching%import_rng (rng) end if end subroutine evt_shower_make_rng @ %def evt_shower_make_rng @ Things we want to do for a new event before the whole event transformation chain is evaluated. <>= procedure :: prepare_new_event => evt_shower_prepare_new_event <>= subroutine evt_shower_prepare_new_event (evt, i_mci, i_term) class(evt_shower_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term real(default) :: fac_scale, alpha_s fac_scale = evt%process_instance%get_fac_scale (i_term) alpha_s = evt%process_instance%get_alpha_s (i_term) call evt%reset () call evt%shower%prepare_new_event (fac_scale, alpha_s) end subroutine evt_shower_prepare_new_event @ %def evt_shower_prepare_new_event @ <>= procedure :: first_event => evt_shower_first_event <>= subroutine evt_shower_first_event (evt) class(evt_shower_t), intent(inout) :: evt double precision :: pdftest call msg_debug (D_TRANSFORMS, "evt_shower_first_event") associate (settings => evt%shower%settings) settings%hadron_collision = .false. !!! !!! !!! Workaround for PGF90 v16.1 !!! if (all (evt%particle_set%prt(1:2)%flv%get_pdg_abs () <= 39)) then if (evt%particle_set%prt(1)%flv%get_pdg_abs () <= 39 .and. & evt%particle_set%prt(2)%flv%get_pdg_abs () <= 39) then settings%hadron_collision = .false. !!! else if (all (evt%particle_set%prt(1:2)%flv%get_pdg_abs () >= 100)) then else if (evt%particle_set%prt(1)%flv%get_pdg_abs () >= 100 .and. & evt%particle_set%prt(2)%flv%get_pdg_abs () >= 100) then settings%hadron_collision = .true. else call msg_fatal ("evt_shower didn't recognize beams setup") end if call msg_debug (D_TRANSFORMS, "hadron_collision", settings%hadron_collision) if (allocated (evt%matching)) then evt%matching%is_hadron_collision = settings%hadron_collision call evt%matching%first_event () end if if (.not. settings%hadron_collision .and. settings%isr_active) then call msg_fatal ("?ps_isr_active is only intended for hadron-collisions") end if if (evt%pdf_data%type == STRF_LHAPDF5) then if (settings%isr_active .and. settings%hadron_collision) then call GetQ2max (0, pdftest) if (pdftest < epsilon (pdftest)) then call msg_bug ("ISR QCD shower enabled, but LHAPDF not " // & "initialized," // LF // " aborting simulation") return end if end if else if (evt%pdf_data%type == STRF_PDF_BUILTIN .and. & settings%method == PS_PYTHIA6) then call msg_fatal ("Builtin PDFs cannot be used for PYTHIA showers," & // LF // " aborting simulation") return end if end associate evt%is_first_event = .false. end subroutine evt_shower_first_event @ %def evt_shower_first_event @ Here we take the particle set from the previous event transform (assuming that there is always one) and apply the shower algorithm. The result is stored in the event transform of the current object. We always return a probability of unity as we don't have the analytic weight of the combination of shower, MLM matching and hadronization. A subdivision into multiple event transformations is under construction. Invalid or vetoed events have to be discarded by the caller which is why we mark the particle set as invalid. This procedure directly takes the (MLM) matching into account. <>= procedure :: generate_weighted => evt_shower_generate_weighted <>= subroutine evt_shower_generate_weighted (evt, probability) class(evt_shower_t), intent(inout) :: evt real(default), intent(inout) :: probability logical :: valid, vetoed call msg_debug (D_TRANSFORMS, "evt_shower_generate_weighted") if (signal_is_pending ()) return evt%particle_set = evt%previous%particle_set valid = .true.; vetoed = .false. if (evt%is_first_event) call evt%first_event () call evt%shower%import_particle_set (evt%particle_set) if (allocated (evt%matching)) then call evt%matching%before_shower (evt%particle_set, vetoed) if (msg_level(D_TRANSFORMS) >= DEBUG) then call msg_debug (D_TRANSFORMS, "Matching before generate emissions") call evt%matching%write () end if end if if (.not. (vetoed .or. POWHEG_TESTING)) then if (evt%shower%settings%method == PS_PYTHIA6 .or. & evt%shower%settings%hadronization_active) then call assure_heprup (evt%particle_set) end if call evt%shower%generate_emissions (valid) end if probability = 1 evt%particle_set_exists = valid .and. .not. vetoed end subroutine evt_shower_generate_weighted @ %def evt_shower_generate_weighted @ Here, we fill the particle set with the partons from the shower. The factorization parameters are irrelevant. We make a sanity check that the initial energy lands either in the outgoing particles or add to the beam remnant. <>= procedure :: make_particle_set => evt_shower_make_particle_set <>= subroutine evt_shower_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_shower_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r type(vector4_t) :: sum_vec_in, sum_vec_out, sum_vec_beamrem, & sum_vec_beamrem_before logical :: vetoed, sane if (evt%particle_set_exists) then vetoed = .false. sum_vec_beamrem_before = sum (evt%particle_set%prt%p, & mask=evt%particle_set%prt%get_status () == PRT_BEAM_REMNANT) call evt%shower%make_particle_set (evt%particle_set, & evt%model, evt%model_hadrons) if (allocated (evt%matching)) then call evt%matching%after_shower (evt%particle_set, vetoed) end if if (debug_active (D_TRANSFORMS)) then call msg_debug (D_TRANSFORMS, & "Shower: obtained particle set after shower + matching") call evt%particle_set%write (summary = .true., compressed = .true.) end if sum_vec_in = sum (evt%particle_set%prt%p, & mask=evt%particle_set%prt%get_status () == PRT_INCOMING) sum_vec_out = sum (evt%particle_set%prt%p, & mask=evt%particle_set%prt%get_status () == PRT_OUTGOING) sum_vec_beamrem = sum (evt%particle_set%prt%p, & mask=evt%particle_set%prt%get_status () == PRT_BEAM_REMNANT) sum_vec_beamrem = sum_vec_beamrem - sum_vec_beamrem_before sane = abs(sum_vec_out%p(0) - sum_vec_in%p(0)) < & sum_vec_in%p(0) / 10 .or. & abs((sum_vec_out%p(0) + sum_vec_beamrem%p(0)) - sum_vec_in%p(0)) < & sum_vec_in%p(0) / 10 sane = .true. evt%particle_set_exists = .not. vetoed .and. sane end if end subroutine evt_shower_make_particle_set @ %def event_shower_make_particle_set @ <>= procedure :: contains_powheg_matching => evt_shower_contains_powheg_matching <>= function evt_shower_contains_powheg_matching (evt) result (val) logical :: val class(evt_shower_t), intent(in) :: evt val = .false. if (allocated (evt%matching)) & val = evt%matching%get_method () == "POWHEG" end function evt_shower_contains_powheg_matching @ %def evt_shower_contains_powheg_matching @ <>= procedure :: disable_powheg_matching => evt_shower_disable_powheg_matching <>= subroutine evt_shower_disable_powheg_matching (evt) class(evt_shower_t), intent(inout) :: evt select type (matching => evt%matching) type is (powheg_matching_t) matching%active = .false. class default call msg_fatal ("Trying to disable powheg but no powheg matching is allocated!") end select end subroutine evt_shower_disable_powheg_matching @ %def evt_shower_disable_powheg_matching @ <>= procedure :: enable_powheg_matching => evt_shower_enable_powheg_matching <>= subroutine evt_shower_enable_powheg_matching (evt) class(evt_shower_t), intent(inout) :: evt select type (matching => evt%matching) type is (powheg_matching_t) matching%active = .true. class default call msg_fatal ("Trying to enable powheg but no powheg matching is allocated!") end select end subroutine evt_shower_enable_powheg_matching @ %def evt_shower_enable_powheg_matching @ <>= procedure :: final => evt_shower_final <>= subroutine evt_shower_final (evt) class(evt_shower_t), intent(inout) :: evt call evt%base_final () if (allocated (evt%matching)) call evt%matching%final () end subroutine evt_shower_final @ %def evt_shower_final @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[shower_ut.f90]]>>= <> module shower_ut use unit_tests use shower_uti <> <> contains <> end module shower_ut @ %def shower_ut @ <<[[shower_uti.f90]]>>= <> module shower_uti <> <> use format_utils, only: write_separator use os_interface use sm_qcd use physics_defs, only: BORN use model_data use models use state_matrices, only: FM_IGNORE_HELICITY use process_libraries use rng_base use rng_tao use dispatch_rng, only: dispatch_rng_factory_fallback use mci_base use mci_midpoint use phs_base use phs_single use prc_core_def, only: prc_core_def_t use prc_core use prc_omega use variables use event_transforms use tauola_interface !NODEP! use process, only: process_t use instances, only: process_instance_t use pdf use shower_base use shower_core use dispatch_rng_ut, only: dispatch_rng_factory_tao use shower <> <> contains <> end module shower_uti @ %def shower_uti @ API: driver for the unit tests below. <>= public :: shower_test <>= subroutine shower_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine shower_test @ %def shower_test @ \subsubsection{Testbed} This sequence sets up a two-jet process, ready for generating events. <>= <> @ <>= subroutine setup_testbed & (prefix, os_data, lib, model_list, process, process_instance) type(string_t), intent(in) :: prefix type(os_data_t), intent(out) :: os_data type(process_library_t), intent(out), target :: lib type(model_list_t), intent(out) :: model_list type(model_t), pointer :: model type(model_t), pointer :: model_tmp type(process_t), target, intent(out) :: process type(process_instance_t), target, intent(out) :: process_instance type(var_list_t), pointer :: model_vars type(string_t) :: model_name, libname, procname type(process_def_entry_t), pointer :: entry type(string_t), dimension(:), allocatable :: prt_in, prt_out class(prc_core_t), allocatable :: core_template class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts model_name = "SM" libname = prefix // "_lib" procname = prefix // "p" call os_data%init () dispatch_rng_factory_fallback => dispatch_rng_factory_tao allocate (model_tmp) call model_list%read_model (model_name, model_name // ".mdl", & os_data, model_tmp) model_vars => model_tmp%get_var_list_ptr () call model_vars%set_real (var_str ("me"), 0._default, & is_known = .true.) model => model_tmp call lib%init (libname) allocate (prt_in (2), source = [var_str ("e-"), var_str ("e+")]) allocate (prt_out (2), source = [var_str ("d"), var_str ("dbar")]) allocate (entry) call entry%init (procname, model, n_in = 2, n_components = 1) call omega_make_process_component (entry, 1, & model_name, prt_in, prt_out, & report_progress=.true.) call lib%append (entry) call lib%configure (os_data) call lib%write_makefile (os_data, force = .true., verbose = .false.) call lib%clean (os_data, distclean = .false.) call lib%write_driver (force = .true.) call lib%load (os_data) call process%init (procname, lib, os_data, model) allocate (prc_omega_t :: core_template) allocate (phs_single_config_t :: phs_config_template) call process%setup_cores (dispatch_core_omega_test) call process%init_components (phs_config_template) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test_midpoint) call process%setup_terms () call process_instance%init (process) call process_instance%integrate (1, 1, 1000) call process%final_integration (1) call process_instance%setup_event_data (i_core = 1) call process_instance%init_simulation (1) call process_instance%generate_weighted_event (1) call process_instance%evaluate_event_data () end subroutine setup_testbed @ %def setup_testbed @ A minimal dispatcher version that allocates the core object for testing. <>= subroutine dispatch_core_omega_test (core, core_def, model, & helicity_selection, qcd, use_color_factors, has_beam_pol) class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_def_t), intent(in) :: core_def class(model_data_t), intent(in), target, optional :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol allocate (prc_omega_t :: core) select type (core) type is (prc_omega_t) call core%set_parameters (model) end select end subroutine dispatch_core_omega_test @ %def dispatch_core_omega_test @ MCI record prepared for midpoint integrator. <>= subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo) use variables, only: var_list_t class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_midpoint_t :: mci) end subroutine dispatch_mci_test_midpoint @ %def dispatch_mci_test_midpoint @ \subsubsection{Trivial Test} We generate a two-jet event and shower it using default settings, i.e. in disabled mode. <>= call test (shower_1, "shower_1", & "disabled shower", & u, results) <>= public :: shower_1 <>= subroutine shower_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(process_library_t), target :: lib type(model_list_t) :: model_list class(model_data_t), pointer :: model type(model_t), pointer :: model_hadrons type(process_t), target :: process type(process_instance_t), target :: process_instance type(pdf_data_t) :: pdf_data integer :: factorization_mode logical :: keep_correlations class(evt_t), allocatable, target :: evt_trivial class(evt_t), allocatable, target :: evt_shower type(shower_settings_t) :: settings type(taudec_settings_t) :: taudec_settings write (u, "(A)") "* Test output: shower_1" write (u, "(A)") "* Purpose: Two-jet event with disabled shower" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"), & os_data, model_hadrons) call setup_testbed (var_str ("shower_1"), & os_data, lib, model_list, process, process_instance) write (u, "(A)") "* Set up trivial transform" write (u, "(A)") allocate (evt_trivial_t :: evt_trivial) model => process%get_model_ptr () call evt_trivial%connect (process_instance, model) call evt_trivial%prepare_new_event (1, 1) call evt_trivial%generate_unweighted () factorization_mode = FM_IGNORE_HELICITY keep_correlations = .false. call evt_trivial%make_particle_set (factorization_mode, keep_correlations) select type (evt_trivial) type is (evt_trivial_t) call evt_trivial%write (u) call write_separator (u, 2) end select write (u, "(A)") write (u, "(A)") "* Set up shower event transform" write (u, "(A)") allocate (evt_shower_t :: evt_shower) select type (evt_shower) type is (evt_shower_t) call evt_shower%init (model_hadrons, os_data) allocate (shower_t :: evt_shower%shower) call evt_shower%shower%init (settings, taudec_settings, pdf_data, os_data) call evt_shower%connect (process_instance, model) end select evt_trivial%next => evt_shower evt_shower%previous => evt_trivial call evt_shower%prepare_new_event (1, 1) call evt_shower%generate_unweighted () call evt_shower%make_particle_set (factorization_mode, keep_correlations) select type (evt_shower) type is (evt_shower_t) call evt_shower%write (u) call write_separator (u, 2) end select write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_shower%final () call evt_trivial%final () call process_instance%final () call process%final () call lib%final () call model_hadrons%final () deallocate (model_hadrons) call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: shower_1" end subroutine shower_1 @ %def shower_1 @ \subsubsection{FSR Shower} We generate a two-jet event and shower it with the Whizard FSR shower. <>= call test (shower_2, "shower_2", & "final-state shower", & u, results) <>= public :: shower_2 <>= subroutine shower_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(process_library_t), target :: lib type(model_list_t) :: model_list type(model_t), pointer :: model_hadrons class(model_data_t), pointer :: model type(process_t), target :: process type(process_instance_t), target :: process_instance integer :: factorization_mode logical :: keep_correlations type(pdf_data_t) :: pdf_data class(evt_t), allocatable, target :: evt_trivial class(evt_t), allocatable, target :: evt_shower type(shower_settings_t) :: settings type(taudec_settings_t) :: taudec_settings write (u, "(A)") "* Test output: shower_2" write (u, "(A)") "* Purpose: Two-jet event with FSR shower" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"), & os_data, model_hadrons) call setup_testbed (var_str ("shower_2"), & os_data, lib, model_list, process, process_instance) model => process%get_model_ptr () write (u, "(A)") "* Set up trivial transform" write (u, "(A)") allocate (evt_trivial_t :: evt_trivial) call evt_trivial%connect (process_instance, model) call evt_trivial%prepare_new_event (1, 1) call evt_trivial%generate_unweighted () factorization_mode = FM_IGNORE_HELICITY keep_correlations = .false. call evt_trivial%make_particle_set (factorization_mode, keep_correlations) select type (evt_trivial) type is (evt_trivial_t) call evt_trivial%write (u) call write_separator (u, 2) end select write (u, "(A)") write (u, "(A)") "* Set up shower event transform" write (u, "(A)") settings%fsr_active = .true. allocate (evt_shower_t :: evt_shower) select type (evt_shower) type is (evt_shower_t) call evt_shower%init (model_hadrons, os_data) allocate (shower_t :: evt_shower%shower) call evt_shower%shower%init (settings, taudec_settings, pdf_data, os_data) call evt_shower%connect (process_instance, model) end select evt_trivial%next => evt_shower evt_shower%previous => evt_trivial call evt_shower%prepare_new_event (1, 1) call evt_shower%generate_unweighted () call evt_shower%make_particle_set (factorization_mode, keep_correlations) select type (evt_shower) type is (evt_shower_t) call evt_shower%write (u, testflag = .true.) call write_separator (u, 2) end select write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_shower%final () call evt_trivial%final () call process_instance%final () call process%final () call lib%final () call model_hadrons%final () deallocate (model_hadrons) call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: shower_2" end subroutine shower_2 @ %def shower_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Fixed Order NLO Events} This section deals with the generation of weighted event samples which take into account next-to-leading order corrections. An approach generating unweighted events is not possible here, because negative weights might occur due to subtraction. Note that the events produced this way are not physical in the sense that they will not keep NLO-accuracy when interfaced to a parton shower. They are rather useful for theoretical consistency checks and a fast estimate of NLO effects.\\ We generate NLO events in the following way: First, the integration is carried out using the complete divergence-subtracted NLO matrix element. In the subsequent simulation, $N$-particle kinematics are generated using $\mathcal{B}+\mathcal{V}+\mathcal{C}$ as weight. After that, the program loops over all singular regions and for each of them generates an event with $N+1$-particle kinematics. The weight for those events corresponds to the real matrix element $\mathcal{R}^\alpha$ evaluated at the $\alpha$-region's emitter's phase space point, multiplied with $S_\alpha$. This procedure is implemented using the [[evt_nlo]] transform. <<[[evt_nlo.f90]]>>= <> module evt_nlo <> <> use io_units, only: given_output_unit use constants use lorentz use diagnostics use physics_defs, only: NLO_REAL use sm_qcd use model_data use particles use instances, only: process_instance_t - ! TODO (cw-2016-09-16): Ideally, only pcm_base use pcm, only: pcm_nlo_t, pcm_instance_nlo_t use process_stacks use event_transforms use phs_fks, only: phs_fks_t, phs_fks_generator_t use phs_fks, only: phs_identifier_t, phs_point_set_t use resonances, only: resonance_contributors_t use fks_regions, only: region_data_t <> <> <> <> contains <> end module evt_nlo @ %def evt_nlo @ <>= type :: nlo_event_deps_t logical :: cm_frame = .true. type(phs_point_set_t) :: p_born_cms type(phs_point_set_t) :: p_born_lab type(phs_point_set_t) :: p_real_cms type(phs_point_set_t) :: p_real_lab type(resonance_contributors_t), dimension(:), allocatable :: contributors type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers integer, dimension(:), allocatable :: alr_to_i_con integer :: n_phs = 0 end type nlo_event_deps_t @ %def nlo_event_deps_t @ This event transformation is for the generation of fixed-order NLO events. It takes an event with Born kinematics and creates $N_\alpha + 1$ modified weighted events. The first one has Born kinematics and its weight is the sum of Born, Real and subtraction matrix elements. The other $N_\alpha$ events have a weight which is equal to the real matrix element, evaluated with the phase space corresponding to the emitter of the $\alpha$-region. All NLO event objects share the same event transformation. For this reason, we save the particle set of the current $\alpha$-region in the array [[particle_set_radiated]]. Otherwise it would be unretrievable if the usual particle set of the event object was used.@ <>= integer, parameter, public :: EVT_NLO_UNDEFINED = 0 integer, parameter, public :: EVT_NLO_SEPARATE_BORNLIKE = 1 integer, parameter, public :: EVT_NLO_SEPARATE_REAL = 2 integer, parameter, public :: EVT_NLO_COMBINED = 3 <>= public :: evt_nlo_t <>= type, extends (evt_t) :: evt_nlo_t type(phs_fks_generator_t) :: phs_fks_generator real(default) :: sqme_rad = zero integer :: i_evaluation = 0 integer :: weight_multiplier = 1 type(particle_set_t), dimension(:), allocatable :: particle_set_radiated type(qcd_t) :: qcd type(nlo_event_deps_t) :: event_deps integer :: mode = EVT_NLO_UNDEFINED integer, dimension(:), allocatable :: & i_evaluation_to_i_phs, i_evaluation_to_emitter, & i_evaluation_to_i_term logical :: keep_failed_events = .false. integer :: selected_i_flv = 0 contains <> end type evt_nlo_t @ %def evt_nlo_t @ <>= procedure :: write_name => evt_nlo_write_name <>= subroutine evt_nlo_write_name (evt, unit) class(evt_nlo_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: NLO" end subroutine evt_nlo_write_name @ %def evt_nlo_write_name @ <>= procedure :: write => evt_nlo_write <>= subroutine evt_nlo_write (evt, unit, verbose, more_verbose, testflag) class(evt_nlo_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag end subroutine evt_nlo_write @ %def evt_nlo_write @ Connects the event transform to the process. Here also the phase space is set up by making [[real_kinematics]] point to the corresponding object in the [[pcm_instance]]. <>= procedure :: connect => evt_nlo_connect <>= subroutine evt_nlo_connect (evt, process_instance, model, process_stack) class(evt_nlo_t), intent(inout), target :: evt type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack call msg_debug (D_TRANSFORMS, "evt_nlo_connect") call evt%base_connect (process_instance, model, process_stack) select type (pcm => process_instance%pcm) class is (pcm_instance_nlo_t) select type (config => pcm%config) type is (pcm_nlo_t) call config%setup_phs_generator (pcm, evt%phs_fks_generator, & process_instance%get_sqrts ()) call evt%set_i_evaluation_mappings (config%region_data, & pcm%real_kinematics%alr_to_i_phs) end select end select call evt%set_mode (process_instance) call evt%setup_general_event_kinematics (process_instance) if (evt%mode > EVT_NLO_SEPARATE_BORNLIKE) & call evt%setup_real_event_kinematics (process_instance) call msg_debug2 (D_TRANSFORMS, "evt_nlo_connect: success") end subroutine evt_nlo_connect @ %def evt_nlo_connect @ <>= procedure :: set_i_evaluation_mappings => evt_nlo_set_i_evaluation_mappings <>= subroutine evt_nlo_set_i_evaluation_mappings (evt, reg_data, alr_to_i_phs) class(evt_nlo_t), intent(inout) :: evt type(region_data_t), intent(in) :: reg_data integer, intent(in), dimension(:) :: alr_to_i_phs integer :: n_phs, alr integer :: i_evaluation, i_phs, emitter logical :: checked type :: registered_triple_t integer, dimension(2) :: phs_em type(registered_triple_t), pointer :: next => null () end type registered_triple_t type(registered_triple_t), allocatable, target :: check_list i_evaluation = 1 n_phs = reg_data%n_phs evt%weight_multiplier = n_phs + 1 allocate (evt%i_evaluation_to_i_phs (n_phs), source = 0) allocate (evt%i_evaluation_to_emitter (n_phs), source = -1) allocate (evt%i_evaluation_to_i_term (0 : n_phs), source = 0) do alr = 1, reg_data%n_regions i_phs = alr_to_i_phs (alr) emitter = reg_data%regions(alr)%emitter call search_check_list (checked) if (.not. checked) then evt%i_evaluation_to_i_phs (i_evaluation) = i_phs evt%i_evaluation_to_emitter (i_evaluation) = emitter i_evaluation = i_evaluation + 1 end if end do call fill_i_evaluation_to_i_term () if (.not. (all (evt%i_evaluation_to_i_phs > 0) & .and. all (evt%i_evaluation_to_emitter > -1))) then call msg_fatal ("evt_nlo: Inconsistent mappings!") else if (debug2_active (D_TRANSFORMS)) then print *, 'evt_nlo Mappings, i_evaluation -> ' print *, 'i_phs: ', evt%i_evaluation_to_i_phs print *, 'emitter: ', evt%i_evaluation_to_emitter end if end if contains subroutine fill_i_evaluation_to_i_term () integer :: i_term, i_evaluation, term_emitter !!! First find subtraction component i_evaluation = 1 do i_term = 1, evt%process%get_n_terms () if (evt%process_instance%term(i_term)%nlo_type /= NLO_REAL) cycle term_emitter = evt%process_instance%term(i_term)%k_term%emitter if (term_emitter < 0) then evt%i_evaluation_to_i_term (0) = i_term else if (evt%i_evaluation_to_emitter(i_evaluation) == term_emitter) then evt%i_evaluation_to_i_term (i_evaluation) = i_term i_evaluation = i_evaluation + 1 end if end do end subroutine fill_i_evaluation_to_i_term subroutine search_check_list (found) logical, intent(out) :: found type(registered_triple_t), pointer :: current_triple => null () if (allocated (check_list)) then current_triple => check_list do if (all (current_triple%phs_em == [i_phs, emitter])) then found = .true. exit end if if (.not. associated (current_triple%next)) then allocate (current_triple%next) current_triple%next%phs_em = [i_phs, emitter] found = .false. exit else current_triple => current_triple%next end if end do else allocate (check_list) check_list%phs_em = [i_phs, emitter] found = .false. end if end subroutine search_check_list end subroutine evt_nlo_set_i_evaluation_mappings @ %def evt_nlo_set_i_evaluation_mappings @ <>= procedure :: get_i_phs => evt_nlo_get_i_phs <>= function evt_nlo_get_i_phs (evt) result (i_phs) integer :: i_phs class(evt_nlo_t), intent(in) :: evt i_phs = evt%i_evaluation_to_i_phs (evt%i_evaluation) end function evt_nlo_get_i_phs @ %def evt_nlo_get_i_phs @ <>= procedure :: get_emitter => evt_nlo_get_emitter <>= function evt_nlo_get_emitter (evt) result (emitter) integer :: emitter class(evt_nlo_t), intent(in) :: evt emitter = evt%i_evaluation_to_emitter (evt%i_evaluation) end function evt_nlo_get_emitter @ %def evt_nlo_get_emitter @ <>= procedure :: get_i_term => evt_nlo_get_i_term <>= function evt_nlo_get_i_term (evt) result (i_term) integer :: i_term class(evt_nlo_t), intent(in) :: evt if (evt%mode >= EVT_NLO_SEPARATE_REAL) then i_term = evt%i_evaluation_to_i_term (evt%i_evaluation) else i_term = evt%process_instance%get_first_active_i_term () end if end function evt_nlo_get_i_term @ %def evt_nlo_get_i_term @ <>= procedure :: copy_previous_particle_set => evt_nlo_copy_previous_particle_set <>= subroutine evt_nlo_copy_previous_particle_set (evt) class(evt_nlo_t), intent(inout) :: evt if (associated (evt%previous)) then evt%particle_set = evt%previous%particle_set else call msg_fatal ("evt_nlo requires one preceeding evt_trivial!") end if end subroutine evt_nlo_copy_previous_particle_set @ %def evt_nlo_copy_previous_particle_set @ The event transform has a variable which counts the number of times it has already been called for one generation point. If [[i_evaluation]] is zero, this means that [[evt_nlo_generate]] is called for the first time, so that the generation of an $N$-particle event is required. In all other cases, emission events are generated.\\ Note that for the first event, the computed weights are added to [[probability]], which at this point is equal to $\mathcal{B} + \mathcal{V}$, whereas for all other runs [[probability]] is replaced. To keep $<\sum{w_i}>=N\times\sigma$ as it is for weighted LO events, we have to multiply by $N_{\rm{phs}} + 1$ since the cross section is distributed over the real and Born subevents. <>= procedure :: generate_weighted => evt_nlo_generate_weighted <>= subroutine evt_nlo_generate_weighted (evt, probability) class(evt_nlo_t), intent(inout) :: evt real(default), intent(inout) :: probability real(default) :: weight call print_debug_info () if (evt%mode > EVT_NLO_SEPARATE_BORNLIKE) then if (evt%i_evaluation == 0) then call evt%reset_phs_identifiers () call evt%evaluate_real_kinematics () weight = evt%compute_subtraction_weights () if (evt%mode == EVT_NLO_SEPARATE_REAL) then probability = weight else probability = probability + weight end if else call evt%compute_real () probability = evt%sqme_rad end if call msg_debug2 (D_TRANSFORMS, "event weight multiplier:", evt%weight_multiplier) probability = probability * evt%weight_multiplier end if call msg_debug (D_TRANSFORMS, "probability (after)", probability) evt%particle_set_exists = .true. contains function status_code_to_string (mode) result (smode) type(string_t) :: smode integer, intent(in) :: mode select case (mode) case (EVT_NLO_UNDEFINED) smode = var_str ("Undefined") case (EVT_NLO_SEPARATE_BORNLIKE) smode = var_str ("Born-like") case (EVT_NLO_SEPARATE_REAL) smode = var_str ("Real") case (EVT_NLO_COMBINED) smode = var_str ("Combined") end select end function status_code_to_string subroutine print_debug_info () call msg_debug (D_TRANSFORMS, "evt_nlo_generate_weighted") call msg_debug (D_TRANSFORMS, char ("mode: " // status_code_to_string (evt%mode))) call msg_debug (D_TRANSFORMS, "probability (before)", probability) call msg_debug (D_TRANSFORMS, "evt%i_evaluation", evt%i_evaluation) if (debug2_active (D_TRANSFORMS)) then if (evt%mode > EVT_NLO_SEPARATE_BORNLIKE) then if (evt%i_evaluation == 0) then print *, 'Evaluate subtraction component' else print *, 'Evaluate radiation component' end if end if end if end subroutine print_debug_info end subroutine evt_nlo_generate_weighted @ %def evt_nlo_generate_weighted @ <>= procedure :: reset_phs_identifiers => evt_nlo_reset_phs_identifiers <>= subroutine evt_nlo_reset_phs_identifiers (evt) class(evt_nlo_t), intent(inout) :: evt evt%event_deps%phs_identifiers%evaluated = .false. end subroutine evt_nlo_reset_phs_identifiers @ %def evt_nlo_reset_phs_identifiers @ <>= procedure :: make_particle_set => evt_nlo_make_particle_set <>= subroutine evt_nlo_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_nlo_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r if (evt%mode >= EVT_NLO_SEPARATE_BORNLIKE) then select type (config => evt%process_instance%pcm%config) type is (pcm_nlo_t) if (evt%i_evaluation > 0) then call make_factorized_particle_set (evt, factorization_mode, & keep_correlations, r, evt%get_i_term (), & config%qn_real(:, evt%selected_i_flv)) else call make_factorized_particle_set (evt, factorization_mode, & keep_correlations, r, evt%get_i_term (), & config%qn_born(:, evt%selected_i_flv)) end if end select else call make_factorized_particle_set (evt, factorization_mode, & keep_correlations, r) end if end subroutine evt_nlo_make_particle_set @ %def evt_nlo_make_particle_set @ <>= procedure :: keep_and_boost_born_particle_set => & evt_nlo_keep_and_boost_born_particle_set <>= subroutine evt_nlo_keep_and_boost_born_particle_set (evt, i_event) class(evt_nlo_t), intent(inout) :: evt integer, intent(in) :: i_event evt%particle_set_radiated(i_event) = evt%particle_set if (evt%event_deps%cm_frame) then evt%event_deps%p_born_cms%phs_point(1) = & evt%particle_set%get_in_and_out_momenta () evt%event_deps%p_born_lab%phs_point(1) = & evt%boost_to_lab (evt%event_deps%p_born_cms%phs_point(1)) call evt%particle_set_radiated(i_event)%replace_incoming_momenta & (evt%event_deps%p_born_lab%phs_point(1)%p) call evt%particle_set_radiated(i_event)%replace_outgoing_momenta & (evt%event_deps%p_born_lab%phs_point(1)%p) end if end subroutine evt_nlo_keep_and_boost_born_particle_set @ %def evt_nlo_keep_and_boost_born_particle_set @ <>= procedure :: evaluate_real_kinematics => evt_nlo_evaluate_real_kinematics <>= subroutine evt_nlo_evaluate_real_kinematics (evt) class(evt_nlo_t), intent(inout) :: evt integer :: alr, i_phs, i_con, emitter real(default), dimension(3) :: x_rad logical :: use_contributors integer :: i_term select type (pcm => evt%process_instance%pcm) class is (pcm_instance_nlo_t) x_rad = pcm%real_kinematics%x_rad associate (event_deps => evt%event_deps) i_term = evt%get_i_term () event_deps%p_born_lab%phs_point(1) = & evt%process_instance%term(i_term)%connected%matrix%get_momenta () event_deps%p_born_cms%phs_point(1) & = evt%boost_to_cms (event_deps%p_born_lab%phs_point(1)) call evt%phs_fks_generator%set_sqrts_hat & (event_deps%p_born_cms%get_energy (1, 1)) use_contributors = allocated (event_deps%contributors) do alr = 1, pcm%get_n_regions () i_phs = pcm%real_kinematics%alr_to_i_phs(alr) if (event_deps%phs_identifiers(i_phs)%evaluated) cycle emitter = event_deps%phs_identifiers(i_phs)%emitter associate (generator => evt%phs_fks_generator) !!! TODO: (cw-2016-12-30): Replace by n_in if (emitter <= 2) then call generator%prepare_generation (x_rad, i_phs, emitter, & event_deps%p_born_cms%phs_point(1)%p, event_deps%phs_identifiers) call generator%generate_isr (i_phs, & event_deps%p_born_lab%phs_point(1)%p, & event_deps%p_real_lab%phs_point(i_phs)%p) event_deps%p_real_cms%phs_point(i_phs) & = evt%boost_to_cms (event_deps%p_real_lab%phs_point(i_phs)) else if (use_contributors) then i_con = event_deps%alr_to_i_con(alr) call generator%prepare_generation (x_rad, i_phs, emitter, & event_deps%p_born_cms%phs_point(1)%p, & event_deps%phs_identifiers, event_deps%contributors, i_con) call generator%generate_fsr (emitter, i_phs, i_con, & event_deps%p_born_cms%phs_point(1)%p, & event_deps%p_real_cms%phs_point(i_phs)%p) else call generator%prepare_generation (x_rad, i_phs, emitter, & event_deps%p_born_cms%phs_point(1)%p, event_deps%phs_identifiers) call generator%generate_fsr (emitter, i_phs, & event_deps%p_born_cms%phs_point(1)%p, & event_deps%p_real_cms%phs_point(i_phs)%p) end if event_deps%p_real_lab%phs_point(i_phs) & = evt%boost_to_lab (event_deps%p_real_cms%phs_point(i_phs)) end if end associate call pcm%set_momenta (event_deps%p_born_lab%phs_point(1)%p, & event_deps%p_real_lab%phs_point(i_phs)%p, i_phs) call pcm%set_momenta (event_deps%p_born_cms%phs_point(1)%p, & event_deps%p_real_cms%phs_point(i_phs)%p, i_phs, cms = .true.) event_deps%phs_identifiers(i_phs)%evaluated = .true. end do end associate end select end subroutine evt_nlo_evaluate_real_kinematics @ %def evt_nlo_evaluate_real_kinematics @ This routine calls the evaluation of the singular regions only for the subtraction terms. <>= procedure :: compute_subtraction_weights => evt_nlo_compute_subtraction_weights <>= function evt_nlo_compute_subtraction_weights (evt) result (weight) class(evt_nlo_t), intent(inout) :: evt real(default) :: weight integer :: i_phs, i_term call msg_debug (D_TRANSFORMS, "evt_nlo_compute_subtraction_weights") weight = zero select type (pcm => evt%process_instance%pcm) class is (pcm_instance_nlo_t) associate (event_deps => evt%event_deps) i_phs = 1; i_term = evt%i_evaluation_to_i_term(0) call evt%process_instance%compute_sqme_rad (i_term, i_phs, .true.) weight = weight + evt%process_instance%get_sqme (i_term) end associate end select end function evt_nlo_compute_subtraction_weights @ %def evt_nlo_compute_subtraction_weights @ This routine calls the evaluation of the singular regions only for emission matrix elements. <>= procedure :: compute_real => evt_nlo_compute_real <>= subroutine evt_nlo_compute_real (evt) class(evt_nlo_t), intent(inout) :: evt integer :: i_phs, i_term call msg_debug (D_TRANSFORMS, "evt_nlo_compute_real") i_phs = evt%get_i_phs () i_term = evt%i_evaluation_to_i_term (evt%i_evaluation) select type (pcm => evt%process_instance%pcm) class is (pcm_instance_nlo_t) associate (event_deps => evt%event_deps) call evt%process_instance%compute_sqme_rad (i_term, i_phs, .false.) evt%sqme_rad = evt%process_instance%get_sqme (i_term) end associate end select end subroutine evt_nlo_compute_real @ %def evt_nlo_compute_real @ <>= procedure :: boost_to_cms => evt_nlo_boost_to_cms <>= function evt_nlo_boost_to_cms (evt, p_lab) result (p_cms) type(phs_point_t), intent(in) :: p_lab class(evt_nlo_t), intent(in) :: evt type(phs_point_t) :: p_cms type(lorentz_transformation_t) :: lt_lab_to_cms integer :: i_boost if (evt%event_deps%cm_frame) then lt_lab_to_cms = identity else if (evt%mode == EVT_NLO_COMBINED) then i_boost = 1 else i_boost = evt%process_instance%select_i_term () end if lt_lab_to_cms = evt%process_instance%get_boost_to_cms (i_boost) end if p_cms = lt_lab_to_cms * p_lab end function evt_nlo_boost_to_cms @ %def evt_nlo_boost_to_cms @ <>= procedure :: boost_to_lab => evt_nlo_boost_to_lab <>= function evt_nlo_boost_to_lab (evt, p_cms) result (p_lab) type(phs_point_t) :: p_lab class(evt_nlo_t), intent(in) :: evt type(phs_point_t), intent(in) :: p_cms type(lorentz_transformation_t) :: lt_cms_to_lab integer :: i_boost if (.not. evt%event_deps%cm_frame) then lt_cms_to_lab = identity else if (evt%mode == EVT_NLO_COMBINED) then i_boost = 1 else i_boost = evt%process_instance%select_i_term () end if lt_cms_to_lab = evt%process_instance%get_boost_to_lab (i_boost) end if p_lab = lt_cms_to_lab * p_cms end function evt_nlo_boost_to_lab @ %def evt_nlo_boost_to_lab @ <>= procedure :: setup_general_event_kinematics => evt_nlo_setup_general_event_kinematics <>= subroutine evt_nlo_setup_general_event_kinematics (evt, process_instance) class(evt_nlo_t), intent(inout) :: evt type(process_instance_t), intent(in) :: process_instance integer :: n_born associate (event_deps => evt%event_deps) event_deps%cm_frame = process_instance%is_cm_frame (1) select type (pcm => process_instance%pcm) type is (pcm_instance_nlo_t) n_born = pcm%get_n_born () end select call event_deps%p_born_cms%init (n_born, 1) call event_deps%p_born_lab%init (n_born, 1) end associate end subroutine evt_nlo_setup_general_event_kinematics @ %def evt_nlo_setup_general_event_kinematics @ <>= procedure :: setup_real_event_kinematics => evt_nlo_setup_real_event_kinematics <>= subroutine evt_nlo_setup_real_event_kinematics (evt, process_instance) class(evt_nlo_t), intent(inout) :: evt type(process_instance_t), intent(in) :: process_instance integer :: n_real, n_phs integer :: i_real associate (event_deps => evt%event_deps) select type (pcm => process_instance%pcm) class is (pcm_instance_nlo_t) n_real = pcm%get_n_real () end select i_real = evt%process%get_first_real_term () select type (phs => process_instance%term(i_real)%k_term%phs) type is (phs_fks_t) event_deps%phs_identifiers = phs%phs_identifiers end select n_phs = size (event_deps%phs_identifiers) call event_deps%p_real_cms%init (n_real, n_phs) call event_deps%p_real_lab%init (n_real, n_phs) select type (pcm => process_instance%pcm) type is (pcm_instance_nlo_t) select type (config => pcm%config) type is (pcm_nlo_t) if (allocated (config%region_data%alr_contributors)) then allocate (event_deps%contributors (size (config%region_data%alr_contributors))) event_deps%contributors = config%region_data%alr_contributors end if if (allocated (config%region_data%alr_to_i_contributor)) then allocate (event_deps%alr_to_i_con & (size (config%region_data%alr_to_i_contributor))) event_deps%alr_to_i_con = config%region_data%alr_to_i_contributor end if end select end select end associate end subroutine evt_nlo_setup_real_event_kinematics @ %def evt_nlo_setup_real_event_kinematics @ <>= procedure :: set_mode => evt_nlo_set_mode <>= subroutine evt_nlo_set_mode (evt, process_instance) class(evt_nlo_t), intent(inout) :: evt type(process_instance_t), intent(in) :: process_instance integer :: i_real select type (pcm => process_instance%pcm) type is (pcm_instance_nlo_t) select type (config => pcm%config) type is (pcm_nlo_t) if (config%settings%combined_integration) then evt%mode = EVT_NLO_COMBINED else i_real = evt%process%get_first_real_component () if (i_real == evt%process%extract_active_component_mci ()) then evt%mode = EVT_NLO_SEPARATE_REAL else evt%mode = EVT_NLO_SEPARATE_BORNLIKE end if end if end select end select end subroutine evt_nlo_set_mode @ %def evt_nlo_set_mode @ <>= procedure :: is_valid_event => evt_nlo_is_valid_event <>= function evt_nlo_is_valid_event (evt, i_term) result (valid) logical :: valid class(evt_nlo_t), intent(in) :: evt integer, intent(in) :: i_term valid = evt%process_instance%term(i_term)%passed end function evt_nlo_is_valid_event @ %def evt_nlo_is_valid_event @ <>= procedure :: prepare_new_event => evt_nlo_prepare_new_event <>= subroutine evt_nlo_prepare_new_event (evt, i_mci, i_term) class(evt_nlo_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term real(default) :: s, x real(default) :: sqme_total real(default), dimension(:), allocatable :: sqme_flv integer :: i call evt%reset () if (evt%i_evaluation > 0) return call evt%rng%generate (x) sqme_total = zero allocate (sqme_flv (evt%process_instance%term(1)%config%data%n_flv)) sqme_flv = zero do i = 1, size (evt%process_instance%term) associate (term => evt%process_instance%term(i)) sqme_total = sqme_total + real (sum ( & term%connected%matrix%get_matrix_element ())) sqme_flv = sqme_flv + real (term%connected%matrix%get_matrix_element ()) end associate end do !!! Need absolute values to take into account negative weights x = x * abs (sqme_total) s = zero do i = 1, size (sqme_flv) s = s + abs (sqme_flv (i)) if (s > x) then evt%selected_i_flv = i exit end if end do if (debug2_active (D_TRANSFORMS)) then call msg_print_color ("Selected i_flv: ", COL_GREEN) print *, evt%selected_i_flv end if end subroutine evt_nlo_prepare_new_event @ %def evt_nlo_prepare_new_event @ \section{Complete Events} This module combines hard processes with decay chains, shower, and hadronization (not implemented yet) to complete events. It also manages the input and output of event records in various formats. <<[[events.f90]]>>= <> module events <> <> use constants, only: one use io_units use format_utils, only: pac_fmt, write_separator use format_defs, only: FMT_12, FMT_19 use numeric_utils use diagnostics use variables use expr_base use model_data use state_matrices, only: FM_IGNORE_HELICITY, & FM_SELECT_HELICITY, FM_FACTOR_HELICITY, FM_CORRELATED_HELICITY use particles use subevt_expr use rng_base use process, only: process_t use instances, only: process_instance_t use pcm, only: pcm_instance_nlo_t use process_stacks use event_base use event_transforms use decays use evt_nlo <> <> <> <> contains <> end module events @ %def events @ \subsection{Event configuration} The parameters govern the transformation of an event to a particle set. The [[safety_factor]] reduces the acceptance probability for unweighting. If greater than one, excess events become less likely, but the reweighting efficiency also drops. The [[sigma]] and [[n]] values, if nontrivial, allow for reweighting the events according to the requested [[norm_mode]]. Various [[parse_node_t]] objects are taken from the SINDARIN input. They encode expressions that apply to the current event. The workspaces for evaluating those expressions are set up in the [[event_expr_t]] objects. Note that these are really pointers, so the actual nodes are not stored inside the event object. <>= type :: event_config_t logical :: unweighted = .false. integer :: norm_mode = NORM_UNDEFINED integer :: factorization_mode = FM_IGNORE_HELICITY logical :: keep_correlations = .false. logical :: colorize_subevt = .false. real(default) :: sigma = 1 integer :: n = 1 real(default) :: safety_factor = 1 class(expr_factory_t), allocatable :: ef_selection class(expr_factory_t), allocatable :: ef_reweight class(expr_factory_t), allocatable :: ef_analysis contains <> end type event_config_t @ %def event_config_t @ Output. <>= procedure :: write => event_config_write <>= subroutine event_config_write (object, unit, show_expressions) class(event_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: show_expressions integer :: u u = given_output_unit (unit) write (u, "(3x,A,L1)") "Unweighted = ", object%unweighted write (u, "(3x,A,A)") "Normalization = ", & char (event_normalization_string (object%norm_mode)) write (u, "(3x,A)", advance="no") "Helicity handling = " select case (object%factorization_mode) case (FM_IGNORE_HELICITY) write (u, "(A)") "drop" case (FM_SELECT_HELICITY) write (u, "(A)") "select" case (FM_FACTOR_HELICITY) write (u, "(A)") "factorize" end select write (u, "(3x,A,L1)") "Keep correlations = ", object%keep_correlations if (object%colorize_subevt) then write (u, "(3x,A,L1)") "Colorize subevent = ", object%colorize_subevt end if if (.not. nearly_equal (object%safety_factor, one)) then write (u, "(3x,A," // FMT_12 // ")") & "Safety factor = ", object%safety_factor end if if (present (show_expressions)) then if (show_expressions) then if (allocated (object%ef_selection)) then call write_separator (u) write (u, "(3x,A)") "Event selection expression:" call object%ef_selection%write (u) end if if (allocated (object%ef_reweight)) then call write_separator (u) write (u, "(3x,A)") "Event reweighting expression:" call object%ef_reweight%write (u) end if if (allocated (object%ef_analysis)) then call write_separator (u) write (u, "(3x,A)") "Analysis expression:" call object%ef_analysis%write (u) end if end if end if end subroutine event_config_write @ %def event_config_write @ \subsection{The event type} This is the concrete implementation of the [[generic_event_t]] core that is defined above in the [[event_base]] module. The core manages the main (dressed) particle set pointer and the current values for weights and sqme. The implementation adds configuration data, expressions, process references, and event transforms. Each event refers to a single elementary process. This process may be dressed by a shower, a decay chain etc. We maintain pointers to a process instance. A list of event transforms (class [[evt_t]]) transform the connected interactions of the process instance into the final particle set. In this list, the first transform is always the trivial one, which just factorizes the process instance. Subsequent transforms may apply decays, etc. The [[particle_set]] pointer identifies the particle set that we want to be analyzed and returned by the event, usually the last one. Squared matrix element and weight values: when reading events from file, the [[ref]] value is the number in the file, while the [[prc]] value is the number that we calculate from the momenta in the file, possibly with different parameters. When generating events the first time, or if we do not recalculate, the numbers should coincide. Furthermore, the array of [[alt]] values is copied from an array of alternative event records. These values should represent calculated values. The [[sqme]] and [[weight]] values mirror corresponding values in the [[expr]] subobject. The idea is that when generating or reading events, the event record is filled first, then the [[expr]] object acquires copies. These copies are used for writing events and as targets for pointer variables in the analysis expression. All data that involve user-provided expressions (selection, reweighting, analysis) are handled by the [[expr]] subobject. In particular, evaluating the event-selection expression sets the [[passed]] flag. Furthermore, the [[expr]] subobject collects data that can be used in the analysis and should be written to file, including copies of [[sqme]] and [[weight]]. <>= public :: event_t <>= type, extends (generic_event_t) :: event_t type(event_config_t) :: config type(process_t), pointer :: process => null () type(process_instance_t), pointer :: instance => null () class(rng_t), allocatable :: rng integer :: selected_i_mci = 0 integer :: selected_i_term = 0 integer :: selected_channel = 0 logical :: is_complete = .false. class(evt_t), pointer :: transform_first => null () class(evt_t), pointer :: transform_last => null () type(event_expr_t) :: expr logical :: selection_evaluated = .false. logical :: passed = .false. real(default), allocatable :: alpha_qcd_forced real(default), allocatable :: scale_forced real(default) :: reweight = 1 logical :: analysis_flag = .false. integer :: i_event = 0 contains <> end type event_t @ %def event_t @ <>= procedure :: clone => event_clone <>= subroutine event_clone (event, event_new) class(event_t), intent(in), target :: event class(event_t), intent(out), target:: event_new type(string_t) :: id integer :: num_id event_new%config = event%config event_new%process => event%process event_new%instance => event%instance if (allocated (event%rng)) & allocate(event_new%rng, source=event%rng) event_new%selected_i_mci = event%selected_i_mci event_new%selected_i_term = event%selected_i_term event_new%selected_channel = event%selected_channel event_new%is_complete = event%is_complete event_new%transform_first => event%transform_first event_new%transform_last => event%transform_last event_new%selection_evaluated = event%selection_evaluated event_new%passed = event%passed if (allocated (event%alpha_qcd_forced)) & allocate(event_new%alpha_qcd_forced, source=event%alpha_qcd_forced) if (allocated (event%scale_forced)) & allocate(event_new%scale_forced, source=event%scale_forced) event_new%reweight = event%reweight event_new%analysis_flag = event%analysis_flag event_new%i_event = event%i_event id = event_new%process%get_id () if (id /= "") call event_new%expr%set_process_id (id) num_id = event_new%process%get_num_id () if (num_id /= 0) call event_new%expr%set_process_num_id (num_id) call event_new%expr%setup_vars (event_new%process%get_sqrts ()) call event_new%expr%link_var_list (event_new%process%get_var_list_ptr ()) end subroutine event_clone @ %def event_clone @ Finalizer: the list of event transforms is deleted iteratively. <>= procedure :: final => event_final <>= subroutine event_final (object) class(event_t), intent(inout) :: object class(evt_t), pointer :: evt if (allocated (object%rng)) call object%rng%final () call object%expr%final () do while (associated (object%transform_first)) evt => object%transform_first object%transform_first => evt%next call evt%final () deallocate (evt) end do end subroutine event_final @ %def event_final @ Output. The event index is written in the header, it should coincide with the [[event_index]] variable that can be used in selection and analysis. Particle set: this is a pointer to one of the event transforms, so it should suffice to print the latter. <>= procedure :: write => event_write <>= subroutine event_write (object, unit, show_process, show_transforms, & show_decay, verbose, testflag) class(event_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: show_process, show_transforms, show_decay logical, intent(in), optional :: verbose logical, intent(in), optional :: testflag logical :: prc, trans, dec, verb class(evt_t), pointer :: evt character(len=7) :: fmt integer :: u, i call pac_fmt (fmt, FMT_19, FMT_12, testflag) u = given_output_unit (unit) prc = .true.; if (present (show_process)) prc = show_process trans = .true.; if (present (show_transforms)) trans = show_transforms dec = .true.; if (present (show_decay)) dec = show_decay verb = .false.; if (present (verbose)) verb = verbose call write_separator (u, 2) write (u, "(1x,A)", advance="no") "Event" if (object%has_index ()) then write (u, "(1x,'#',I0)", advance="no") object%get_index () end if if (object%is_complete) then write (u, *) else write (u, "(1x,A)") "[incomplete]" end if call write_separator (u) call object%config%write (u) if (object%sqme_ref_is_known () .or. object%weight_ref_is_known ()) then call write_separator (u) end if if (object%sqme_ref_is_known ()) then write (u, "(3x,A," // fmt // ")") & "Squared matrix el. (ref) = ", object%get_sqme_ref () if (object%sqme_alt_is_known ()) then do i = 1, object%get_n_alt () write (u, "(5x,A," // fmt // ",1x,I0)") & "alternate sqme = ", object%get_sqme_alt(i), i end do end if end if if (object%sqme_prc_is_known ()) & write (u, "(3x,A," // fmt // ")") & "Squared matrix el. (prc) = ", object%get_sqme_prc () if (object%weight_ref_is_known ()) then write (u, "(3x,A," // fmt // ")") & "Event weight (ref) = ", object%get_weight_ref () if (object%weight_alt_is_known ()) then do i = 1, object%get_n_alt () write (u, "(5x,A," // fmt // ",1x,I0)") & "alternate weight = ", object%get_weight_alt(i), i end do end if end if if (object%weight_prc_is_known ()) & write (u, "(3x,A," // fmt // ")") & "Event weight (prc) = ", object%get_weight_prc () if (object%selected_i_mci /= 0) then call write_separator (u) write (u, "(3x,A,I0)") "Selected MCI group = ", object%selected_i_mci write (u, "(3x,A,I0)") "Selected term = ", object%selected_i_term write (u, "(3x,A,I0)") "Selected channel = ", object%selected_channel end if if (object%selection_evaluated) then call write_separator (u) write (u, "(3x,A,L1)") "Passed selection = ", object%passed if (object%passed) then write (u, "(3x,A," // fmt // ")") & "Reweighting factor = ", object%reweight write (u, "(3x,A,L1)") & "Analysis flag = ", object%analysis_flag end if end if if (associated (object%instance)) then if (prc) then if (verb) then call object%instance%write (u, testflag) else call object%instance%write_header (u) end if end if if (trans) then evt => object%transform_first do while (associated (evt)) select type (evt) type is (evt_decay_t) call evt%write (u, verbose = dec, more_verbose = verb, & testflag = testflag) class default call evt%write (u, verbose = verb, testflag = testflag) end select call write_separator (u, 2) evt => evt%next end do else call write_separator (u, 2) end if if (object%expr%subevt_filled) then call object%expr%write (u, pacified = testflag) call write_separator (u, 2) end if else call write_separator (u, 2) write (u, "(1x,A)") "Process instance: [undefined]" call write_separator (u, 2) end if end subroutine event_write @ %def event_write @ \subsection{Initialization} Initialize: set configuration parameters, using a variable list. We do not call this [[init]], because this method name will be used by a type extension. The default normalization is [[NORM_SIGMA]], since the default generation mode is weighted. For unweighted events, we may want to a apply a safety factor to event rejection. (By default, this factor is unity and can be ignored.) We also allocate the trivial event transform, which is always the first one. <>= procedure :: basic_init => event_init <>= subroutine event_init (event, var_list, n_alt) class(event_t), intent(out) :: event type(var_list_t), intent(in), optional :: var_list integer, intent(in), optional :: n_alt type(string_t) :: norm_string, mode_string logical :: polarized_events if (present (n_alt)) then call event%base_init (n_alt) call event%expr%init (n_alt) else call event%base_init (0) end if if (present (var_list)) then event%config%unweighted = var_list%get_lval (& var_str ("?unweighted")) norm_string = var_list%get_sval (& var_str ("$sample_normalization")) event%config%norm_mode = & event_normalization_mode (norm_string, event%config%unweighted) polarized_events = & var_list%get_lval (var_str ("?polarized_events")) if (polarized_events) then mode_string = & var_list%get_sval (var_str ("$polarization_mode")) select case (char (mode_string)) case ("ignore") event%config%factorization_mode = FM_IGNORE_HELICITY case ("helicity") event%config%factorization_mode = FM_SELECT_HELICITY case ("factorized") event%config%factorization_mode = FM_FACTOR_HELICITY case ("correlated") event%config%factorization_mode = FM_CORRELATED_HELICITY case default call msg_fatal ("Polarization mode " & // char (mode_string) // " is undefined") end select else event%config%factorization_mode = FM_IGNORE_HELICITY end if event%config%colorize_subevt = & var_list%get_lval (var_str ("?colorize_subevt")) if (event%config%unweighted) then event%config%safety_factor = var_list%get_rval (& var_str ("safety_factor")) end if else event%config%norm_mode = NORM_SIGMA end if allocate (evt_trivial_t :: event%transform_first) event%transform_last => event%transform_first end subroutine event_init @ %def event_init @ Set the [[sigma]] and [[n]] values in the configuration record that determine non-standard event normalizations. If these numbers are not set explicitly, the default value for both is unity, and event renormalization has no effect. <>= procedure :: set_sigma => event_set_sigma procedure :: set_n => event_set_n <>= elemental subroutine event_set_sigma (event, sigma) class(event_t), intent(inout) :: event real(default), intent(in) :: sigma event%config%sigma = sigma end subroutine event_set_sigma elemental subroutine event_set_n (event, n) class(event_t), intent(inout) :: event integer, intent(in) :: n event%config%n = n end subroutine event_set_n @ %def event_set_n @ Append an event transform (decays, etc.). The transform is not yet connected to a process. The transform is then considered to belong to the event object, and will be finalized together with it. The original pointer is removed. We can assume that the trivial transform is already present in the event object, at least. <>= procedure :: import_transform => event_import_transform <>= subroutine event_import_transform (event, evt) class(event_t), intent(inout) :: event class(evt_t), intent(inout), pointer :: evt event%transform_last%next => evt evt%previous => event%transform_last event%transform_last => evt evt => null () end subroutine event_import_transform @ %def event_import_transform @ We link the event to an existing process instance. This includes the variable list, which is linked to the process variable list. Note that this is not necessarily identical to the variable list used for event initialization. The variable list will contain pointers to [[event]] subobjects, therefore the [[target]] attribute. Once we have a process connected, we can use it to obtain an event generator instance. The model and process stack may be needed by event transforms. The current model setting may be different from the model in the process (regarding unstable particles, etc.). The process stack can be used for assigning extra processes that we need for the event transforms. <>= procedure :: connect => event_connect <>= subroutine event_connect (event, process_instance, model, process_stack) class(event_t), intent(inout), target :: event type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(string_t) :: id integer :: num_id class(evt_t), pointer :: evt event%process => process_instance%process event%instance => process_instance id = event%process%get_id () if (id /= "") call event%expr%set_process_id (id) num_id = event%process%get_num_id () if (num_id /= 0) call event%expr%set_process_num_id (num_id) call event%expr%setup_vars (event%process%get_sqrts ()) call event%expr%link_var_list (event%process%get_var_list_ptr ()) call event%process%make_rng (event%rng) evt => event%transform_first do while (associated (evt)) call evt%connect (process_instance, model, process_stack) evt => evt%next end do end subroutine event_connect @ %def event_connect @ Set the parse nodes for the associated expressions, individually. The parse-node pointers may be null. <>= procedure :: set_selection => event_set_selection procedure :: set_reweight => event_set_reweight procedure :: set_analysis => event_set_analysis <>= subroutine event_set_selection (event, ef_selection) class(event_t), intent(inout) :: event class(expr_factory_t), intent(in) :: ef_selection allocate (event%config%ef_selection, source = ef_selection) end subroutine event_set_selection subroutine event_set_reweight (event, ef_reweight) class(event_t), intent(inout) :: event class(expr_factory_t), intent(in) :: ef_reweight allocate (event%config%ef_reweight, source = ef_reweight) end subroutine event_set_reweight subroutine event_set_analysis (event, ef_analysis) class(event_t), intent(inout) :: event class(expr_factory_t), intent(in) :: ef_analysis allocate (event%config%ef_analysis, source = ef_analysis) end subroutine event_set_analysis @ %def event_set_selection @ %def event_set_reweight @ %def event_set_analysis @ Create evaluation trees from the parse trees. The [[target]] attribute is required because the expressions contain pointers to event subobjects. <>= procedure :: setup_expressions => event_setup_expressions <>= subroutine event_setup_expressions (event) class(event_t), intent(inout), target :: event call event%expr%setup_selection (event%config%ef_selection) call event%expr%setup_analysis (event%config%ef_analysis) call event%expr%setup_reweight (event%config%ef_reweight) call event%expr%colorize (event%config%colorize_subevt) end subroutine event_setup_expressions @ %def event_setup_expressions @ \subsection{Evaluation} To fill the [[particle_set]], i.e., the event record proper, we have to apply all event transforms in order. The last transform should fill its associated particle set, factorizing the state matrix according to the current settings. There are several parameters in the event configuration that control this. We always fill the particle set for the first transform (the hard process) and the last transform, if different from the first (the fully dressed process). Each event transform is an event generator of its own. We choose to generate an \emph{unweighted} event for each of them, even if the master event is assumed to be weighted. Thus, the overall event weight is the one of the hard process only. (There may be more options in future extensions.) We can generate the two random numbers that the factorization needs. For testing purpose, we allow for providing them explicitly, as an option. <>= procedure :: evaluate_transforms => event_evaluate_transforms <>= subroutine event_evaluate_transforms (event, r) class(event_t), intent(inout) :: event real(default), dimension(:), intent(in), optional :: r class(evt_t), pointer :: evt real(default) :: sigma_over_sqme integer :: i_term logical :: failed_but_keep failed_but_keep = .false. call msg_debug (D_TRANSFORMS, "event_evaluate_transforms") call event%discard_particle_set () call event%check () if (event%instance%is_complete_event ()) then i_term = event%instance%select_i_term () event%selected_i_term = i_term evt => event%transform_first do while (associated (evt)) call evt%prepare_new_event & (event%selected_i_mci, event%selected_i_term) evt => evt%next end do evt => event%transform_first call msg_debug (D_TRANSFORMS, "Before event transformations") call msg_debug (D_TRANSFORMS, "event%weight_prc", event%weight_prc) call msg_debug (D_TRANSFORMS, "event%sqme_prc", event%sqme_prc) do while (associated (evt)) call print_transform_name_if_debug () if (evt%only_weighted_events) then select type (evt) type is (evt_nlo_t) failed_but_keep = .not. evt%is_valid_event (i_term) .and. evt%keep_failed_events if (.not. evt%is_valid_event (i_term) .and. .not. failed_but_keep) & return end select if (abs (event%weight_prc) > 0._default) then sigma_over_sqme = event%weight_prc / event%sqme_prc call evt%generate_weighted (event%sqme_prc) event%weight_prc = sigma_over_sqme * event%sqme_prc else if (.not. failed_but_keep) exit end if else call evt%generate_unweighted () end if if (signal_is_pending ()) return call evt%make_particle_set (event%config%factorization_mode, & event%config%keep_correlations) if (signal_is_pending ()) return if (.not. evt%particle_set_exists) exit evt => evt%next end do evt => event%transform_last if ((associated (evt) .and. evt%particle_set_exists) .or. failed_but_keep) then if (event%is_nlo ()) then select type (evt) type is (evt_nlo_t) if (evt%i_evaluation > 0) then evt%particle_set_radiated (event%i_event + 1) = evt%particle_set else call evt%keep_and_boost_born_particle_set (event%i_event + 1) end if evt%i_evaluation = evt%i_evaluation + 1 call event%link_particle_set & (evt%particle_set_radiated(event%i_event + 1)) end select else call event%link_particle_set (evt%particle_set) end if end if call msg_debug (D_TRANSFORMS, "After event transformations") call msg_debug (D_TRANSFORMS, "event%weight_prc", event%weight_prc) call msg_debug (D_TRANSFORMS, "event%sqme_prc", event%sqme_prc) call msg_debug (D_TRANSFORMS, "evt%particle_set_exists", evt%particle_set_exists) end if contains subroutine print_transform_name_if_debug () if (debug_active (D_TRANSFORMS)) then print *, 'Current event transform: ' call evt%write_name () end if end subroutine print_transform_name_if_debug end subroutine event_evaluate_transforms @ %def event_evaluate_transforms @ Set / increment the event index for the current event. There is no condition for this to happen. The event index is actually stored in the subevent expression, because this allows us to access it in subevent expressions as a variable. <>= procedure :: set_index => event_set_index procedure :: increment_index => event_increment_index <>= subroutine event_set_index (event, index) class(event_t), intent(inout) :: event integer, intent(in) :: index call event%expr%set_event_index (index) end subroutine event_set_index subroutine event_increment_index (event, offset) class(event_t), intent(inout) :: event integer, intent(in), optional :: offset call event%expr%increment_event_index (offset) end subroutine event_increment_index @ %def event_set_index @ %def event_increment_index @ Evaluate the event-related expressions, given a valid [[particle_set]]. If [[update_sqme]] is set, we use the process instance for the [[sqme_prc]] value. The [[sqme_ref]] value is always taken from the event record. Note: without the explicit [[particle_set]] pointer, some gfortran 4.8 version corrupts its memory. <>= procedure :: evaluate_expressions => event_evaluate_expressions <>= subroutine event_evaluate_expressions (event) class(event_t), intent(inout) :: event type(particle_set_t), pointer :: particle_set if (event%has_valid_particle_set ()) then particle_set => event%get_particle_set_ptr () call event%expr%fill_subevt (particle_set) end if if (event%weight_ref_is_known ()) then call event%expr%set (weight_ref = event%get_weight_ref ()) end if if (event%weight_prc_is_known ()) then call event%expr%set (weight_prc = event%get_weight_prc ()) end if if (event%excess_prc_is_known ()) then call event%expr%set (excess_prc = event%get_excess_prc ()) end if if (event%sqme_ref_is_known ()) then call event%expr%set (sqme_ref = event%get_sqme_ref ()) end if if (event%sqme_prc_is_known ()) then call event%expr%set (sqme_prc = event%get_sqme_prc ()) end if if (event%has_valid_particle_set ()) then call event%expr%evaluate & (event%passed, event%reweight, event%analysis_flag) event%selection_evaluated = .true. end if end subroutine event_evaluate_expressions @ %def event_evaluate_expressions @ Report the result of the [[selection]] evaluation. <>= procedure :: passed_selection => event_passed_selection <>= function event_passed_selection (event) result (flag) class(event_t), intent(in) :: event logical :: flag flag = event%passed end function event_passed_selection @ %def event_passed_selection @ Set alternate sqme and weight arrays. This should be merged with the previous routine, if the expressions are allowed to refer to these values. <>= procedure :: store_alt_values => event_store_alt_values <>= subroutine event_store_alt_values (event) class(event_t), intent(inout) :: event if (event%weight_alt_is_known ()) then call event%expr%set (weight_alt = event%get_weight_alt ()) end if if (event%sqme_alt_is_known ()) then call event%expr%set (sqme_alt = event%get_sqme_alt ()) end if end subroutine event_store_alt_values @ %def event_store_alt_values @ <>= procedure :: is_nlo => event_is_nlo <>= function event_is_nlo (event) result (is_nlo) logical :: is_nlo class(event_t), intent(in) :: event if (associated (event%instance)) then select type (pcm => event%instance%pcm) type is (pcm_instance_nlo_t) is_nlo = pcm%is_fixed_order_nlo_events () class default is_nlo = .false. end select else is_nlo = .false. end if end function event_is_nlo @ %def event_is_nlo @ \subsection{Reset to empty state} Applying this, current event contents are marked as incomplete but are not deleted. In particular, the initialization is kept. The event index is also kept, this can be reset separately. <>= procedure :: reset_contents => event_reset_contents procedure :: reset_index => event_reset_index <>= subroutine event_reset_contents (event) class(event_t), intent(inout) :: event class(evt_t), pointer :: evt call event%base_reset_contents () event%selected_i_mci = 0 event%selected_i_term = 0 event%selected_channel = 0 event%is_complete = .false. call event%expr%reset_contents () event%selection_evaluated = .false. event%passed = .false. event%analysis_flag = .false. if (associated (event%instance)) then call event%instance%reset (reset_mci = .true.) end if if (allocated (event%alpha_qcd_forced)) deallocate (event%alpha_qcd_forced) if (allocated (event%scale_forced)) deallocate (event%scale_forced) evt => event%transform_first do while (associated (evt)) call evt%reset () evt => evt%next end do end subroutine event_reset_contents subroutine event_reset_index (event) class(event_t), intent(inout) :: event call event%expr%reset_event_index () end subroutine event_reset_index @ %def event_reset_contents @ %def event_reset_index @ \subsection{Squared Matrix Element and Weight} Transfer the result of the process instance calculation to the event record header. <>= procedure :: import_instance_results => event_import_instance_results <>= subroutine event_import_instance_results (event) class(event_t), intent(inout) :: event if (associated (event%instance)) then if (event%instance%has_evaluated_trace ()) then call event%set ( & sqme_prc = event%instance%get_sqme (), & weight_prc = event%instance%get_weight (), & excess_prc = event%instance%get_excess (), & n_dropped = event%instance%get_n_dropped () & ) end if end if end subroutine event_import_instance_results @ %def event_import_instance_results @ Duplicate the instance result / the reference result in the event record. <>= procedure :: accept_sqme_ref => event_accept_sqme_ref procedure :: accept_sqme_prc => event_accept_sqme_prc procedure :: accept_weight_ref => event_accept_weight_ref procedure :: accept_weight_prc => event_accept_weight_prc <>= subroutine event_accept_sqme_ref (event) class(event_t), intent(inout) :: event if (event%sqme_ref_is_known ()) then call event%set (sqme_prc = event%get_sqme_ref ()) end if end subroutine event_accept_sqme_ref subroutine event_accept_sqme_prc (event) class(event_t), intent(inout) :: event if (event%sqme_prc_is_known ()) then call event%set (sqme_ref = event%get_sqme_prc ()) end if end subroutine event_accept_sqme_prc subroutine event_accept_weight_ref (event) class(event_t), intent(inout) :: event if (event%weight_ref_is_known ()) then call event%set (weight_prc = event%get_weight_ref ()) end if end subroutine event_accept_weight_ref subroutine event_accept_weight_prc (event) class(event_t), intent(inout) :: event if (event%weight_prc_is_known ()) then call event%set (weight_ref = event%get_weight_prc ()) end if end subroutine event_accept_weight_prc @ %def event_accept_sqme_ref @ %def event_accept_sqme_prc @ %def event_accept_weight_ref @ %def event_accept_weight_prc @ Update the weight normalization, just after generation. Unweighted and weighted events are generated with a different default normalization. The intended normalization is stored in the configuration record. <>= procedure :: update_normalization => event_update_normalization <>= subroutine event_update_normalization (event, mode_ref) class(event_t), intent(inout) :: event integer, intent(in), optional :: mode_ref integer :: mode_old real(default) :: weight, excess if (present (mode_ref)) then mode_old = mode_ref else if (event%config%unweighted) then mode_old = NORM_UNIT else mode_old = NORM_SIGMA end if weight = event%get_weight_prc () call event_normalization_update (weight, & event%config%sigma, event%config%n, & mode_new = event%config%norm_mode, & mode_old = mode_old) call event%set_weight_prc (weight) excess = event%get_excess_prc () call event_normalization_update (excess, & event%config%sigma, event%config%n, & mode_new = event%config%norm_mode, & mode_old = mode_old) call event%set_excess_prc (excess) end subroutine event_update_normalization @ %def event_update_normalization @ The event is complete if it has a particle set plus valid entries for the sqme and weight values. <>= procedure :: check => event_check <>= subroutine event_check (event) class(event_t), intent(inout) :: event event%is_complete = event%has_valid_particle_set () & .and. event%sqme_ref_is_known () & .and. event%sqme_prc_is_known () & .and. event%weight_ref_is_known () & .and. event%weight_prc_is_known () if (event%get_n_alt () /= 0) then event%is_complete = event%is_complete & .and. event%sqme_alt_is_known () & .and. event%weight_alt_is_known () end if end subroutine event_check @ %def event_check @ @ \subsection{Generation} Assuming that we have a valid process associated to the event, we generate an event. We complete the event data, then factorize the spin density matrix and transfer it to the particle set. When done, we retrieve squared matrix element and weight. In case of explicit generation, the reference values coincide with the process values, so we [[accept]] the latter. The explicit random number argument [[r]] should be generated by a random-number generator. It is taken for the factorization algorithm, bypassing the event-specific random-number generator. This is useful for deterministic testing. <>= procedure :: generate => event_generate <>= subroutine event_generate (event, i_mci, r, i_nlo) class(event_t), intent(inout) :: event integer, intent(in) :: i_mci real(default), dimension(:), intent(in), optional :: r integer, intent(in), optional :: i_nlo logical :: generate_new generate_new = .true. if (present (i_nlo)) generate_new = (i_nlo == 1) if (generate_new) call event%reset_contents () event%selected_i_mci = i_mci if (event%config%unweighted) then call event%instance%generate_unweighted_event (i_mci) if (signal_is_pending ()) return call event%instance%evaluate_event_data () call event%instance%normalize_weight () else if (generate_new) & call event%instance%generate_weighted_event (i_mci) if (signal_is_pending ()) return call event%instance%evaluate_event_data () end if event%selected_channel = event%instance%get_channel () call event%import_instance_results () call event%accept_sqme_prc () call event%update_normalization () call event%accept_weight_prc () call event%evaluate_transforms (r) if (signal_is_pending ()) return call event%check () end subroutine event_generate @ %def event_generate @ Get a copy of the particle set belonging to the hard process. <>= procedure :: get_hard_particle_set => event_get_hard_particle_set <>= subroutine event_get_hard_particle_set (event, pset) class(event_t), intent(in) :: event type(particle_set_t), intent(out) :: pset class(evt_t), pointer :: evt evt => event%transform_first pset = evt%particle_set end subroutine event_get_hard_particle_set @ %def event_get_hard_particle_set @ \subsection{Recovering an event} Select MC group, term, and integration channel. <>= procedure :: select => event_select <>= subroutine event_select (event, i_mci, i_term, channel) class(event_t), intent(inout) :: event integer, intent(in) :: i_mci, i_term, channel if (associated (event%instance)) then event%selected_i_mci = i_mci event%selected_i_term = i_term event%selected_channel = channel else event%selected_i_mci = 0 event%selected_i_term = 0 event%selected_channel = 0 end if end subroutine event_select @ %def event_select @ Copy a particle set into the event record. We deliberately use the first (the trivial) transform for this, i.e., the hard process. The event reader may either read in the transformed event separately, or apply all event transforms to the hard particle set to (re)generate a fully dressed event. Since this makes all subsequent event transforms invalid, we call [[reset]] on them. <>= procedure :: set_hard_particle_set => event_set_hard_particle_set <>= subroutine event_set_hard_particle_set (event, particle_set) class(event_t), intent(inout) :: event type(particle_set_t), intent(in) :: particle_set class(evt_t), pointer :: evt evt => event%transform_first call evt%set_particle_set (particle_set, & event%selected_i_mci, event%selected_i_term) call event%link_particle_set (evt%particle_set) evt => evt%next do while (associated (evt)) call evt%reset () evt => evt%next end do end subroutine event_set_hard_particle_set @ %def event_set_hard_particle_set @ Set the $\alpha_s$ value that should be used in a recalculation. This should be called only if we explicitly want to override the QCD setting of the process core. <>= procedure :: set_alpha_qcd_forced => event_set_alpha_qcd_forced <>= subroutine event_set_alpha_qcd_forced (event, alpha_qcd) class(event_t), intent(inout) :: event real(default), intent(in) :: alpha_qcd if (allocated (event%alpha_qcd_forced)) then event%alpha_qcd_forced = alpha_qcd else allocate (event%alpha_qcd_forced, source = alpha_qcd) end if end subroutine event_set_alpha_qcd_forced @ %def event_set_alpha_qcd_forced @ Analogously, for the common scale. This forces also renormalization and factorization scale. <>= procedure :: set_scale_forced => event_set_scale_forced <>= subroutine event_set_scale_forced (event, scale) class(event_t), intent(inout) :: event real(default), intent(in) :: scale if (allocated (event%scale_forced)) then event%scale_forced = scale else allocate (event%scale_forced, source = scale) end if end subroutine event_set_scale_forced @ %def event_set_scale_forced @ Here we try to recover an event from the [[particle_set]] subobject and recalculate the structure functions and matrix elements. We have the appropriate [[process]] object and an initialized [[process_instance]] at hand, so beam and configuration data are known. From the [[particle_set]], we get the momenta. The quantum-number information may be incomplete, e.g., helicity information may be partial or absent. We recover the event just from the momentum configuration. We do not transfer the matrix element from the process instance to the event record, as we do when generating an event. The event record may contain the matrix element as read from file, and the current calculation may use different parameters. We thus can compare old and new values. The event [[weight]] may also be known already. If yes, we pass it to the [[evaluate_event_data]] procedure. It should already be normalized. If we have an [[weight_factor]] value, we obtain the event weight by multiplying the computed [[sqme]] by this factor. Otherwise, we make use of the MCI setup (which should be valid then) to compute the event weight, and we should normalize the result just as when generating events. Evaluating event expressions must also be done separately. If [[recover_phs]] is set (and false), do not attempt any phase-space calculation, including MCI evaluation. Useful if we need only matrix elements. <>= procedure :: recalculate => event_recalculate <>= subroutine event_recalculate & (event, update_sqme, weight_factor, recover_beams, recover_phs) class(event_t), intent(inout) :: event logical, intent(in) :: update_sqme real(default), intent(in), optional :: weight_factor logical, intent(in), optional :: recover_beams logical, intent(in), optional :: recover_phs type(particle_set_t), pointer :: particle_set integer :: i_mci, i_term, channel logical :: rec_phs_mci rec_phs_mci = .true.; if (present (recover_phs)) rec_phs_mci = recover_phs if (event%has_valid_particle_set ()) then particle_set => event%get_particle_set_ptr () i_mci = event%selected_i_mci i_term = event%selected_i_term channel = event%selected_channel if (i_mci == 0 .or. i_term == 0 .or. channel == 0) then call msg_bug ("Event: recalculate: undefined selection parameters") end if call event%instance%choose_mci (i_mci) call event%instance%set_trace (particle_set, i_term, recover_beams) if (allocated (event%alpha_qcd_forced)) then call event%instance%set_alpha_qcd_forced & (i_term, event%alpha_qcd_forced) end if call event%instance%recover (channel, i_term, & update_sqme, rec_phs_mci, event%scale_forced) if (signal_is_pending ()) return if (update_sqme .and. present (weight_factor)) then call event%instance%evaluate_event_data & (weight = event%instance%get_sqme () * weight_factor) else if (event%weight_ref_is_known ()) then call event%instance%evaluate_event_data & (weight = event%get_weight_ref ()) else if (rec_phs_mci) then call event%instance%recover_event () if (signal_is_pending ()) return call event%instance%evaluate_event_data () if (event%config%unweighted) then call event%instance%normalize_weight () end if end if if (signal_is_pending ()) return if (update_sqme) then call event%import_instance_results () else call event%accept_sqme_ref () call event%accept_weight_ref () end if else call msg_bug ("Event: can't recalculate, particle set is undefined") end if end subroutine event_recalculate @ %def event_recalculate @ \subsection{Access content} Pointer to the associated process object (the associated model). <>= procedure :: get_process_ptr => event_get_process_ptr procedure :: get_process_instance_ptr => event_get_process_instance_ptr procedure :: get_model_ptr => event_get_model_ptr <>= function event_get_process_ptr (event) result (ptr) class(event_t), intent(in) :: event type(process_t), pointer :: ptr ptr => event%process end function event_get_process_ptr function event_get_process_instance_ptr (event) result (ptr) class(event_t), intent(in) :: event type(process_instance_t), pointer :: ptr ptr => event%instance end function event_get_process_instance_ptr function event_get_model_ptr (event) result (model) class(event_t), intent(in) :: event class(model_data_t), pointer :: model if (associated (event%process)) then model => event%process%get_model_ptr () else model => null () end if end function event_get_model_ptr @ %def event_get_process_ptr @ %def event_get_process_instance_ptr @ %def event_get_model_ptr @ Return the current values of indices: the MCI group of components, the term index (different terms corresponding, potentially, to different effective kinematics), and the MC integration channel. The [[i_mci]] call is delegated to the current process instance. <>= procedure :: get_i_mci => event_get_i_mci procedure :: get_i_term => event_get_i_term procedure :: get_channel => event_get_channel <>= function event_get_i_mci (event) result (i_mci) class(event_t), intent(in) :: event integer :: i_mci i_mci = event%selected_i_mci end function event_get_i_mci function event_get_i_term (event) result (i_term) class(event_t), intent(in) :: event integer :: i_term i_term = event%selected_i_term end function event_get_i_term function event_get_channel (event) result (channel) class(event_t), intent(in) :: event integer :: channel channel = event%selected_channel end function event_get_channel @ %def event_get_i_mci @ %def event_get_i_term @ %def event_get_channel @ This flag tells us whether the event consists just of a hard process (i.e., holds at most the first, trivial transform), or is a dressed events with additional transforms. <>= procedure :: has_transform => event_has_transform <>= function event_has_transform (event) result (flag) class(event_t), intent(in) :: event logical :: flag if (associated (event%transform_first)) then flag = associated (event%transform_first%next) else flag = .false. end if end function event_has_transform @ %def event_has_transform @ Return the currently selected normalization mode, or alternate normalization mode. <>= procedure :: get_norm_mode => event_get_norm_mode <>= elemental function event_get_norm_mode (event) result (norm_mode) class(event_t), intent(in) :: event integer :: norm_mode norm_mode = event%config%norm_mode end function event_get_norm_mode @ %def event_get_norm_mode @ Return the kinematical weight, defined as the ratio of event weight and squared matrix element. <>= procedure :: get_kinematical_weight => event_get_kinematical_weight <>= function event_get_kinematical_weight (event) result (f) class(event_t), intent(in) :: event real(default) :: f if (event%sqme_ref_is_known () .and. event%weight_ref_is_known () & .and. abs (event%get_sqme_ref ()) > 0) then f = event%get_weight_ref () / event%get_sqme_ref () else f = 0 end if end function event_get_kinematical_weight @ %def event_get_kinematical_weight @ Return data used by external event formats. <>= procedure :: has_index => event_has_index procedure :: get_index => event_get_index procedure :: get_fac_scale => event_get_fac_scale procedure :: get_alpha_s => event_get_alpha_s procedure :: get_sqrts => event_get_sqrts procedure :: get_polarization => event_get_polarization procedure :: get_beam_file => event_get_beam_file procedure :: get_process_name => event_get_process_name <>= function event_has_index (event) result (flag) class(event_t), intent(in) :: event logical :: flag flag = event%expr%has_event_index () end function event_has_index function event_get_index (event) result (index) class(event_t), intent(in) :: event integer :: index index = event%expr%get_event_index () end function event_get_index function event_get_fac_scale (event) result (fac_scale) class(event_t), intent(in) :: event real(default) :: fac_scale fac_scale = event%instance%get_fac_scale (event%selected_i_term) end function event_get_fac_scale function event_get_alpha_s (event) result (alpha_s) class(event_t), intent(in) :: event real(default) :: alpha_s alpha_s = event%instance%get_alpha_s (event%selected_i_term) end function event_get_alpha_s function event_get_sqrts (event) result (sqrts) class(event_t), intent(in) :: event real(default) :: sqrts sqrts = event%instance%get_sqrts () end function event_get_sqrts function event_get_polarization (event) result (pol) class(event_t), intent(in) :: event real(default), dimension(2) :: pol pol = event%instance%get_polarization () end function event_get_polarization function event_get_beam_file (event) result (file) class(event_t), intent(in) :: event type(string_t) :: file file = event%instance%get_beam_file () end function event_get_beam_file function event_get_process_name (event) result (name) class(event_t), intent(in) :: event type(string_t) :: name name = event%instance%get_process_name () end function event_get_process_name @ %def event_get_index @ %def event_get_fac_scale @ %def event_get_alpha_s @ %def event_get_sqrts @ %def event_get_polarization @ %def event_get_beam_file @ %def event_get_process_name @ Return the actual number of calls, as stored in the process instance. <>= procedure :: get_actual_calls_total => event_get_actual_calls_total <>= elemental function event_get_actual_calls_total (event) result (n) class(event_t), intent(in) :: event integer :: n if (associated (event%instance)) then n = event%instance%get_actual_calls_total () else n = 0 end if end function event_get_actual_calls_total @ %def event_get_actual_calls_total @ Eliminate numerical noise in the [[subevt]] expression and in the event transforms (which includes associated process instances). <>= public :: pacify <>= interface pacify module procedure pacify_event end interface pacify <>= subroutine pacify_event (event) class(event_t), intent(inout) :: event class(evt_t), pointer :: evt call event%pacify_particle_set () if (event%expr%subevt_filled) call pacify (event%expr) evt => event%transform_first do while (associated (evt)) select type (evt) type is (evt_decay_t); call pacify (evt) end select evt => evt%next end do end subroutine pacify_event @ %def pacify @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[events_ut.f90]]>>= <> module events_ut use unit_tests use events_uti <> <> contains <> end module events_ut @ %def events_ut @ <<[[events_uti.f90]]>>= <> module events_uti <> <> use os_interface use model_data use particles use process_libraries use process_stacks use event_transforms use decays use decays_ut, only: prepare_testbed use process, only: process_t use instances, only: process_instance_t use events <> <> contains <> end module events_uti @ %def events_uti @ API: driver for the unit tests below. <>= public :: events_test <>= subroutine events_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine events_test @ %def events_test @ \subsubsection{Empty event record} <>= call test (events_1, "events_1", & "empty event record", & u, results) <>= public :: events_1 <>= subroutine events_1 (u) integer, intent(in) :: u type(event_t), target :: event write (u, "(A)") "* Test output: events_1" write (u, "(A)") "* Purpose: display an empty event object" write (u, "(A)") call event%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: events_1" end subroutine events_1 @ %def events_1 @ \subsubsection{Simple event} <>= call test (events_2, "events_2", & "generate event", & u, results) <>= public :: events_2 <>= subroutine events_2 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(model_data_t), target :: model write (u, "(A)") "* Test output: events_2" write (u, "(A)") "* Purpose: generate and display an event" write (u, "(A)") call model%init_test () write (u, "(A)") "* Generate test process event" allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model) call process_instance%setup_event_data () write (u, "(A)") write (u, "(A)") "* Initialize event object" allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) write (u, "(A)") write (u, "(A)") "* Generate test process event" call process_instance%generate_weighted_event (1) write (u, "(A)") write (u, "(A)") "* Fill event object" write (u, "(A)") call event%generate (1, [0.4_default, 0.4_default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call event%final () deallocate (event) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: events_2" end subroutine events_2 @ %def events_2 @ \subsubsection{Recovering an event} Generate an event and store the particle set. Then reset the event record, recall the particle set, and recover the event from that. Note: The extra [[particle_set_ptr]] auxiliary is a workaround for memory corruption in gfortran 4.7. <>= call test (events_4, "events_4", & "recover event", & u, results) <>= public :: events_4 <>= subroutine events_4 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(process_t), allocatable, target :: process2 type(process_instance_t), allocatable, target :: process2_instance type(particle_set_t) :: particle_set type(particle_set_t), pointer :: particle_set_ptr type(model_data_t), target :: model write (u, "(A)") "* Test output: events_4" write (u, "(A)") "* Purpose: generate and recover an event" write (u, "(A)") call model%init_test () write (u, "(A)") "* Generate test process event and save particle set" write (u, "(A)") allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call event%generate (1, [0.4_default, 0.4_default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) particle_set_ptr => event%get_particle_set_ptr () particle_set = particle_set_ptr ! NB: 'particle_set' contains pointers to the model within 'process' call event%final () deallocate (event) write (u, "(A)") write (u, "(A)") "* Recover event from particle set" write (u, "(A)") allocate (process2) allocate (process2_instance) call prepare_test_process (process2, process2_instance, model) call process2_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process2_instance, process2%get_model_ptr ()) call event%select (1, 1, 1) call event%set_hard_particle_set (particle_set) call event%recalculate (update_sqme = .true.) call event%write (u) write (u, "(A)") write (u, "(A)") "* Transfer sqme and evaluate expressions" write (u, "(A)") call event%accept_sqme_prc () call event%accept_weight_prc () call event%check () call event%set_index (1) call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Reset contents" write (u, "(A)") call event%reset_contents () call event%reset_index () event%transform_first%particle_set_exists = .false. call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call particle_set%final () call event%final () deallocate (event) call cleanup_test_process (process2, process2_instance) deallocate (process2_instance) deallocate (process2) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: events_4" end subroutine events_4 @ %def events_4 @ \subsubsection{Partially Recovering an event} Generate an event and store the particle set. Then reset the event record, recall the particle set, and recover the event as far as possible without recomputing the squared matrix element. <>= call test (events_5, "events_5", & "partially recover event", & u, results) <>= public :: events_5 <>= subroutine events_5 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(process_t), allocatable, target :: process2 type(process_instance_t), allocatable, target :: process2_instance type(particle_set_t) :: particle_set type(particle_set_t), pointer :: particle_set_ptr real(default) :: sqme, weight type(model_data_t), target :: model write (u, "(A)") "* Test output: events_5" write (u, "(A)") "* Purpose: generate and recover an event" write (u, "(A)") call model%init_test () write (u, "(A)") "* Generate test process event and save particle set" write (u, "(A)") allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call event%generate (1, [0.4_default, 0.4_default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) particle_set_ptr => event%get_particle_set_ptr () particle_set = particle_set_ptr sqme = event%get_sqme_ref () weight = event%get_weight_ref () call event%final () deallocate (event) write (u, "(A)") write (u, "(A)") "* Recover event from particle set" write (u, "(A)") allocate (process2) allocate (process2_instance) call prepare_test_process (process2, process2_instance, model) call process2_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process2_instance, process2%get_model_ptr ()) call event%select (1, 1, 1) call event%set_hard_particle_set (particle_set) call event%recalculate (update_sqme = .false.) call event%write (u) write (u, "(A)") write (u, "(A)") "* Manually set sqme and evaluate expressions" write (u, "(A)") call event%set (sqme_ref = sqme, weight_ref = weight) call event%accept_sqme_ref () call event%accept_weight_ref () call event%set_index (1) call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call particle_set%final () call event%final () deallocate (event) call cleanup_test_process (process2, process2_instance) deallocate (process2_instance) deallocate (process2) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: events_5" end subroutine events_5 @ %def events_5 @ \subsubsection{Decays} Generate an event with subsequent decays. <>= call test (events_6, "events_6", & "decays", & u, results) <>= public :: events_6 <>= subroutine events_6 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(string_t) :: prefix, procname1, procname2 type(process_library_t), target :: lib type(process_stack_t) :: process_stack class(evt_t), pointer :: evt_decay type(event_t), allocatable, target :: event type(process_t), pointer :: process type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: events_6" write (u, "(A)") "* Purpose: generate an event with subsequent decays" write (u, "(A)") write (u, "(A)") "* Generate test process and decay" write (u, "(A)") call os_data%init () prefix = "events_6" procname1 = prefix // "_p" procname2 = prefix // "_d" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.true., decay=.true.) write (u, "(A)") "* Initialize decay process" process => process_stack%get_process_ptr (procname1) model => process%get_model_ptr () call model%set_unstable (25, [procname2]) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () call process_instance%init_simulation (1) write (u, "(A)") write (u, "(A)") "* Initialize event transform: decay" allocate (evt_decay_t :: evt_decay) call evt_decay%connect (process_instance, model, process_stack) write (u, "(A)") write (u, "(A)") "* Initialize event object" write (u, "(A)") allocate (event) call event%basic_init () call event%connect (process_instance, model) call event%import_transform (evt_decay) call event%write (u, show_decay = .true.) write (u, "(A)") write (u, "(A)") "* Generate event" write (u, "(A)") call event%generate (1, [0.4_default, 0.4_default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call event%final () deallocate (event) call process_instance%final () deallocate (process_instance) call process_stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: events_6" end subroutine events_6 @ %def events_6 @ \subsubsection{Decays} Generate a decay event with varying options. <>= call test (events_7, "events_7", & "decay options", & u, results) <>= public :: events_7 <>= subroutine events_7 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(string_t) :: prefix, procname2 type(process_library_t), target :: lib type(process_stack_t) :: process_stack type(process_t), pointer :: process type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: events_7" write (u, "(A)") "* Purpose: check decay options" write (u, "(A)") write (u, "(A)") "* Prepare test process" write (u, "(A)") call os_data%init () prefix = "events_7" procname2 = prefix // "_d" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.false., decay=.true.) write (u, "(A)") "* Generate decay event, default options" write (u, "(A)") process => process_stack%get_process_ptr (procname2) model => process%get_model_ptr () call model%set_unstable (25, [procname2]) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data (model) call process_instance%init_simulation (1) call process_instance%generate_weighted_event (1) call process_instance%write (u) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Generate decay event, helicity-diagonal decay" write (u, "(A)") process => process_stack%get_process_ptr (procname2) model => process%get_model_ptr () call model%set_unstable (25, [procname2], diagonal = .true.) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data (model) call process_instance%init_simulation (1) call process_instance%generate_weighted_event (1) call process_instance%write (u) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Generate decay event, isotropic decay, & &polarized final state" write (u, "(A)") process => process_stack%get_process_ptr (procname2) model => process%get_model_ptr () call model%set_unstable (25, [procname2], isotropic = .true.) call model%set_polarized (6) call model%set_polarized (-6) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data (model) call process_instance%init_simulation (1) call process_instance%generate_weighted_event (1) call process_instance%write (u) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Cleanup" call process_stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: events_7" end subroutine events_7 @ %def events_7 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Raw Event I/O} The raw format is for internal use only. All data are stored unformatted, so they can be efficiently be re-read on the same machine, but not necessarily on another machine. This module explicitly depends on the [[events]] module which provides the concrete implementation of [[event_base]]. The other I/O formats access only the methods that are defined in [[event_base]]. <<[[eio_raw.f90]]>>= <> module eio_raw <> <> use io_units use diagnostics use model_data use particles use event_base use eio_data use eio_base use events <> <> <> <> contains <> end module eio_raw @ %def eio_raw @ \subsection{File Format Version} This is the current default file version. <>= integer, parameter :: CURRENT_FILE_VERSION = 2 @ %def CURRENT_FILE_VERSION @ The user may change this number; this should force some compatibility mode for reading and writing. In any case, the file version stored in a event file that we read has to match the expected file version. History of version numbers: \begin{enumerate} \item Format for WHIZARD 2.2.0 to 2.2.3. No version number stored in the raw file. \item Format from 2.2.4 on. File contains version number. The file contains the transformed particle set (if applicable) after the hard-process particle set. \end{enumerate} @ \subsection{Type} Note the file version number. The default may be reset during initialization, which should enforce some compatibility mode. <>= public :: eio_raw_t <>= type, extends (eio_t) :: eio_raw_t logical :: reading = .false. logical :: writing = .false. integer :: unit = 0 integer :: norm_mode = NORM_UNDEFINED real(default) :: sigma = 1 integer :: n = 1 integer :: n_alt = 0 logical :: check = .false. integer :: file_version = CURRENT_FILE_VERSION contains <> end type eio_raw_t @ %def eio_raw_t @ Output. This is not the actual event format, but a readable account of the current object status. <>= procedure :: write => eio_raw_write <>= subroutine eio_raw_write (object, unit) class(eio_raw_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Raw event stream:" write (u, "(3x,A,L1)") "Check MD5 sum = ", object%check if (object%n_alt > 0) then write (u, "(3x,A,I0)") "Alternate weights = ", object%n_alt end if if (object%reading) then write (u, "(3x,A,A)") "Reading from file = ", char (object%filename) else if (object%writing) then write (u, "(3x,A,A)") "Writing to file = ", char (object%filename) else write (u, "(3x,A)") "[closed]" end if end subroutine eio_raw_write @ %def eio_raw_write @ Finalizer: close any open file. <>= procedure :: final => eio_raw_final <>= subroutine eio_raw_final (object) class(eio_raw_t), intent(inout) :: object if (object%reading .or. object%writing) then write (msg_buffer, "(A,A,A)") "Events: closing raw file '", & char (object%filename), "'" call msg_message () close (object%unit) object%reading = .false. object%writing = .false. end if end subroutine eio_raw_final @ %def eio_raw_final @ Set the [[check]] flag which determines whether we compare checksums on input. <>= procedure :: set_parameters => eio_raw_set_parameters <>= subroutine eio_raw_set_parameters (eio, check, version_string, extension) class(eio_raw_t), intent(inout) :: eio logical, intent(in), optional :: check type(string_t), intent(in), optional :: version_string type(string_t), intent(in), optional :: extension if (present (check)) eio%check = check if (present (version_string)) then select case (char (version_string)) case ("", "2.2.4") eio%file_version = CURRENT_FILE_VERSION case ("2.2") eio%file_version = 1 case default call msg_fatal ("Raw event I/O: unsupported version '" & // char (version_string) // "'") eio%file_version = 0 end select end if if (present (extension)) then eio%extension = extension else eio%extension = "evx" end if end subroutine eio_raw_set_parameters @ %def eio_raw_set_parameters @ Initialize event writing. <>= procedure :: init_out => eio_raw_init_out <>= subroutine eio_raw_init_out (eio, sample, data, success, extension) class(eio_raw_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success type(string_t), intent(in), optional :: extension character(32) :: md5sum_prc, md5sum_cfg character(32), dimension(:), allocatable :: md5sum_alt integer :: i if (present (extension)) then eio%extension = extension else eio%extension = "evx" end if eio%filename = sample // "." // eio%extension eio%unit = free_unit () write (msg_buffer, "(A,A,A)") "Events: writing to raw file '", & char (eio%filename), "'" call msg_message () eio%writing = .true. if (present (data)) then md5sum_prc = data%md5sum_prc md5sum_cfg = data%md5sum_cfg eio%norm_mode = data%norm_mode eio%sigma = data%total_cross_section eio%n = data%n_evt eio%n_alt = data%n_alt if (eio%n_alt > 0) then !!! !!! !!! Workaround for gfortran 5.0 ICE allocate (md5sum_alt (data%n_alt)) md5sum_alt = data%md5sum_alt !!! allocate (md5sum_alt (data%n_alt), source = data%md5sum_alt) end if else md5sum_prc = "" md5sum_cfg = "" end if open (eio%unit, file = char (eio%filename), form = "unformatted", & action = "write", status = "replace") select case (eio%file_version) case (2:); write (eio%unit) eio%file_version end select write (eio%unit) md5sum_prc write (eio%unit) md5sum_cfg write (eio%unit) eio%norm_mode write (eio%unit) eio%n_alt if (allocated (md5sum_alt)) then do i = 1, eio%n_alt write (eio%unit) md5sum_alt(i) end do end if if (present (success)) success = .true. end subroutine eio_raw_init_out @ %def eio_raw_init_out @ Initialize event reading. <>= procedure :: init_in => eio_raw_init_in <>= subroutine eio_raw_init_in (eio, sample, data, success, extension) class(eio_raw_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success type(string_t), intent(in), optional :: extension character(32) :: md5sum_prc, md5sum_cfg character(32), dimension(:), allocatable :: md5sum_alt integer :: i, file_version if (present (success)) success = .true. if (present (extension)) then eio%extension = extension else eio%extension = "evx" end if eio%filename = sample // "." // eio%extension eio%unit = free_unit () if (present (data)) then eio%sigma = data%total_cross_section eio%n = data%n_evt end if write (msg_buffer, "(A,A,A)") "Events: reading from raw file '", & char (eio%filename), "'" call msg_message () eio%reading = .true. open (eio%unit, file = char (eio%filename), form = "unformatted", & action = "read", status = "old") select case (eio%file_version) case (2:); read (eio%unit) file_version case default; file_version = 1 end select if (file_version /= eio%file_version) then call msg_error ("Reading event file: raw-file version mismatch.") if (present (success)) success = .false. return else if (file_version /= CURRENT_FILE_VERSION) then call msg_warning ("Reading event file: compatibility mode.") end if read (eio%unit) md5sum_prc read (eio%unit) md5sum_cfg read (eio%unit) eio%norm_mode read (eio%unit) eio%n_alt if (present (data)) then if (eio%n_alt /= data%n_alt) then if (present (success)) success = .false. return end if end if allocate (md5sum_alt (eio%n_alt)) do i = 1, eio%n_alt read (eio%unit) md5sum_alt(i) end do if (present (success)) then if (present (data)) then if (eio%check) then if (data%md5sum_prc /= "") then success = success .and. md5sum_prc == data%md5sum_prc end if if (data%md5sum_cfg /= "") then success = success .and. md5sum_cfg == data%md5sum_cfg end if do i = 1, eio%n_alt if (data%md5sum_alt(i) /= "") then success = success .and. md5sum_alt(i) == data%md5sum_alt(i) end if end do else call msg_warning ("Reading event file: MD5 sum check disabled") end if end if end if end subroutine eio_raw_init_in @ %def eio_raw_init_in @ Switch from input to output: reopen the file for reading. <>= procedure :: switch_inout => eio_raw_switch_inout <>= subroutine eio_raw_switch_inout (eio, success) class(eio_raw_t), intent(inout) :: eio logical, intent(out), optional :: success write (msg_buffer, "(A,A,A)") "Events: appending to raw file '", & char (eio%filename), "'" call msg_message () close (eio%unit, status = "keep") eio%reading = .false. open (eio%unit, file = char (eio%filename), form = "unformatted", & action = "write", position = "append", status = "old") eio%writing = .true. if (present (success)) success = .true. end subroutine eio_raw_switch_inout @ %def eio_raw_switch_inout @ Output an event. Write first the event indices, then weight and squared matrix element, then the particle set. We always write the particle set of the hard process. (Note: this should be reconsidered.) We do make a physical copy. On output, we write the [[prc]] values for weight and sqme, since these are the values just computed. On input, we store the values as [[ref]] values. The caller can then decide whether to recompute values and thus obtain distinct [[prc]] values, or just accept them. The [[passed]] flag is not written. This allow us to apply different selection criteria upon rereading. <>= procedure :: output => eio_raw_output <>= subroutine eio_raw_output (eio, event, i_prc, reading, passed, pacify) class(eio_raw_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event logical, intent(in), optional :: reading, passed, pacify integer, intent(in) :: i_prc type(particle_set_t), pointer :: pset integer :: i if (eio%writing) then if (event%has_valid_particle_set ()) then select type (event) type is (event_t) write (eio%unit) i_prc write (eio%unit) event%get_index () write (eio%unit) event%get_i_mci () write (eio%unit) event%get_i_term () write (eio%unit) event%get_channel () write (eio%unit) event%expr%weight_prc write (eio%unit) event%expr%excess_prc write (eio%unit) event%get_n_dropped () write (eio%unit) event%expr%sqme_prc do i = 1, eio%n_alt write (eio%unit) event%expr%weight_alt(i) write (eio%unit) event%expr%sqme_alt(i) end do allocate (pset) call event%get_hard_particle_set (pset) call pset%write_raw (eio%unit) call pset%final () deallocate (pset) select case (eio%file_version) case (2:) if (event%has_transform ()) then write (eio%unit) .true. pset => event%get_particle_set_ptr () call pset%write_raw (eio%unit) else write (eio%unit) .false. end if end select class default call msg_bug ("Event: write raw: defined only for full event_t") end select else call msg_bug ("Event: write raw: particle set is undefined") end if else call eio%write () call msg_fatal ("Raw event file is not open for writing") end if end subroutine eio_raw_output @ %def eio_raw_output @ Input an event. Note: the particle set is physically copied. If there is a performance issue, we might choose to pointer-assign it instead, with a different version of [[event%set_hard_particle_set]]. <>= procedure :: input_i_prc => eio_raw_input_i_prc procedure :: input_event => eio_raw_input_event <>= subroutine eio_raw_input_i_prc (eio, i_prc, iostat) class(eio_raw_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat if (eio%reading) then read (eio%unit, iostat = iostat) i_prc else call eio%write () call msg_fatal ("Raw event file is not open for reading") end if end subroutine eio_raw_input_i_prc subroutine eio_raw_input_event (eio, event, iostat) class(eio_raw_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat integer :: event_index, i_mci, i_term, channel, i real(default) :: weight, excess, sqme integer :: n_dropped real(default), dimension(:), allocatable :: weight_alt, sqme_alt logical :: has_transform type(particle_set_t), pointer :: pset class(model_data_t), pointer :: model if (eio%reading) then select type (event) type is (event_t) read (eio%unit, iostat = iostat) event_index if (iostat /= 0) return read (eio%unit, iostat = iostat) i_mci if (iostat /= 0) return read (eio%unit, iostat = iostat) i_term if (iostat /= 0) return read (eio%unit, iostat = iostat) channel if (iostat /= 0) return read (eio%unit, iostat = iostat) weight if (iostat /= 0) return read (eio%unit, iostat = iostat) excess if (iostat /= 0) return read (eio%unit, iostat = iostat) n_dropped if (iostat /= 0) return read (eio%unit, iostat = iostat) sqme if (iostat /= 0) return call event%reset_contents () call event%set_index (event_index) call event%select (i_mci, i_term, channel) if (eio%norm_mode /= NORM_UNDEFINED) then call event_normalization_update (weight, & eio%sigma, eio%n, event%get_norm_mode (), eio%norm_mode) call event_normalization_update (excess, & eio%sigma, eio%n, event%get_norm_mode (), eio%norm_mode) end if call event%set (sqme_ref = sqme, weight_ref = weight, & excess_prc = excess, & n_dropped = n_dropped) if (eio%n_alt /= 0) then allocate (sqme_alt (eio%n_alt), weight_alt (eio%n_alt)) do i = 1, eio%n_alt read (eio%unit, iostat = iostat) weight_alt(i) if (iostat /= 0) return read (eio%unit, iostat = iostat) sqme_alt(i) if (iostat /= 0) return end do call event%set (sqme_alt = sqme_alt, weight_alt = weight_alt) end if model => null () if (associated (event%process)) then model => event%process%get_model_ptr () end if allocate (pset) call pset%read_raw (eio%unit, iostat) if (iostat /= 0) return if (associated (model)) call pset%set_model (model) call event%set_hard_particle_set (pset) call pset%final () deallocate (pset) select case (eio%file_version) case (2:) read (eio%unit, iostat = iostat) has_transform if (iostat /= 0) return if (has_transform) then allocate (pset) call pset%read_raw (eio%unit, iostat) if (iostat /= 0) return if (associated (model)) & call pset%set_model (model) call event%link_particle_set (pset) end if end select class default call msg_bug ("Event: read raw: defined only for full event_t") end select else call eio%write () call msg_fatal ("Raw event file is not open for reading") end if end subroutine eio_raw_input_event @ %def eio_raw_input_i_prc @ %def eio_raw_input_event @ <>= procedure :: skip => eio_raw_skip <>= subroutine eio_raw_skip (eio, iostat) class(eio_raw_t), intent(inout) :: eio integer, intent(out) :: iostat if (eio%reading) then read (eio%unit, iostat = iostat) else call eio%write () call msg_fatal ("Raw event file is not open for reading") end if end subroutine eio_raw_skip @ %def eio_raw_skip @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eio_raw_ut.f90]]>>= <> module eio_raw_ut use unit_tests use eio_raw_uti <> <> contains <> end module eio_raw_ut @ %def eio_raw_ut @ <<[[eio_raw_uti.f90]]>>= <> module eio_raw_uti <> <> use model_data use variables use events use eio_data use eio_base use eio_raw use process, only: process_t use instances, only: process_instance_t <> <> contains <> end module eio_raw_uti @ %def eio_raw_uti @ API: driver for the unit tests below. <>= public :: eio_raw_test <>= subroutine eio_raw_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_raw_test @ %def eio_raw_test @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= call test (eio_raw_1, "eio_raw_1", & "read and write event contents", & u, results) <>= public :: eio_raw_1 <>= subroutine eio_raw_1 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(model_data_t), target :: model type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance class(eio_t), allocatable :: eio integer :: i_prc, iostat type(string_t) :: sample write (u, "(A)") "* Test output: eio_raw_1" write (u, "(A)") "* Purpose: generate and read/write an event" write (u, "(A)") write (u, "(A)") "* Initialize test process" call model%init_test () allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model, & run_id = var_str ("run_test")) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_raw_1" allocate (eio_raw_t :: eio) call eio%init_out (sample) call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) write (u, "(A)") call eio%output (event, i_prc = 42) call eio%write (u) call eio%final () call event%final () deallocate (event) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Re-read the event" write (u, "(A)") call eio%init_in (sample) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call eio%input_i_prc (i_prc, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (i_prc):", iostat call eio%input_event (event, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (event):", iostat call eio%write (u) write (u, "(A)") write (u, "(1x,A,I0)") "i_prc = ", i_prc write (u, "(A)") call event%write (u) write (u, "(A)") write (u, "(A)") "* Generate and append another event" write (u, "(A)") call eio%switch_inout () call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) write (u, "(A)") call eio%output (event, i_prc = 5) call eio%write (u) call eio%final () call event%final () deallocate (event) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Re-read both events" write (u, "(A)") call eio%init_in (sample) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call eio%input_i_prc (i_prc, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (i_prc/1):", iostat call eio%input_event (event, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (event/1):", iostat call eio%input_i_prc (i_prc, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (i_prc/2):", iostat call eio%input_event (event, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (event/2):", iostat call eio%write (u) write (u, "(A)") write (u, "(1x,A,I0)") "i_prc = ", i_prc write (u, "(A)") call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () deallocate (eio) call event%final () deallocate (event) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: eio_raw_1" end subroutine eio_raw_1 @ %def eio_raw_1 @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= call test (eio_raw_2, "eio_raw_2", & "handle multiple weights", & u, results) <>= public :: eio_raw_2 <>= subroutine eio_raw_2 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(model_data_t), target :: model type(var_list_t) :: var_list type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(event_sample_data_t) :: data class(eio_t), allocatable :: eio integer :: i_prc, iostat type(string_t) :: sample write (u, "(A)") "* Test output: eio_raw_2" write (u, "(A)") "* Purpose: generate and read/write an event" write (u, "(A)") "* with multiple weights" write (u, "(A)") call model%init_test () write (u, "(A)") "* Initialize test process" allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model, & run_id = var_str ("run_test")) call process_instance%setup_event_data () call data%init (n_proc = 1, n_alt = 2) call var_list_append_log (var_list, var_str ("?unweighted"), .false., & intrinsic = .true.) call var_list_append_string (var_list, var_str ("$sample_normalization"), & var_str ("auto"), intrinsic = .true.) call var_list_append_real (var_list, var_str ("safety_factor"), & 1._default, intrinsic = .true.) allocate (event) call event%basic_init (var_list, n_alt = 2) call event%connect (process_instance, process%get_model_ptr ()) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_raw_2" allocate (eio_raw_t :: eio) call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call event%set (sqme_alt = [2._default, 3._default]) call event%set (weight_alt = & [2 * event%get_weight_ref (), 3 * event%get_weight_ref ()]) call event%store_alt_values () call event%check () call event%write (u) write (u, "(A)") call eio%output (event, i_prc = 42) call eio%write (u) call eio%final () call event%final () deallocate (event) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Re-read the event" write (u, "(A)") call eio%init_in (sample, data) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () allocate (event) call event%basic_init (var_list, n_alt = 2) call event%connect (process_instance, process%get_model_ptr ()) call eio%input_i_prc (i_prc, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (i_prc):", iostat call eio%input_event (event, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (event):", iostat call eio%write (u) write (u, "(A)") write (u, "(1x,A,I0)") "i_prc = ", i_prc write (u, "(A)") call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () deallocate (eio) call event%final () deallocate (event) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: eio_raw_2" end subroutine eio_raw_2 @ %def eio_raw_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Dispatch} An event transform is responsible for dressing a partonic event. Since event transforms are not mutually exclusive but are concatenated, we provide individual dispatchers for each of them. <<[[dispatch_transforms.f90]]>>= <> module dispatch_transforms <> <> use process use variables use system_defs, only: LF use system_dependencies, only: LHAPDF6_AVAILABLE use sf_lhapdf, only: lhapdf_initialize use diagnostics use models use os_interface use beam_structures use resonances, only: resonance_history_set_t use instances, only: process_instance_t, process_instance_hook_t use event_base, only: event_callback_t, event_callback_nop_t use eio_base use eio_raw use eio_checkpoints use eio_callback use eio_lhef use eio_hepmc use eio_lcio use eio_stdhep use eio_ascii use eio_weights use eio_dump use event_transforms use resonance_insertion use isr_epa_handler use decays use shower_base use shower_core use shower use shower_pythia6 use shower_pythia8 use hadrons use mlm_matching use powheg_matching use ckkw_matching use tauola_interface !NODEP! use evt_nlo <> <> contains <> end module dispatch_transforms @ %def dispatch_transforms @ <>= public :: dispatch_evt_nlo <>= subroutine dispatch_evt_nlo (evt, keep_failed_events) class(evt_t), intent(out), pointer :: evt logical, intent(in) :: keep_failed_events call msg_message ("Simulate: activating fixed-order NLO events") allocate (evt_nlo_t :: evt) evt%only_weighted_events = .true. select type (evt) type is (evt_nlo_t) evt%i_evaluation = 0 evt%keep_failed_events = keep_failed_events end select end subroutine dispatch_evt_nlo @ %def dispatch_evt_nlo @ <>= public :: dispatch_evt_resonance <>= subroutine dispatch_evt_resonance (evt, var_list, res_history_set, libname) class(evt_t), intent(out), pointer :: evt type(var_list_t), intent(in) :: var_list type(resonance_history_set_t), dimension(:), intent(in) :: res_history_set type(string_t), intent(in) :: libname logical :: resonance_history resonance_history = var_list%get_lval (var_str ("?resonance_history")) if (resonance_history) then allocate (evt_resonance_t :: evt) call msg_message ("Simulate: activating resonance insertion") select type (evt) type is (evt_resonance_t) call evt%set_resonance_data (res_history_set) call evt%set_library (libname) end select else evt => null () end if end subroutine dispatch_evt_resonance @ %def dispatch_evt_resonance @ Initialize the ISR/EPA handler, depending on active settings. The activation is independent for both handlers, since only one may be needed at a time. However, if both handlers are active, the current implementation requires the handler modes of ISR and EPA to coincide. <>= public :: dispatch_evt_isr_epa_handler <>= subroutine dispatch_evt_isr_epa_handler (evt, var_list) class(evt_t), intent(out), pointer :: evt type(var_list_t), intent(in) :: var_list logical :: isr_recoil logical :: epa_recoil logical :: isr_handler_active logical :: epa_handler_active type(string_t) :: isr_handler_mode type(string_t) :: epa_handler_mode real(default) :: sqrts real(default) :: isr_q_max real(default) :: epa_q_max real(default) :: isr_mass real(default) :: epa_mass isr_handler_active = var_list%get_lval (var_str ("?isr_handler")) if (isr_handler_active) then call msg_message ("Simulate: activating ISR handler") isr_recoil = var_list%get_lval (var_str ("?isr_recoil")) isr_handler_mode = var_list%get_sval (var_str ("$isr_handler_mode")) if (isr_recoil) then call msg_fatal ("Simulate: ISR handler is incompatible & &with ?isr_recoil=true") end if end if epa_handler_active = var_list%get_lval (var_str ("?epa_handler")) if (epa_handler_active) then call msg_message ("Simulate: activating EPA handler") epa_recoil = var_list%get_lval (var_str ("?epa_recoil")) epa_handler_mode = var_list%get_sval (var_str ("$epa_handler_mode")) if (epa_recoil) then call msg_fatal ("Simulate: EPA handler is incompatible & &with ?epa_recoil=true") end if end if if (isr_handler_active .and. epa_handler_active) then if (isr_handler_mode /= epa_handler_mode) then call msg_fatal ("Simulate: ISR/EPA handler: modes must coincide") end if end if if (isr_handler_active .or. epa_handler_active) then allocate (evt_isr_epa_t :: evt) select type (evt) type is (evt_isr_epa_t) if (isr_handler_active) then call evt%set_mode_string (isr_handler_mode) else call evt%set_mode_string (epa_handler_mode) end if sqrts = var_list%get_rval (var_str ("sqrts")) if (isr_handler_active) then isr_q_max = var_list%get_rval (var_str ("isr_q_max")) isr_mass = var_list%get_rval (var_str ("isr_mass")) call evt%set_data_isr (sqrts, isr_q_max, isr_mass) end if if (epa_handler_active) then epa_q_max = var_list%get_rval (var_str ("epa_q_max")) epa_mass = var_list%get_rval (var_str ("epa_mass")) call evt%set_data_epa (sqrts, epa_q_max, epa_mass) end if call msg_message ("Simulate: ISR/EPA handler mode: " & // char (evt%get_mode_string ())) end select else evt => null () end if end subroutine dispatch_evt_isr_epa_handler @ %def dispatch_evt_isr_epa_handler @ <>= public :: dispatch_evt_decay <>= subroutine dispatch_evt_decay (evt, var_list) class(evt_t), intent(out), pointer :: evt type(var_list_t), intent(in), target :: var_list logical :: allow_decays allow_decays = var_list%get_lval (var_str ("?allow_decays")) if (allow_decays) then allocate (evt_decay_t :: evt) call msg_message ("Simulate: activating decays") select type (evt) type is (evt_decay_t) call evt%set_var_list (var_list) end select else evt => null () end if end subroutine dispatch_evt_decay @ %def dispatch_evt_decay @ <>= public :: dispatch_evt_shower <>= subroutine dispatch_evt_shower (evt, var_list, model, fallback_model, & os_data, beam_structure, process) class(evt_t), intent(out), pointer :: evt type(var_list_t), intent(in) :: var_list type(model_t), pointer, intent(in) :: model, fallback_model type(os_data_t), intent(in) :: os_data type(beam_structure_t), intent(in) :: beam_structure type(process_t), intent(in), optional :: process type(string_t) :: lhapdf_file, lhapdf_dir, process_name integer :: lhapdf_member type(shower_settings_t) :: settings type(taudec_settings_t) :: taudec_settings call msg_message ("Simulate: activating parton shower") allocate (evt_shower_t :: evt) call settings%init (var_list) if (associated (model)) then call taudec_settings%init (var_list, model) else call taudec_settings%init (var_list, fallback_model) end if if (present (process)) then process_name = process%get_id () else process_name = 'dispatch_testing' end if select type (evt) type is (evt_shower_t) call evt%init (fallback_model, os_data) lhapdf_member = & var_list%get_ival (var_str ("lhapdf_member")) if (LHAPDF6_AVAILABLE) then lhapdf_dir = & var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = & var_list%get_sval (var_str ("$lhapdf_file")) call lhapdf_initialize & (1, lhapdf_dir, lhapdf_file, lhapdf_member, evt%pdf_data%pdf) end if if (present (process)) call evt%pdf_data%setup ("Shower", & beam_structure, lhapdf_member, process%get_pdf_set ()) select case (settings%method) case (PS_WHIZARD) allocate (shower_t :: evt%shower) case (PS_PYTHIA6) allocate (shower_pythia6_t :: evt%shower) case (PS_PYTHIA8) allocate (shower_pythia8_t :: evt%shower) case default call msg_fatal ('Shower: Method ' // & char (var_list%get_sval (var_str ("$shower_method"))) // & 'not implemented!') end select call evt%shower%init (settings, taudec_settings, evt%pdf_data, os_data) end select call dispatch_matching (evt, settings, var_list, process_name) end subroutine dispatch_evt_shower @ %def dispatch_evt_shower @ <>= public :: dispatch_evt_shower_hook <>= subroutine dispatch_evt_shower_hook (hook, var_list, process_instance) class(process_instance_hook_t), pointer, intent(out) :: hook type(var_list_t), intent(in) :: var_list class(process_instance_t), intent(in), target :: process_instance if (var_list%get_lval (var_str ('?powheg_matching'))) then call msg_message ("Integration hook: add POWHEG hook") allocate (powheg_matching_hook_t :: hook) call hook%init (var_list, process_instance) else hook => null () end if end subroutine dispatch_evt_shower_hook @ %def dispatch_evt_shower_hook @ <>= public :: dispatch_matching <>= subroutine dispatch_matching (evt, settings, var_list, process_name) class(evt_t), intent(inout) :: evt type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_name type(shower_settings_t), intent(in) :: settings select type (evt) type is (evt_shower_t) if (settings%mlm_matching .and. settings%ckkw_matching) then call msg_fatal ("Both MLM and CKKW matching activated," // & LF // " aborting simulation") end if if (settings%powheg_matching) then call msg_message ("Simulate: applying POWHEG matching") allocate (powheg_matching_t :: evt%matching) end if if (settings%mlm_matching) then call msg_message ("Simulate: applying MLM matching") allocate (mlm_matching_t :: evt%matching) end if if (settings%ckkw_matching) then call msg_warning ("Simulate: CKKW(-L) matching not yet supported") allocate (ckkw_matching_t :: evt%matching) end if if (allocated (evt%matching)) & call evt%matching%init (var_list, process_name) end select end subroutine dispatch_matching @ %def dispatch_matching @ <>= public :: dispatch_evt_hadrons <>= subroutine dispatch_evt_hadrons (evt, var_list, fallback_model) class(evt_t), intent(out), pointer :: evt type(var_list_t), intent(in) :: var_list type(model_t), pointer, intent(in) :: fallback_model type(shower_settings_t) :: shower_settings type(hadron_settings_t) :: hadron_settings allocate (evt_hadrons_t :: evt) call msg_message ("Simulate: activating hadronization") call shower_settings%init (var_list) call hadron_settings%init (var_list) select type (evt) type is (evt_hadrons_t) call evt%init (fallback_model) select case (hadron_settings%method) case (HADRONS_WHIZARD) allocate (hadrons_hadrons_t :: evt%hadrons) case (HADRONS_PYTHIA6) allocate (hadrons_pythia6_t :: evt%hadrons) case (HADRONS_PYTHIA8) allocate (hadrons_pythia8_t :: evt%hadrons) case default call msg_fatal ('Hadronization: Method ' // & char (var_list%get_sval (var_str ("hadronization_method"))) // & 'not implemented!') end select call evt%hadrons%init & (shower_settings, hadron_settings, fallback_model) end select end subroutine dispatch_evt_hadrons @ %def dispatch_evt_hadrons @ We cannot put this in the [[events]] subdir due to [[eio_raw_t]], which is defined here. <>= public :: dispatch_eio <>= subroutine dispatch_eio (eio, method, var_list, fallback_model, & event_callback) class(eio_t), allocatable, intent(inout) :: eio type(string_t), intent(in) :: method type(var_list_t), intent(in) :: var_list type(model_t), target, intent(in) :: fallback_model class(event_callback_t), allocatable, intent(in) :: event_callback !!! !!! !!! Workaround for ifort v18(beta) bug type(event_callback_nop_t) :: event_callback_tmp logical :: check, keep_beams, keep_remnants, recover_beams logical :: use_alphas_from_file, use_scale_from_file logical :: write_sqme_prc, write_sqme_ref, write_sqme_alt logical :: output_cross_section, ensure_order type(string_t) :: lhef_version, lhef_extension, raw_version type(string_t) :: extension_default, debug_extension, dump_extension, & extension_hepmc, & extension_lha, extension_hepevt, extension_ascii_short, & extension_ascii_long, extension_athena, extension_mokka, & extension_stdhep, extension_stdhep_up, extension_stdhep_ev4, & extension_raw, extension_hepevt_verb, extension_lha_verb, & extension_lcio integer :: checkpoint logical :: show_process, show_transforms, show_decay, verbose, pacified logical :: dump_weights, dump_compressed, dump_summary, dump_screen keep_beams = & var_list%get_lval (var_str ("?keep_beams")) keep_remnants = & var_list%get_lval (var_str ("?keep_remnants")) ensure_order = & var_list%get_lval (var_str ("?hepevt_ensure_order")) recover_beams = & var_list%get_lval (var_str ("?recover_beams")) use_alphas_from_file = & var_list%get_lval (var_str ("?use_alphas_from_file")) use_scale_from_file = & var_list%get_lval (var_str ("?use_scale_from_file")) select case (char (method)) case ("raw") allocate (eio_raw_t :: eio) select type (eio) type is (eio_raw_t) check = & var_list%get_lval (var_str ("?check_event_file")) raw_version = & var_list%get_sval (var_str ("$event_file_version")) extension_raw = & var_list%get_sval (var_str ("$extension_raw")) call eio%set_parameters (check, raw_version, extension_raw) end select case ("checkpoint") allocate (eio_checkpoints_t :: eio) select type (eio) type is (eio_checkpoints_t) checkpoint = & var_list%get_ival (var_str ("checkpoint")) pacified = & var_list%get_lval (var_str ("?pacify")) call eio%set_parameters (checkpoint, blank = pacified) end select case ("callback") allocate (eio_callback_t :: eio) select type (eio) type is (eio_callback_t) checkpoint = & var_list%get_ival (var_str ("event_callback_interval")) if (allocated (event_callback)) then call eio%set_parameters (event_callback, checkpoint) else !!! !!! !!! Workaround for ifort v18(beta) bug ! call eio%set_parameters (event_callback_nop_t (), 0) call eio%set_parameters (event_callback_tmp, 0) end if end select case ("lhef") allocate (eio_lhef_t :: eio) select type (eio) type is (eio_lhef_t) lhef_version = & var_list%get_sval (var_str ("$lhef_version")) lhef_extension = & var_list%get_sval (var_str ("$lhef_extension")) write_sqme_prc = & var_list%get_lval (var_str ("?lhef_write_sqme_prc")) write_sqme_ref = & var_list%get_lval (var_str ("?lhef_write_sqme_ref")) write_sqme_alt = & var_list%get_lval (var_str ("?lhef_write_sqme_alt")) call eio%set_parameters ( & keep_beams, keep_remnants, recover_beams, & use_alphas_from_file, use_scale_from_file, & char (lhef_version), lhef_extension, & write_sqme_ref, write_sqme_prc, write_sqme_alt) end select case ("hepmc") allocate (eio_hepmc_t :: eio) select type (eio) type is (eio_hepmc_t) output_cross_section = & var_list%get_lval (var_str ("?hepmc_output_cross_section")) extension_hepmc = & var_list%get_sval (var_str ("$extension_hepmc")) call eio%set_parameters (recover_beams, & use_alphas_from_file, use_scale_from_file, & extension_hepmc, output_cross_section) end select case ("lcio") allocate (eio_lcio_t :: eio) select type (eio) type is (eio_lcio_t) extension_lcio = & var_list%get_sval (var_str ("$extension_lcio")) call eio%set_parameters (recover_beams, & use_alphas_from_file, use_scale_from_file, & extension_lcio) end select case ("stdhep") allocate (eio_stdhep_hepevt_t :: eio) select type (eio) type is (eio_stdhep_hepevt_t) extension_stdhep = & var_list%get_sval (var_str ("$extension_stdhep")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, recover_beams, & use_alphas_from_file, use_scale_from_file, extension_stdhep) end select case ("stdhep_up") allocate (eio_stdhep_hepeup_t :: eio) select type (eio) type is (eio_stdhep_hepeup_t) extension_stdhep_up = & var_list%get_sval (var_str ("$extension_stdhep_up")) call eio%set_parameters (keep_beams, keep_remnants, ensure_order, & recover_beams, use_alphas_from_file, & use_scale_from_file, extension_stdhep_up) end select case ("stdhep_ev4") allocate (eio_stdhep_hepev4_t :: eio) select type (eio) type is (eio_stdhep_hepev4_t) extension_stdhep_ev4 = & var_list%get_sval (var_str ("$extension_stdhep_ev4")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, recover_beams, & use_alphas_from_file, use_scale_from_file, extension_stdhep_ev4) end select case ("ascii") allocate (eio_ascii_ascii_t :: eio) select type (eio) type is (eio_ascii_ascii_t) extension_default = & var_list%get_sval (var_str ("$extension_default")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_default) end select case ("athena") allocate (eio_ascii_athena_t :: eio) select type (eio) type is (eio_ascii_athena_t) extension_athena = & var_list%get_sval (var_str ("$extension_athena")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_athena) end select case ("debug") allocate (eio_ascii_debug_t :: eio) select type (eio) type is (eio_ascii_debug_t) debug_extension = & var_list%get_sval (var_str ("$debug_extension")) show_process = & var_list%get_lval (var_str ("?debug_process")) show_transforms = & var_list%get_lval (var_str ("?debug_transforms")) show_decay = & var_list%get_lval (var_str ("?debug_decay")) verbose = & var_list%get_lval (var_str ("?debug_verbose")) call eio%set_parameters ( & extension = debug_extension, & show_process = show_process, & show_transforms = show_transforms, & show_decay = show_decay, & verbose = verbose) end select case ("dump") allocate (eio_dump_t :: eio) select type (eio) type is (eio_dump_t) dump_extension = & var_list%get_sval (var_str ("$dump_extension")) pacified = & var_list%get_lval (var_str ("?pacify")) dump_weights = & var_list%get_lval (var_str ("?dump_weights")) dump_compressed = & var_list%get_lval (var_str ("?dump_compressed")) dump_summary = & var_list%get_lval (var_str ("?dump_summary")) dump_screen = & var_list%get_lval (var_str ("?dump_screen")) call eio%set_parameters ( & extension = dump_extension, & pacify = pacified, & weights = dump_weights, & compressed = dump_compressed, & summary = dump_summary, & screen = dump_screen) end select case ("hepevt") allocate (eio_ascii_hepevt_t :: eio) select type (eio) type is (eio_ascii_hepevt_t) extension_hepevt = & var_list%get_sval (var_str ("$extension_hepevt")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_hepevt) end select case ("hepevt_verb") allocate (eio_ascii_hepevt_verb_t :: eio) select type (eio) type is (eio_ascii_hepevt_verb_t) extension_hepevt_verb = & var_list%get_sval (var_str ("$extension_hepevt_verb")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_hepevt_verb) end select case ("lha") allocate (eio_ascii_lha_t :: eio) select type (eio) type is (eio_ascii_lha_t) extension_lha = & var_list%get_sval (var_str ("$extension_lha")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_lha) end select case ("lha_verb") allocate (eio_ascii_lha_verb_t :: eio) select type (eio) type is (eio_ascii_lha_verb_t) extension_lha_verb = var_list%get_sval ( & var_str ("$extension_lha_verb")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_lha_verb) end select case ("long") allocate (eio_ascii_long_t :: eio) select type (eio) type is (eio_ascii_long_t) extension_ascii_long = & var_list%get_sval (var_str ("$extension_ascii_long")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_ascii_long) end select case ("mokka") allocate (eio_ascii_mokka_t :: eio) select type (eio) type is (eio_ascii_mokka_t) extension_mokka = & var_list%get_sval (var_str ("$extension_mokka")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_mokka) end select case ("short") allocate (eio_ascii_short_t :: eio) select type (eio) type is (eio_ascii_short_t) extension_ascii_short = & var_list%get_sval (var_str ("$extension_ascii_short")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_ascii_short) end select case ("weight_stream") allocate (eio_weights_t :: eio) select type (eio) type is (eio_weights_t) pacified = & var_list%get_lval (var_str ("?pacify")) call eio%set_parameters (pacify = pacified) end select case default call msg_fatal ("Event I/O method '" // char (method) & // "' not implemented") end select call eio%set_fallback_model (fallback_model) end subroutine dispatch_eio @ %def dispatch_eio @ @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[dispatch_transforms_ut.f90]]>>= <> module dispatch_transforms_ut use unit_tests use dispatch_transforms_uti <> <> contains <> end module dispatch_transforms_ut @ %def dispatch_transforms_ut @ <<[[dispatch_transforms_uti.f90]]>>= <> module dispatch_transforms_uti <> <> use format_utils, only: write_separator use variables use event_base, only: event_callback_t use models, only: model_t, model_list_t use models, only: syntax_model_file_init, syntax_model_file_final use resonances, only: resonance_history_set_t use beam_structures, only: beam_structure_t use eio_base, only: eio_t use os_interface, only: os_data_t use event_transforms, only: evt_t use dispatch_transforms <> <> contains <> end module dispatch_transforms_uti @ %def dispatch_transforms_uti @ API: driver for the unit tests below. <>= public ::dispatch_transforms_test <>= subroutine dispatch_transforms_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine dispatch_transforms_test @ %def dispatch_transforms_test @ \subsubsection{Event I/O} <>= call test (dispatch_transforms_1, "dispatch_transforms_1", & "event I/O", & u, results) <>= public :: dispatch_transforms_1 <>= subroutine dispatch_transforms_1 (u) integer, intent(in) :: u type(var_list_t) :: var_list type(model_list_t) :: model_list type(model_t), pointer :: model type(os_data_t) :: os_data class(event_callback_t), allocatable :: event_callback class(eio_t), allocatable :: eio write (u, "(A)") "* Test output: dispatch_transforms_1" write (u, "(A)") "* Purpose: allocate an event I/O (eio) stream" write (u, "(A)") call var_list%init_defaults (0) call os_data%init () call syntax_model_file_init () call model_list%read_model (var_str ("SM_hadrons"), & var_str ("SM_hadrons.mdl"), os_data, model) write (u, "(A)") "* Allocate as raw" write (u, "(A)") call dispatch_eio (eio, var_str ("raw"), var_list, & model, event_callback) call eio%write (u) call eio%final () deallocate (eio) write (u, "(A)") write (u, "(A)") "* Allocate as checkpoints:" write (u, "(A)") call dispatch_eio (eio, var_str ("checkpoint"), var_list, & model, event_callback) call eio%write (u) call eio%final () deallocate (eio) write (u, "(A)") write (u, "(A)") "* Allocate as LHEF:" write (u, "(A)") call var_list%set_string (var_str ("$lhef_extension"), & var_str ("lhe_custom"), is_known = .true.) call dispatch_eio (eio, var_str ("lhef"), var_list, & model, event_callback) call eio%write (u) call eio%final () deallocate (eio) write (u, "(A)") write (u, "(A)") "* Allocate as HepMC:" write (u, "(A)") call dispatch_eio (eio, var_str ("hepmc"), var_list, & model, event_callback) call eio%write (u) call eio%final () deallocate (eio) write (u, "(A)") write (u, "(A)") "* Allocate as weight_stream" write (u, "(A)") call dispatch_eio (eio, var_str ("weight_stream"), var_list, & model, event_callback) call eio%write (u) call eio%final () deallocate (eio) write (u, "(A)") write (u, "(A)") "* Allocate as debug format" write (u, "(A)") call var_list%set_log (var_str ("?debug_verbose"), & .false., is_known = .true.) call dispatch_eio (eio, var_str ("debug"), var_list, & model, event_callback) call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () call var_list%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_transforms_1" end subroutine dispatch_transforms_1 @ %def dispatch_transforms_1 @ \subsubsection{Event transforms} This test dispatches [[evt]] (event transform) objects. <>= call test (dispatch_transforms_2, "dispatch_transforms_2", & "event transforms", & u, results) <>= public :: dispatch_transforms_2 <>= subroutine dispatch_transforms_2 (u) integer, intent(in) :: u type(var_list_t), target :: var_list type(model_list_t) :: model_list type(model_t), pointer :: model type(os_data_t) :: os_data type(resonance_history_set_t), dimension(1) :: res_history_set type(beam_structure_t) :: beam_structure class(evt_t), pointer :: evt write (u, "(A)") "* Test output: dispatch_transforms_2" write (u, "(A)") "* Purpose: configure event transform" write (u, "(A)") call syntax_model_file_init () call var_list%init_defaults (0) call os_data%init () call model_list%read_model (var_str ("SM_hadrons"), & var_str ("SM_hadrons.mdl"), os_data, model) write (u, "(A)") "* Resonance insertion" write (u, "(A)") call var_list%set_log (var_str ("?resonance_history"), .true., & is_known = .true.) call dispatch_evt_resonance (evt, var_list, & res_history_set, & var_str ("foo_R")) call evt%write (u, verbose = .true., more_verbose = .true.) call evt%final () deallocate (evt) write (u, "(A)") write (u, "(A)") "* ISR handler" write (u, "(A)") call var_list%set_log (var_str ("?isr_handler"), .true., & is_known = .true.) call var_list%set_log (var_str ("?epa_handler"), .false., & is_known = .true.) call var_list%set_string (var_str ("$isr_handler_mode"), & var_str ("recoil"), & is_known = .true.) call var_list%set_real (var_str ("sqrts"), 100._default, & is_known = .true.) call var_list%set_real (var_str ("isr_mass"), 511.e-6_default, & is_known = .true.) call dispatch_evt_isr_epa_handler (evt, var_list) call evt%write (u, verbose = .true., more_verbose = .true.) call evt%final () deallocate (evt) write (u, "(A)") write (u, "(A)") "* EPA handler" write (u, "(A)") call var_list%set_log (var_str ("?isr_handler"), .false., & is_known = .true.) call var_list%set_log (var_str ("?epa_handler"), .true., & is_known = .true.) call var_list%set_string (var_str ("$epa_handler_mode"), & var_str ("recoil"), & is_known = .true.) call var_list%set_real (var_str ("sqrts"), 100._default, & is_known = .true.) call var_list%set_real (var_str ("epa_mass"), 511.e-6_default, & is_known = .true.) call dispatch_evt_isr_epa_handler (evt, var_list) call evt%write (u, verbose = .true., more_verbose = .true.) call evt%final () deallocate (evt) write (u, "(A)") write (u, "(A)") "* Partonic decays" write (u, "(A)") call dispatch_evt_decay (evt, var_list) call evt%write (u, verbose = .true., more_verbose = .true.) call evt%final () deallocate (evt) write (u, "(A)") write (u, "(A)") "* Shower" write (u, "(A)") call var_list%set_log (var_str ("?allow_shower"), .true., & is_known = .true.) call var_list%set_string (var_str ("$shower_method"), & var_str ("WHIZARD"), is_known = .true.) call dispatch_evt_shower (evt, var_list, model, & model, os_data, beam_structure) call evt%write (u) call write_separator (u, 2) call evt%final () deallocate (evt) call var_list%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_transforms_2" end subroutine dispatch_transforms_2 @ %def dispatch_transforms_2 Index: trunk/src/recola/recola.nw =================================================================== --- trunk/src/recola/recola.nw (revision 8234) +++ trunk/src/recola/recola.nw (revision 8235) @@ -1,3284 +1,3278 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: interface to Recola 1-loop library @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Recola Interface} \section{Recola wrapper} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% <<[[recola_wrapper.f90]]>>= <> module recola_wrapper use recola !NODEP! use kinds <> use constants, only: zero use diagnostics, only: msg_fatal, msg_message, msg_debug, msg_debug2, D_ME_METHODS use io_units, only: given_output_unit <> <> <> <> <> contains <> end module recola_wrapper @ %def recola_wrapper @ <>= public :: rclwrap_is_active <>= logical, parameter :: rclwrap_is_active = .true. @ %def rclwrap_is_active @ Returns the particle string corresponding to a pdg code used in the Recola process definition <>= public :: get_recola_particle_string <>= elemental function get_recola_particle_string (pdg) result (name) type(string_t) :: name integer, intent(in) :: pdg select case (pdg) case (1) name = var_str ("d") case (-1) name = var_str ("d~") case (2) name = var_str ("u") case (-2) name = var_str ("u~") case (3) name = var_str ("s") case (-3) name = var_str ("s~") case (4) name = var_str ("c") case (-4) name = var_str ("c~") case (5) name = var_str ("b") case (-5) name = var_str ("b~") case (6) name = var_str ("t") case (-6) name = var_str ("t~") case (11) name = var_str ("e-") case (-11) name = var_str ("e+") case (12) name = var_str ("nu_e") case (-12) name = var_str ("nu_e~") case (13) name = var_str ("mu-") case (-13) name = var_str ("mu+") case (14) name = var_str ("nu_mu") case (-14) name = var_str ("nu_mu~") case (15) name = var_str ("tau-") case (-15) name = var_str ("tau+") case (16) name = var_str ("nu_tau") case (-16) name = var_str ("nu_tau~") case (21) name = var_str ("g") case (22) name = var_str ("A") case (23) name = var_str ("Z") case (24) name = var_str ("W+") case (-24) name = var_str ("W-") case (25) name = var_str ("H") end select end function get_recola_particle_string @ %def get_recola_particle_string @ <>= subroutine rclwrap_define_process (id, process_string, order) integer, intent(in) :: id type(string_t), intent(in) :: process_string type(string_t), intent(in) :: order call msg_debug2 (D_ME_METHODS, "define_process_rcl") call define_process_rcl (id, char (process_string), char (order)) end subroutine rclwrap_define_process @ %def rclwrap_define_process @ This defines a wrapper for the information required to define a RECOLA process. It is used to collect the process definitions in an array. <>= type :: rcl_process_t private integer :: id type(string_t) :: process_string type(string_t) :: order contains <> end type rcl_process_t @ %def rcl_process_t @ <>= interface rcl_process_t module procedure new_rcl_process_t end interface @ %def rcl_process_t @ <>= function new_rcl_process_t (id, process_string, order) integer, intent(in) :: id type(string_t), intent(in) :: process_string, order type(rcl_process_t) :: new_rcl_process_t new_rcl_process_t%id = id new_rcl_process_t%process_string = process_string new_rcl_process_t%order = order end function new_rcl_process_t @ %def new_rcl_process_t <>= procedure :: get_params => rcl_process_get_params <>= subroutine rcl_process_get_params (prc, id, process_string, order) class(rcl_process_t), intent(in) :: prc integer, intent(out) :: id type(string_t), intent(out) :: process_string type(string_t), intent(out) :: order id = prc%id process_string = prc%process_string order = prc%order end subroutine rcl_process_get_params @ %def rcl_process_get_params @ Output. <>= procedure :: write => rcl_process_write <>= subroutine rcl_process_write (object, unit) class(rcl_process_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A,I0,2(1x,A,1x))") "RECOLA process:", & "id=", object%id, "process_string=", char(object%process_string), & "order=", char(object%order) end subroutine rcl_process_write @ %def rcl_process_write @ This defines a singleton object, located in this module only, that controls RECOLA initialization and process management. When WHIZARD compiles processes, it should also run the RECOLA "`controller"', which actually initializes RECOLA for integration and manages process information in an array. The main complication is that this has to be done after all processes have been registered, and cannot be redone. We could work with module variables directly, but the singleton pattern, e.g., allows us to work with multiple RECOLA instances, if this becomes possible in the future. Type and object can be private. <>= type :: rcl_controller_t private logical :: active = .false. logical :: defined = .false. logical :: done = .false. integer :: recola_id = 0 type(rcl_process_t), dimension (:), allocatable :: processes integer :: n_processes = 0 contains <> end type rcl_controller_t @ %def rcl_controller_t <>= type(rcl_controller_t), target, save :: rcl_controller @ %def rcl_controller @ Add a RECOLA process to the controller. This will make sure that processes can be redefined if additional definitions are to be made after process generation. <>= procedure :: add_process => rcl_controller_add_process <>= subroutine rcl_controller_add_process (rcl, process) class(rcl_controller_t), intent(inout) :: rcl type(rcl_process_t), intent(in) :: process type(rcl_process_t), dimension (:), allocatable :: temp if (rcl%n_processes == size(rcl%processes)) then allocate( temp(2 * rcl%n_processes) ) temp(:rcl%n_processes) = rcl%processes call move_alloc(temp, rcl%processes) end if rcl%processes(rcl%n_processes + 1) = process rcl%n_processes = rcl%n_processes + 1 end subroutine rcl_controller_add_process @ %def rcl_controller_add_process @ Define all processes added to the controller, and only them. If processes have been defined before, RECOLA is reset. <>= procedure :: define_processes => rcl_controller_define_processes <>= subroutine rcl_controller_define_processes (rcl) class(rcl_controller_t), intent(inout) :: rcl integer :: id, i type(string_t) :: process_string type(string_t) :: order if (rcl%defined) then if (.not. rcl%done) call rclwrap_generate_processes () call msg_debug2 (D_ME_METHODS, "reset_recola_rcl") call reset_recola_rcl () end if do i = 1, rcl%n_processes call rcl%processes(i)%get_params(id, process_string, order) call rclwrap_define_process (id, process_string, order) end do rcl%defined = .true. rcl%done = .false. end subroutine rcl_controller_define_processes @ %def rcl_controller_define_processes @ Revert to initial state. Also, reset RECOLA (only if it has already done something). <>= procedure :: reset => rcl_controller_reset <>= subroutine rcl_controller_reset (rcl) class(rcl_controller_t), intent(inout) :: rcl if (rcl%active .or. rcl%done) then call msg_debug2 (D_ME_METHODS, "reset_recola_rcl") if (allocated (rcl%processes)) deallocate (rcl%processes) call reset_recola_rcl () end if rcl%active = .false. rcl%defined = .false. rcl%done = .false. rcl%recola_id = 0 rcl%n_processes = 0 end subroutine rcl_controller_reset @ %def rcl_controller_reset @ Output. <>= procedure :: write => rcl_controller_write <>= subroutine rcl_controller_write (object, unit) class(rcl_controller_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A,2(1x,A,L1),2(1x,A,I0))") "RECOLA controller:", & "active=", object%active, "done=", object%done, & "id=", object%recola_id, "n_processes=", object%n_processes end subroutine rcl_controller_write @ %def rcl_controller_write @ Return a new numeric process ID, incrementing the counter once. <>= procedure :: get_new_id => rcl_controller_get_new_id <>= subroutine rcl_controller_get_new_id (object, id) class(rcl_controller_t), intent(inout) :: object integer, intent(out) :: id object%recola_id = object%recola_id + 1 id = object%recola_id end subroutine rcl_controller_get_new_id @ %def rcl_controller_get_new_id @ Return the current numeric process ID without incrementing the counter. <>= procedure :: get_current_id => rcl_controller_get_current_id <>= subroutine rcl_controller_get_current_id (object, id) class(rcl_controller_t), intent(inout) :: object integer, intent(out) :: id id = object%recola_id end subroutine rcl_controller_get_current_id @ %def rcl_controller_get_current_id @ Do not allow activation if processes have been calculated previously. Otherwise set the flag. <>= procedure :: activate => rcl_controller_activate <>= subroutine rcl_controller_activate (rcl) class(rcl_controller_t), intent(inout) :: rcl if ( .not. allocated(rcl%processes) ) allocate ( rcl%processes(10) ) rcl_controller%active = .true. end subroutine rcl_controller_activate @ %def rcl_controller_activate @ Start process initialization by calling the RECOLA API. Do not allow this twice (skip silently), and skip anyway if there is no activation. <>= procedure :: generate_processes => rcl_controller_generate_processes <>= subroutine rcl_controller_generate_processes (rcl) class(rcl_controller_t), intent(inout) :: rcl if (rcl_controller%active) then if (.not. rcl_controller%done) then call msg_message ("Recola: preparing processes for integration") call generate_processes_rcl () rcl_controller%done = .true. end if end if end subroutine rcl_controller_generate_processes @ %def rcl_controller_generate_processes @ Return a new numeric RECOLA process ID. The singleton nature of the controller guarantees that the ID is unique. <>= public :: rclwrap_get_new_recola_id <>= subroutine rclwrap_get_new_recola_id (id) integer, intent(out) :: id call rcl_controller%get_new_id (id) end subroutine rclwrap_get_new_recola_id @ %def rclwrap_get_new_recola_id @ Return the current numeric RECOLA process ID. This coincides with the amount of IDs currently in use. <>= public :: rclwrap_get_current_recola_id <>= function rclwrap_get_current_recola_id () result (n) integer :: n call rcl_controller%get_current_id (n) end function rclwrap_get_current_recola_id @ %def rclwrap_get_current_recola_id @ This procedure records the fact that there is a recola process pending, so we will have to call [[generate_processes]] before we can calculate anything with Recola. <>= public :: rclwrap_request_generate_processes <>= subroutine rclwrap_request_generate_processes () call msg_debug2 (D_ME_METHODS, "request_generate_processes_rcl") call rcl_controller%activate () end subroutine rclwrap_request_generate_processes @ %def rclwrap_request_generate_processes @ Add a process to be defined later <>= public :: rclwrap_add_process <>= subroutine rclwrap_add_process (id, process_string, order) integer, intent(in) :: id type(string_t), intent(in) :: process_string, order type(rcl_process_t) :: prc call msg_debug2 (D_ME_METHODS, "add_process_rcl: id", id) prc = rcl_process_t (id, process_string, order) call rcl_controller%add_process (prc) end subroutine rclwrap_add_process @ %def rclwrap_add_process @ Define all added processes. Reset if processes were already defined. <>= public :: rclwrap_define_processes <>= subroutine rclwrap_define_processes () call msg_debug2 (D_ME_METHODS, "define_processes_rcl") call rcl_controller%define_processes () end subroutine rclwrap_define_processes @ %def rclwrap_define_processes @ We call this after all processes have been added and defined, so RECOLA can initialize itself for integration. <>= public :: rclwrap_generate_processes <>= subroutine rclwrap_generate_processes () call msg_debug2 (D_ME_METHODS, "generate_processes_rcl") call rcl_controller%generate_processes () end subroutine rclwrap_generate_processes @ %def rclwrap_generate_processes @ <>= public :: rclwrap_compute_process <>= subroutine rclwrap_compute_process (id, p, order, sqme) integer, intent(in) :: id real(double), intent(in), dimension(:,:) :: p character(len=*), intent(in) :: order real(double), intent(out), dimension(0:1), optional :: sqme call msg_debug2 (D_ME_METHODS, "compute_process_rcl") call compute_process_rcl (id, p, order, sqme) end subroutine rclwrap_compute_process @ %def rclwrap_compute_process @ <>= public :: rclwrap_get_amplitude <>= subroutine rclwrap_get_amplitude (id, g_power, order, col, hel, amp) integer, intent(in) :: id, g_power character(len=*), intent(in) :: order integer, dimension(:), intent(in) :: col, hel complex(double), intent(out) :: amp call msg_debug2 (D_ME_METHODS, "get_amplitude_rcl") call get_amplitude_rcl (id, g_power, order, col, hel, amp) end subroutine rclwrap_get_amplitude @ %def rclwrap_get_amplitude @ <>= public :: rclwrap_get_squared_amplitude <>= subroutine rclwrap_get_squared_amplitude (id, alphas_power, order, sqme) integer, intent(in) :: id, alphas_power character(len=*), intent(in) :: order real(double), intent(out) :: sqme call msg_debug2 (D_ME_METHODS, "get_squared_amplitude_rcl") call get_squared_amplitude_rcl (id, alphas_power, order, sqme) end subroutine rclwrap_get_squared_amplitude @ %def rclwrap_get_squared_amplitude @ <>= public :: rclwrap_set_pole_mass <>= subroutine rclwrap_set_pole_mass (pdg_id, mass, width) integer, intent(in) :: pdg_id real(double), intent(in) :: mass, width call msg_debug2 (D_ME_METHODS, "rclwrap_set_pole_mass of ", pdg_id) select case (abs(pdg_id)) case (11) if (width > zero) & call msg_fatal ("Recola pole mass: Attempting to set non-zero electron width!") call set_pole_mass_electron_rcl (mass) case (13) call set_pole_mass_muon_rcl (mass, width) case (15) call set_pole_mass_tau_rcl (mass, width) case (1) if (width > zero) & call msg_fatal ("Recola pole mass: Attempting to set non-zero down-quark width!") call set_pole_mass_down_rcl (mass) case (2) if (width > zero) & call msg_fatal ("Recola pole mass: Attempting to set non-zero up-quark width!") call set_pole_mass_up_rcl (mass) case (3) if (width > zero) & call msg_fatal ("Recola pole mass: Attempting to set non-zero strange-quark width!") call set_pole_mass_strange_rcl (mass) case (4) call set_pole_mass_charm_rcl (mass, width) case (5) call set_pole_mass_bottom_rcl (mass, width) case (6) call set_pole_mass_top_rcl (mass, width) case (23) call set_pole_mass_z_rcl (mass, width) case (24) call set_pole_mass_w_rcl (mass, width) case (25) call set_pole_mass_h_rcl (mass, width) case default call msg_fatal ("Recola pole mass: Unsupported particle") end select end subroutine rclwrap_set_pole_mass @ %def rclwrap_set_pole_mass @ <>= public :: rclwrap_set_onshell_mass <>= subroutine rclwrap_set_onshell_mass (pdg_id, mass, width) integer, intent(in) :: pdg_id real(double), intent(in) :: mass, width call msg_debug2 (D_ME_METHODS, "rclwrap_set_onshell_mass of ", pdg_id) select case (abs(pdg_id)) case (23) call set_onshell_mass_z_rcl (mass, width) case (24) call set_onshell_mass_w_rcl (mass, width) case default call msg_fatal ("Recola onshell mass: Only for W and Z") end select end subroutine rclwrap_set_onshell_mass @ %def rclwrap_set_onshell_mass @ <>= public :: rclwrap_use_gfermi_scheme <>= subroutine rclwrap_use_gfermi_scheme (gf) real(double), intent(in), optional :: gf call msg_debug2 (D_ME_METHODS, "use_gfermi_scheme_rcl", & real(gf, kind=default)) call use_gfermi_scheme_rcl (gf) end subroutine rclwrap_use_gfermi_scheme @ %def rclwrap_use_gfermi_scheme @ <>= public :: rclwrap_set_light_fermions <>= subroutine rclwrap_set_light_fermions (m) real(double), intent(in) :: m call msg_debug2 (D_ME_METHODS, "set_light_fermions_rcl", & real(m, kind=default)) call set_light_fermions_rcl (m) end subroutine rclwrap_set_light_fermions @ %def rclwrap_set_light_fermions @ <>= public :: rclwrap_set_light_fermion <>= subroutine rclwrap_set_light_fermion (pdg_id) integer, intent(in) :: pdg_id call msg_debug2 (D_ME_METHODS, "rclwrap_set_light_fermion", pdg_id) select case (abs(pdg_id)) case (1) call set_light_down_rcl () case (2) call set_light_up_rcl () case (3) call set_light_strange_rcl () case (4) call set_light_charm_rcl () case (5) call set_light_bottom_rcl () case (6) call set_light_top_rcl () case (11) call set_light_electron_rcl () case (13) call set_light_muon_rcl () case (15) call set_light_tau_rcl () end select end subroutine rclwrap_set_light_fermion @ %def rclwrap_set_light_fermion @ <>= public :: rclwrap_unset_light_fermion <>= subroutine rclwrap_unset_light_fermion (pdg_id) integer, intent(in) :: pdg_id call msg_debug2 (D_ME_METHODS, "rclwrap_unset_light_fermion", pdg_id) select case (abs(pdg_id)) case (1) call unset_light_down_rcl () case (2) call unset_light_up_rcl () case (3) call unset_light_strange_rcl () case (4) call unset_light_charm_rcl () case (5) call unset_light_bottom_rcl () case (6) call unset_light_top_rcl () case (11) call unset_light_electron_rcl () case (13) call unset_light_muon_rcl () case (15) call unset_light_tau_rcl () end select end subroutine rclwrap_unset_light_fermion @ %def rclwrap_unset_light_fermion @ <>= public :: rclwrap_set_onshell_scheme <>= subroutine rclwrap_set_onshell_scheme call msg_debug2 (D_ME_METHODS, "set_on_shell_scheme_rcl") call set_on_shell_scheme_rcl () end subroutine rclwrap_set_onshell_scheme @ %def rclwrap_set_onshell_scheme @ <>= public :: rclwrap_set_alpha_s <>= subroutine rclwrap_set_alpha_s (alpha_s, mu, nf) real(double), intent(in) :: alpha_s, mu integer, intent(in) :: nf call msg_debug2 (D_ME_METHODS, "set_alphas_rcl") call set_alphas_rcl (alpha_s, mu, nf) end subroutine rclwrap_set_alpha_s @ %def rclwrap_set_alpha_s @ <>= public :: rclwrap_get_alpha_s <>= function rclwrap_get_alpha_s () result (alpha_s) real(double) :: alpha_s call msg_debug2 (D_ME_METHODS, "get_alphas_rcl") call get_alphas_rcl (alpha_s) end function rclwrap_get_alpha_s @ %def rclwrap_get_alpha_s @ <>= public :: rclwrap_get_helicity_configurations <>= subroutine rclwrap_get_helicity_configurations (id, hel) integer, intent(in) :: id integer, intent(inout), dimension(:,:), allocatable :: hel call get_helicity_configurations_rcl (id, hel) end subroutine rclwrap_get_helicity_configurations @ %def rclwrap_get_helicity_configurations @ <>= public :: rclwrap_get_color_configurations <>= subroutine rclwrap_get_color_configurations (id, col) integer, intent(in) :: id integer, intent(out), dimension(:,:), allocatable :: col call get_colour_configurations_rcl (id, col) end subroutine rclwrap_get_color_configurations @ %def rclwrap_get_color_configurations @ Selects dimensional regularization for soft singularities. <>= public :: rclwrap_use_dim_reg_soft <>= subroutine rclwrap_use_dim_reg_soft () call msg_debug2 (D_ME_METHODS, "use_dim_reg_soft_rcl") call use_dim_reg_soft_rcl () end subroutine rclwrap_use_dim_reg_soft @ %def rclwrap_use_dim_reg_soft @ Selects mass regularization for soft singularities and sets the mass regulator in GeV to [[m]]. <>= public :: rclwrap_use_mass_reg_soft <>= subroutine rclwrap_use_mass_reg_soft (m) real(double), intent(in) :: m call msg_debug2 (D_ME_METHODS, "use_mass_reg_soft_rcl") call use_mass_reg_soft_rcl (m) end subroutine rclwrap_use_mass_reg_soft @ %def rclwrap_use_mass_reg_soft @ Sets the UV pole parameterization $\Delta_{UV}$. <>= public :: rclwrap_set_delta_uv <>= subroutine rclwrap_set_delta_uv (d) real(double), intent(in) :: d call msg_debug2 (D_ME_METHODS, "set_delta_uv_rcl") call set_delta_uv_rcl (d) end subroutine rclwrap_set_delta_uv @ %def rclwrap_set_delta_uv @ <>= public :: rclwrap_set_mu_uv <>= subroutine rclwrap_set_mu_uv (mu) real(double), intent(in) :: mu call msg_debug2 (D_ME_METHODS, "set_mu_uv_rcl") call set_mu_uv_rcl (mu) end subroutine rclwrap_set_mu_uv @ %def rclwrap_set_mu_uv @ Sets the IR pole parameterizations $\Delta_{IR}$ and $\Delta_2$. <>= public :: rclwrap_set_delta_ir <>= subroutine rclwrap_set_delta_ir (d, d2) real(double), intent(in) :: d, d2 call msg_debug2 (D_ME_METHODS, "set_delta_ir_rcl", & real(d, kind=default)) call msg_debug2 (D_ME_METHODS, "set_delta_ir_rcl", & real(d2, kind=default)) call set_delta_ir_rcl (d, d2) end subroutine rclwrap_set_delta_ir @ %def rclwrap_set_delta_ir @ <>= public :: rclwrap_set_mu_ir <>= subroutine rclwrap_set_mu_ir (mu) real(double), intent(in) :: mu call msg_debug2 (D_ME_METHODS, "set_mu_ir_rcl") call set_mu_ir_rcl (mu) end subroutine rclwrap_set_mu_ir @ %def rclwrap_set_mu_ir @ <>= public :: rclwrap_get_renormalization_scale <>= subroutine rclwrap_get_renormalization_scale (mu) real(double), intent(out) :: mu call msg_debug2 (D_ME_METHODS, "get_renormalization_scale_rcl") call get_renormalization_scale_rcl (mu) end subroutine rclwrap_get_renormalization_scale @ %def rclwrap_get_renormalization_scale @ <>= public :: rclwrap_get_flavor_scheme <>= subroutine rclwrap_get_flavor_scheme (nf) integer, intent(out) :: nf call msg_debug2 (D_ME_METHODS, "get_flavour_scheme_rcl") call get_flavour_scheme_rcl (nf) end subroutine rclwrap_get_flavor_scheme @ %def rclwrap_get_flavor_scheme @ <>= public :: rclwrap_use_alpha0_scheme <>= subroutine rclwrap_use_alpha0_scheme (al0) real(double), intent(in), optional :: al0 call msg_debug2 (D_ME_METHODS, "use_alpha0_scheme_rcl") call use_alpha0_scheme_rcl (al0) end subroutine rclwrap_use_alpha0_scheme @ %def rclwrap_use_alpha0_scheme @ <>= public :: rclwrap_use_alphaz_scheme <>= subroutine rclwrap_use_alphaz_scheme (alz) real(double), intent(in), optional :: alz call msg_debug2 (D_ME_METHODS, "use_alphaz_scheme_rcl") call use_alphaz_scheme_rcl (alz) end subroutine rclwrap_use_alphaz_scheme @ %def rclwrap_use_alphaz_scheme @ <>= public :: rclwrap_set_complex_mass_scheme <>= subroutine rclwrap_set_complex_mass_scheme () call msg_debug2 (D_ME_METHODS, "set_complex_mass_scheme_rcl") call set_complex_mass_scheme_rcl () end subroutine rclwrap_set_complex_mass_scheme @ %def rclwrap_set_complex_mass_scheme @ <>= public :: rclwrap_set_resonant_particle <>= subroutine rclwrap_set_resonant_particle (pdg_id) integer, intent(in) :: pdg_id call msg_debug2 (D_ME_METHODS, "set_resonant_particle_rcl") call set_resonant_particle_rcl (char(get_recola_particle_string (pdg_id))) end subroutine rclwrap_set_resonant_particle @ %def rclwrap_set_resonant_particle @ <>= public :: rclwrap_switch_on_resonant_self_energies <>= subroutine rclwrap_switch_on_resonant_self_energies () call msg_debug2 (D_ME_METHODS, "switchon_resonant_selfenergies_rcl") call switchon_resonant_selfenergies_rcl () end subroutine rclwrap_switch_on_resonant_self_energies @ %def rclwrap_switch_on_resonant_self_energies @ <>= public :: rclwrap_switch_off_resonant_self_energies <>= subroutine rclwrap_switch_off_resonant_self_energies () call msg_debug2 (D_ME_METHODS, "switchoff_resonant_selfenergies_rcl") call switchoff_resonant_selfenergies_rcl () end subroutine rclwrap_switch_off_resonant_self_energies @ %def rclwrap_switch_off_resonant_self_energies @ <>= public :: rclwrap_set_draw_level_branches <>= subroutine rclwrap_set_draw_level_branches (n) integer, intent(in) :: n call msg_debug2 (D_ME_METHODS, "set_draw_level_branches_rcl") call set_draw_level_branches_rcl (n) end subroutine rclwrap_set_draw_level_branches @ %def rclwrap_set_draw_level_branches @ <>= public :: rclwrap_set_print_level_amplitude <>= subroutine rclwrap_set_print_level_amplitude (n) integer, intent(in) :: n call msg_debug2 (D_ME_METHODS, "set_print_level_amplitude_rcl") call set_print_level_amplitude_rcl (n) end subroutine rclwrap_set_print_level_amplitude @ %def rclwrap_set_print_level_amplitude @ <>= public :: rclwrap_set_print_level_squared_amplitude <>= subroutine rclwrap_set_print_level_squared_amplitude (n) integer, intent(in) :: n call msg_debug2 (D_ME_METHODS, "set_print_level_squared_amplitude_rcl") call set_print_level_squared_amplitude_rcl (n) end subroutine rclwrap_set_print_level_squared_amplitude @ %def rclwrap_set_print_level_squared_amplitude @ <>= public :: rclwrap_set_print_level_correlations <>= subroutine rclwrap_set_print_level_correlations (n) integer, intent(in) :: n call msg_debug2 (D_ME_METHODS, "set_print_level_correlations_rcl") call set_print_level_correlations_rcl (n) end subroutine rclwrap_set_print_level_correlations @ %def rclwrap_set_print_level_correlations @ <>= public :: rclwrap_set_print_level_RAM <>= subroutine rclwrap_set_print_level_RAM (n) integer, intent(in) :: n call msg_debug2 (D_ME_METHODS, "set_print_level_RAM_rcl") call set_print_level_RAM_rcl (n) end subroutine rclwrap_set_print_level_RAM @ %def rclwrap_set_print_level_RAM @ <>= public :: rclwrap_scale_coupling3 <>= subroutine rclwrap_scale_coupling3 (pdg_id1, pdg_id2, pdg_id3, factor) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3 complex(double), intent(in) :: factor call msg_debug2 (D_ME_METHODS, "scale_coupling3_rcl") call scale_coupling3_rcl (factor, char(get_recola_particle_string (pdg_id1)), & char(get_recola_particle_string (pdg_id2)), char(get_recola_particle_string (pdg_id3))) end subroutine rclwrap_scale_coupling3 @ %def rclwrap_scale_coupling3 @ <>= public :: rclwrap_scale_coupling4 <>= subroutine rclwrap_scale_coupling4 (pdg_id1, pdg_id2, pdg_id3, pdg_id4, factor) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3, pdg_id4 complex(double), intent(in) :: factor call msg_debug2 (D_ME_METHODS, "scale_coupling4_rcl") call scale_coupling4_rcl (factor, char(get_recola_particle_string (pdg_id1)), & char(get_recola_particle_string (pdg_id2)), char(get_recola_particle_string (pdg_id3)), & char(get_recola_particle_string (pdg_id4))) end subroutine rclwrap_scale_coupling4 @ %def rclwrap_scale_coupling4 @ <>= public :: rclwrap_switch_off_coupling3 <>= subroutine rclwrap_switch_off_coupling3 (pdg_id1, pdg_id2, pdg_id3) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3 call msg_debug2 (D_ME_METHODS, "switchoff_coupling3_rcl") call switchoff_coupling3_rcl (char(get_recola_particle_string (pdg_id1)), & char(get_recola_particle_string (pdg_id2)), char(get_recola_particle_string (pdg_id3))) end subroutine rclwrap_switch_off_coupling3 @ %def rclwrap_switch_off_coupling3 @ <>= public :: rclwrap_switch_off_coupling4 <>= subroutine rclwrap_switch_off_coupling4 (pdg_id1, pdg_id2, pdg_id3, pdg_id4) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3, pdg_id4 call msg_debug2 (D_ME_METHODS, "switchoff_coupling4_rcl") call switchoff_coupling4_rcl & (char(get_recola_particle_string (pdg_id1)), & char(get_recola_particle_string (pdg_id2)), & char(get_recola_particle_string (pdg_id3)), & char(get_recola_particle_string (pdg_id4))) end subroutine rclwrap_switch_off_coupling4 @ %def rclwrap_switch_off_coupling4 @ <>= public :: rclwrap_set_ifail <>= subroutine rclwrap_set_ifail (i) integer, intent(in) :: i call msg_debug2 (D_ME_METHODS, "set_ifail_rcl") call set_ifail_rcl (i) end subroutine rclwrap_set_ifail @ %def rclwrap_set_ifail @ <>= public :: rclwrap_get_ifail <>= subroutine rclwrap_get_ifail (i) integer, intent(out) :: i call msg_debug2 (D_ME_METHODS, "get_ifail_rcl") call get_ifail_rcl (i) end subroutine rclwrap_get_ifail @ %def rclwrap_get_ifail @ <>= public :: rclwrap_set_output_file <>= subroutine rclwrap_set_output_file (filename) character(len=*), intent(in) :: filename call msg_debug2 (D_ME_METHODS, "set_output_file_rcl") call set_output_file_rcl (filename) end subroutine rclwrap_set_output_file @ %def rclwrap_set_output_file @ <>= public :: rclwrap_set_gs_power <>= subroutine rclwrap_set_gs_power (id, gs_array) integer, intent(in) :: id integer, dimension(:,:), intent(in) :: gs_array call msg_debug2 (D_ME_METHODS, "set_gs_power_rcl") call set_gs_power_rcl (id, gs_array) end subroutine rclwrap_set_gs_power @ %def rclwrap_set_gs_power @ <>= public :: rclwrap_select_gs_power_born_amp <>= subroutine rclwrap_select_gs_power_born_amp (id, gs_power) integer, intent(in) :: id, gs_power call msg_debug2 (D_ME_METHODS, "select_gs_power_BornAmpl_rcl") call select_gs_power_BornAmpl_rcl (id, gs_power) end subroutine rclwrap_select_gs_power_born_amp @ %def rclwrap_select_gs_power_born_amp @ <>= public :: rclwrap_unselect_gs_power_born_amp <>= subroutine rclwrap_unselect_gs_power_born_amp (id, gs_power) integer, intent(in) :: id, gs_power call msg_debug2 (D_ME_METHODS, "unselect_gs_power_BornAmpl_rcl") call unselect_gs_power_BornAmpl_rcl (id, gs_power) end subroutine rclwrap_unselect_gs_power_born_amp @ %def rclwrap_unselect_gs_power_born_amp @ <>= public :: rclwrap_select_gs_power_loop_amp <>= subroutine rclwrap_select_gs_power_loop_amp (id, gs_power) integer, intent(in) :: id, gs_power call msg_debug2 (D_ME_METHODS, "select_gs_power_LoopAmpl_rcl") call select_gs_power_LoopAmpl_rcl (id, gs_power) end subroutine rclwrap_select_gs_power_loop_amp @ %def rclwrap_select_gs_power_loop_amp @ <>= public :: rclwrap_unselect_gs_power_loop_amp <>= subroutine rclwrap_unselect_gs_power_loop_amp (id, gs_power) integer, intent(in) :: id, gs_power call msg_debug2 (D_ME_METHODS, "unselect_gs_power_LoopAmpl_rcl") call unselect_gs_power_LoopAmpl_rcl (id, gs_power) end subroutine rclwrap_unselect_gs_power_loop_amp @ %def rclwrap_unselect_gs_power_loop_amp @ <>= public :: rclwrap_select_all_gs_powers_born_amp <>= subroutine rclwrap_select_all_gs_powers_born_amp (id) integer, intent(in) :: id call msg_debug2 (D_ME_METHODS, "select_all_gs_powers_BornAmpl_rcl") call select_all_gs_powers_BornAmpl_rcl (id) end subroutine rclwrap_select_all_gs_powers_born_amp @ %def rclwrap_select_all_gs_powers_born_amp @ <>= public :: rclwrap_unselect_all_gs_powers_loop_amp <>= subroutine rclwrap_unselect_all_gs_powers_loop_amp (id) integer, intent(in) :: id call msg_debug2 (D_ME_METHODS, "unselect_all_gs_powers_BornAmpl_rcl") call unselect_all_gs_powers_BornAmpl_rcl (id) end subroutine rclwrap_unselect_all_gs_powers_loop_amp @ %def rclwrap_unselect_all_gs_powers_loop_amp @ <>= public :: rclwrap_select_all_gs_powers_loop_amp <>= subroutine rclwrap_select_all_gs_powers_loop_amp (id) integer, intent(in) :: id call msg_debug2 (D_ME_METHODS, "select_all_gs_powers_LoopAmpl_rcl") call select_all_gs_powers_LoopAmpl_rcl (id) end subroutine rclwrap_select_all_gs_powers_loop_amp @ %def rclwrap_select_all_gs_powers_loop_amp @ <>= public :: rclwrap_unselect_all_gs_powers_born_amp <>= subroutine rclwrap_unselect_all_gs_powers_born_amp (id) integer, intent(in) :: id call msg_debug2 (D_ME_METHODS, "unselect_all_gs_powers_LoopAmpl_rcl") call unselect_all_gs_powers_LoopAmpl_rcl (id) end subroutine rclwrap_unselect_all_gs_powers_born_amp @ %def rclwrap_unselect_all_gs_powers_born_amp @ <>= public :: rclwrap_set_resonant_squared_momentum <>= subroutine rclwrap_set_resonant_squared_momentum (id, i_res, p2) integer, intent(in) :: id, i_res real(double), intent(in) :: p2 call msg_debug2 (D_ME_METHODS, "set_resonant_squared_momentum_rcl") call set_resonant_squared_momentum_rcl (id, i_res, p2) end subroutine rclwrap_set_resonant_squared_momentum @ %def rclwrap_set_resonant_squared_momentum @ <>= public :: rclwrap_compute_running_alpha_s <>= subroutine rclwrap_compute_running_alpha_s (Q, nf, n_loops) real(double), intent(in) :: Q integer, intent(in) :: nf, n_loops call msg_debug2 (D_ME_METHODS, "compute_running_alphas_rcl") call compute_running_alphas_rcl (Q, nf, n_loops) end subroutine rclwrap_compute_running_alpha_s @ %def rclwrap_compute_running_alpha_s @ <>= public :: rclwrap_set_dynamic_settings <>= subroutine rclwrap_set_dynamic_settings () call msg_debug2 (D_ME_METHODS, "set_dynamic_settings_rcl") call set_dynamic_settings_rcl (1) end subroutine rclwrap_set_dynamic_settings @ %def rclwrap_set_dynamic_settings @ <>= public :: rclwrap_rescale_process <>= subroutine rclwrap_rescale_process (id, order, sqme) integer, intent(in) :: id character(len=*), intent(in) :: order real(double), dimension(0:1), intent(out), optional :: sqme call msg_debug2 (D_ME_METHODS, "rescale_process_rcl") call rescale_process_rcl (id, order, sqme) end subroutine rclwrap_rescale_process @ %def rclwrap_rescale_process @ <>= public :: rclwrap_get_polarized_squared_amplitude <>= subroutine rclwrap_get_polarized_squared_amplitude (id, & alphas_power, order, hel, sqme) integer, intent(in) :: id, alphas_power character(len=*), intent(in) :: order integer, dimension(:), intent(in) :: hel real(double), intent(out) :: sqme call msg_debug2 (D_ME_METHODS, "get_polarized_squared_amplitude_rcl") call get_polarized_squared_amplitude_rcl (id, alphas_power, & order, hel, sqme) end subroutine rclwrap_get_polarized_squared_amplitude @ %def rclwrap_get_polarized_squared_amplitude @ <>= public :: rclwrap_compute_color_correlation <>= subroutine rclwrap_compute_color_correlation (id, p, & i1, i2, sqme) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p integer, intent(in) :: i1, i2 real(double), intent(out), optional :: sqme call msg_debug2 (D_ME_METHODS, "compute_colour_correlation_rcl") call compute_colour_correlation_rcl (id, p, i1, i2, sqme) end subroutine rclwrap_compute_color_correlation @ %def rclwrap_compute_color_correlation @ <>= public :: rclwrap_compute_all_color_correlations <>= subroutine rclwrap_compute_all_color_correlations (id, p) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p call msg_debug2 (D_ME_METHODS, "compute_all_colour_correlations_rcl") call compute_all_colour_correlations_rcl (id, p) end subroutine rclwrap_compute_all_color_correlations @ %def rclwrap_compute_all_color_correlations @ <>= public :: rclwrap_rescale_color_correlation <>= subroutine rclwrap_rescale_color_correlation (id, i1, i2, sqme) integer, intent(in) :: id, i1, i2 real(double), intent(out), optional :: sqme call msg_debug2 (D_ME_METHODS, "rescale_colour_correlation_rcl") call rescale_colour_correlation_rcl (id, i1, i2, sqme) end subroutine rclwrap_rescale_color_correlation @ %def rclwrap_rescale_color_correlation @ <>= public :: rclwrap_rescale_all_color_correlations <>= subroutine rclwrap_rescale_all_color_correlations (id) integer, intent(in) :: id call msg_debug2 (D_ME_METHODS, "rescale_all_colour_correlations_rcl") call rescale_all_colour_correlations_rcl (id) end subroutine rclwrap_rescale_all_color_correlations @ %def rclwrap_rescale_all_color_correlations @ <>= public :: rclwrap_get_color_correlation <>= subroutine rclwrap_get_color_correlation (id, alphas_power, i1, i2, sqme) integer, intent(in) :: id, alphas_power, i1, i2 real(double), intent(out) :: sqme call msg_debug2 (D_ME_METHODS, "get_colour_correlation_rcl") call get_colour_correlation_rcl (id, alphas_power, i1, i2, sqme) end subroutine rclwrap_get_color_correlation @ %def rclwrap_get_color_correlation @ <>= public :: rclwrap_compute_spin_correlation <>= subroutine rclwrap_compute_spin_correlation (id, p, i_photon, pol, sqme) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p integer, intent(in) :: i_photon complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme call msg_debug2 (D_ME_METHODS, "compute_spin_correlation_rcl") call compute_spin_correlation_rcl (id, p, i_photon, pol, sqme) end subroutine rclwrap_compute_spin_correlation @ %def rclwrap_compute_spin_correlation @ <>= public :: rclwrap_rescale_spin_correlation <>= subroutine rclwrap_rescale_spin_correlation (id, i_photon, pol, sqme) integer, intent(in) :: id, i_photon complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme call msg_debug2 (D_ME_METHODS, "rescale_spin_correlation_rcl") call rescale_spin_correlation_rcl (id, i_photon, pol, sqme) end subroutine rclwrap_rescale_spin_correlation @ %def rclwrap_rescale_spin_correlation @ <>= public :: rclwrap_get_spin_correlation <>= subroutine rclwrap_get_spin_correlation (id, alphas_power, sqme) integer, intent(in) :: id, alphas_power real(double), intent(out) :: sqme call msg_debug2 (D_ME_METHODS, "get_spin_correlation_rcl") call get_spin_correlation_rcl (id, alphas_power, sqme) end subroutine rclwrap_get_spin_correlation @ %def rclwrap_get_spin_correlation @ <>= public :: rclwrap_compute_spin_color_correlation <>= subroutine rclwrap_compute_spin_color_correlation (id, p, & i_gluon, i_spectator, pol, sqme) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p integer, intent(in) :: i_gluon, i_spectator complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme call msg_debug2 (D_ME_METHODS, "compute_spin_colour_correlation_rcl") call compute_spin_colour_correlation_rcl (id, p, & i_gluon, i_spectator, pol, sqme) end subroutine rclwrap_compute_spin_color_correlation @ %def rclwrap_compute_spin_color_correlation @ <>= public :: rclwrap_rescale_spin_color_correlation <>= subroutine rclwrap_rescale_spin_color_correlation (id, i_gluon, & i_spectator, pol, sqme) integer, intent(in) :: id, i_gluon, i_spectator complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme call msg_debug2 (D_ME_METHODS, "rescale_spin_colour_correlation_rcl") call rescale_spin_colour_correlation_rcl (id, i_gluon, & i_spectator, pol, sqme) end subroutine rclwrap_rescale_spin_color_correlation @ %def rclwrap_rescale_spin_color_correlation @ <>= public :: rclwrap_get_spin_color_correlation <>= subroutine rclwrap_get_spin_color_correlation (id, alphas_power, & i_gluon, i_spectator, sqme) integer, intent(in) :: id, alphas_power, i_gluon, i_spectator real(double), intent(out) :: sqme call msg_debug2 (D_ME_METHODS, "get_spin_colour_correlation_rcl") call get_spin_colour_correlation_rcl (id, alphas_power, & i_gluon, i_spectator, sqme) end subroutine rclwrap_get_spin_color_correlation @ %def rclwrap_get_spin_color_correlation @ <>= public :: rclwrap_get_momenta <>= subroutine rclwrap_get_momenta (id, p) integer, intent(in) :: id real(double), dimension(:,:), intent(out) :: p call msg_debug2 (D_ME_METHODS, "get_momenta_rcl") call get_momenta_rcl (id, p) end subroutine rclwrap_get_momenta @ %def rclwrap_get_momenta @ The reset routine is essential. But note that it doesn't reset the Recola parameters, just the processes. For LOL, Recola's reset routine crashes the program if there was no process before. So, rather reset indirectly via the controller. <>= public :: rclwrap_reset_recola <>= subroutine rclwrap_reset_recola call msg_debug (D_ME_METHODS, "rclwrap_reset_recola") call rcl_controller%reset () end subroutine rclwrap_reset_recola @ %def rclwrap_reset_recola @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Recola dummy replacement module} <<[[recola_wrapper_dummy.f90]]>>= <> module recola_wrapper use kinds <> <> <> <> contains <> end module recola_wrapper @ %def recola_wrapper_dummy @ <>= public :: rclwrap_is_active <>= logical, parameter :: rclwrap_is_active = .false. @ %def rclwrap_is_active @ <>= public :: get_recola_particle_string <>= elemental function get_recola_particle_string (pdg) result (name) type(string_t) :: name integer, intent(in) :: pdg name = var_str ("?") end function get_recola_particle_string @ %def get_recola_paritcle_string @ <>= public :: rclwrap_get_new_recola_id <>= subroutine rclwrap_get_new_recola_id (id) integer, intent(out) :: id id = 0 end subroutine rclwrap_get_new_recola_id @ %def rclwrap_get_new_recola_id @ <>= public :: rclwrap_get_current_recola_id <>= function rclwrap_get_current_recola_id () result (n) integer :: n n = 0 end function rclwrap_get_current_recola_id @ %def rclwrap_get_current_recola_id @ <>= public :: rclwrap_request_generate_processes <>= subroutine rclwrap_request_generate_processes () end subroutine rclwrap_request_generate_processes @ %def rclwrap_request_generate_processes @ <>= public :: rclwrap_add_process <>= subroutine rclwrap_add_process (id, process_string, order) integer, intent(in) :: id type(string_t), intent(in) :: process_string, order end subroutine rclwrap_add_process @ %def rclwrap_add_process @ <>= public :: rclwrap_define_processes <>= subroutine rclwrap_define_processes () end subroutine rclwrap_define_processes @ %def rclwrap_define_processes @ <>= public :: rclwrap_generate_processes <>= subroutine rclwrap_generate_processes () end subroutine rclwrap_generate_processes @ %def rclwrap_generate_processes @ <>= public :: rclwrap_compute_process <>= subroutine rclwrap_compute_process (id, p, order, sqme) integer, intent(in) :: id real(double), intent(in), dimension(:,:) :: p character(len=*), intent(in) :: order real(double), intent(out), dimension(0:1), optional :: sqme end subroutine rclwrap_compute_process @ %def rclwrap_compute_process @ <>= public :: rclwrap_get_amplitude <>= subroutine rclwrap_get_amplitude (id, g_power, order, col, hel, amp) integer, intent(in) :: id, g_power character(len=*), intent(in) :: order integer, dimension(:), intent(in) :: col, hel complex(double), intent(out) :: amp end subroutine rclwrap_get_amplitude @ %def rclwrap_get_amplitude @ <>= public :: rclwrap_get_squared_amplitude <>= subroutine rclwrap_get_squared_amplitude (id, alphas_power, order, sqme) integer, intent(in) :: id, alphas_power character(len=*), intent(in) :: order real(double), intent(out) :: sqme end subroutine rclwrap_get_squared_amplitude @ %def rclwrap_get_squared_amplitude @ <>= public :: rclwrap_set_pole_mass <>= subroutine rclwrap_set_pole_mass (pdg_id, mass, width) integer, intent(in) :: pdg_id real(double), intent(in) :: mass, width end subroutine rclwrap_set_pole_mass @ %def rclwrap_set_pole_mass @ <>= public :: rclwrap_set_onshell_mass <>= subroutine rclwrap_set_onshell_mass (pdg_id, mass, width) integer, intent(in) :: pdg_id real(double), intent(in) :: mass, width end subroutine rclwrap_set_onshell_mass @ %def rclwrap_set_onshell_mass @ <>= public :: rclwrap_use_gfermi_scheme <>= subroutine rclwrap_use_gfermi_scheme (gf) real(double), intent(in), optional :: gf end subroutine rclwrap_use_gfermi_scheme @ %def rclwrap_use_gfermi_scheme @ <>= public :: rclwrap_set_light_fermions <>= subroutine rclwrap_set_light_fermions (m) real(double), intent(in) :: m end subroutine rclwrap_set_light_fermions @ %def rclwrap_set_light_fermions @ <>= public :: rclwrap_set_light_fermion <>= subroutine rclwrap_set_light_fermion (pdg_id) integer, intent(in) :: pdg_id end subroutine rclwrap_set_light_fermion @ %def rclwrap_set_light_fermion @ <>= public :: rclwrap_unset_light_fermion <>= subroutine rclwrap_unset_light_fermion (pdg_id) integer, intent(in) :: pdg_id end subroutine rclwrap_unset_light_fermion @ %def rclwrap_unset_light_fermion @ <>= public :: rclwrap_set_onshell_scheme <>= subroutine rclwrap_set_onshell_scheme end subroutine rclwrap_set_onshell_scheme @ %def rclwrap_set_onshell_scheme @ <>= public :: rclwrap_set_alpha_s <>= subroutine rclwrap_set_alpha_s (alpha_s, mu, nf) real(double), intent(in) :: alpha_s, mu integer, intent(in) :: nf end subroutine rclwrap_set_alpha_s @ %def rclwrap_set_alpha_s @ <>= public :: rclwrap_get_alpha_s <>= function rclwrap_get_alpha_s () result (alpha_s) real(double) :: alpha_s end function rclwrap_get_alpha_s @ %def rclwrap_get_alpha_s @ <>= public :: rclwrap_get_helicity_configurations <>= subroutine rclwrap_get_helicity_configurations (id, hel) integer, intent(in) :: id integer, intent(inout), dimension(:,:), allocatable :: hel end subroutine rclwrap_get_helicity_configurations @ %def rclwrap_get_helicity_configurations @ <>= public :: rclwrap_get_color_configurations <>= subroutine rclwrap_get_color_configurations (id, col) integer, intent(in) :: id integer, intent(out), dimension(:,:), allocatable :: col end subroutine rclwrap_get_color_configurations @ %def rclwrap_get_color_configurations @ <>= public :: rclwrap_use_dim_reg_soft <>= subroutine rclwrap_use_dim_reg_soft () end subroutine rclwrap_use_dim_reg_soft @ %def rclwrap_use_dim_reg_soft @ <>= public :: rclwrap_use_mass_reg_soft <>= subroutine rclwrap_use_mass_reg_soft (m) real(double), intent(in) :: m end subroutine rclwrap_use_mass_reg_soft @ %def rclwrap_use_mass_reg_soft @ <>= public :: rclwrap_set_delta_uv <>= subroutine rclwrap_set_delta_uv (d) real(double), intent(in) :: d end subroutine rclwrap_set_delta_uv @ %def rclwrap_set_delta_uv @ <>= public :: rclwrap_set_mu_uv <>= subroutine rclwrap_set_mu_uv (mu) real(double), intent(in) :: mu end subroutine rclwrap_set_mu_uv @ %def rclwrap_set_mu_uv @ <>= public :: rclwrap_set_delta_ir <>= subroutine rclwrap_set_delta_ir (d, d2) real(double), intent(in) :: d, d2 end subroutine rclwrap_set_delta_ir @ %def rclwrap_set_delta_ir @ <>= public :: rclwrap_set_mu_ir <>= subroutine rclwrap_set_mu_ir (mu) real(double), intent(in) :: mu end subroutine rclwrap_set_mu_ir @ %def rclwrap_set_mu_ir @ <>= public :: rclwrap_get_renormalization_scale <>= subroutine rclwrap_get_renormalization_scale (mu) real(double), intent(out) :: mu end subroutine rclwrap_get_renormalization_scale @ %def rclwrap_get_renormalization_scale @ <>= public :: rclwrap_get_flavor_scheme <>= subroutine rclwrap_get_flavor_scheme (nf) integer, intent(out) :: nf end subroutine rclwrap_get_flavor_scheme @ %def rclwrap_get_flavor_scheme @ <>= public :: rclwrap_use_alpha0_scheme <>= subroutine rclwrap_use_alpha0_scheme (al0) real(double), intent(in), optional :: al0 end subroutine rclwrap_use_alpha0_scheme @ %def rclwrap_use_alpha0_scheme @ <>= public :: rclwrap_use_alphaz_scheme <>= subroutine rclwrap_use_alphaz_scheme (alz) real(double), intent(in), optional :: alz end subroutine rclwrap_use_alphaz_scheme @ %def rclwrap_use_alphaz_scheme @ <>= public :: rclwrap_set_complex_mass_scheme <>= subroutine rclwrap_set_complex_mass_scheme () end subroutine rclwrap_set_complex_mass_scheme @ %def rclwrap_set_complex_mass_scheme @ <>= public :: rclwrap_set_resonant_particle <>= subroutine rclwrap_set_resonant_particle (pdg_id) integer, intent(in) :: pdg_id end subroutine rclwrap_set_resonant_particle @ %def rclwrap_set_resonant_particle @ <>= public :: rclwrap_switch_on_resonant_self_energies <>= subroutine rclwrap_switch_on_resonant_self_energies () end subroutine rclwrap_switch_on_resonant_self_energies @ %def rclwrap_switch_on_resonant_self_energies @ <>= public :: rclwrap_switch_off_resonant_self_energies <>= subroutine rclwrap_switch_off_resonant_self_energies () end subroutine rclwrap_switch_off_resonant_self_energies @ %def rclwrap_switch_off_resonant_self_energies @ <>= public :: rclwrap_set_draw_level_branches <>= subroutine rclwrap_set_draw_level_branches (n) integer, intent(in) :: n end subroutine rclwrap_set_draw_level_branches @ %def rclwrap_set_draw_level_branches @ <>= public :: rclwrap_set_print_level_amplitude <>= subroutine rclwrap_set_print_level_amplitude (n) integer, intent(in) :: n end subroutine rclwrap_set_print_level_amplitude @ %def rclwrap_set_print_level_amplitude @ <>= public :: rclwrap_set_print_level_squared_amplitude <>= subroutine rclwrap_set_print_level_squared_amplitude (n) integer, intent(in) :: n end subroutine rclwrap_set_print_level_squared_amplitude @ %def rclwrap_set_print_level_squared_amplitude @ <>= public :: rclwrap_set_print_level_correlations <>= subroutine rclwrap_set_print_level_correlations (n) integer, intent(in) :: n end subroutine rclwrap_set_print_level_correlations @ %def rclwrap_set_print_level_correlations @ <>= public :: rclwrap_set_print_level_RAM <>= subroutine rclwrap_set_print_level_RAM (n) integer, intent(in) :: n end subroutine rclwrap_set_print_level_RAM @ %def rclwrap_set_print_level_RAM @ <>= public :: rclwrap_scale_coupling3 <>= subroutine rclwrap_scale_coupling3 (pdg_id1, pdg_id2, pdg_id3, factor) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3 complex(double), intent(in) :: factor end subroutine rclwrap_scale_coupling3 @ %def rclwrap_scale_coupling3 @ <>= public :: rclwrap_scale_coupling4 <>= subroutine rclwrap_scale_coupling4 (pdg_id1, pdg_id2, pdg_id3, pdg_id4, factor) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3, pdg_id4 complex(double), intent(in) :: factor end subroutine rclwrap_scale_coupling4 @ %def rclwrap_scale_coupling4 @ <>= public :: rclwrap_switch_off_coupling3 <>= subroutine rclwrap_switch_off_coupling3 (pdg_id1, pdg_id2, pdg_id3) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3 end subroutine rclwrap_switch_off_coupling3 @ %def rclwrap_switch_off_coupling3 @ <>= public :: rclwrap_switch_off_coupling4 <>= subroutine rclwrap_switch_off_coupling4 (pdg_id1, pdg_id2, pdg_id3, pdg_id4) integer, intent(in) :: pdg_id1, pdg_id2, pdg_id3, pdg_id4 end subroutine rclwrap_switch_off_coupling4 @ %def rclwrap_switch_off_coupling4 @ <>= public :: rclwrap_set_ifail <>= subroutine rclwrap_set_ifail (i) integer, intent(in) :: i end subroutine rclwrap_set_ifail @ %def rclwrap_set_ifail @ <>= public :: rclwrap_get_ifail <>= subroutine rclwrap_get_ifail (i) integer, intent(out) :: i end subroutine rclwrap_get_ifail @ %def rclwrap_get_ifail @ <>= public :: rclwrap_set_output_file <>= subroutine rclwrap_set_output_file (filename) character(len=*), intent(in) :: filename end subroutine rclwrap_set_output_file @ %def rclwrap_set_output_file @ <>= public :: rclwrap_set_gs_power <>= subroutine rclwrap_set_gs_power (id, gs_array) integer, intent(in) :: id integer, dimension(:,:), intent(in) :: gs_array end subroutine rclwrap_set_gs_power @ %def rclwrap_set_gs_power @ <>= public :: rclwrap_select_gs_power_born_amp <>= subroutine rclwrap_select_gs_power_born_amp (id, gs_power) integer, intent(in) :: id, gs_power end subroutine rclwrap_select_gs_power_born_amp @ %def rclwrap_select_gs_power_born_amp @ <>= public :: rclwrap_unselect_gs_power_born_amp <>= subroutine rclwrap_unselect_gs_power_born_amp (id, gs_power) integer, intent(in) :: id, gs_power end subroutine rclwrap_unselect_gs_power_born_amp @ %def rclwrap_unselect_gs_power_born_amp @ <>= public :: rclwrap_select_gs_power_loop_amp <>= subroutine rclwrap_select_gs_power_loop_amp (id, gs_power) integer, intent(in) :: id, gs_power end subroutine rclwrap_select_gs_power_loop_amp @ %def rclwrap_select_gs_power_loop_amp @ <>= public :: rclwrap_unselect_gs_power_loop_amp <>= subroutine rclwrap_unselect_gs_power_loop_amp (id, gs_power) integer, intent(in) :: id, gs_power end subroutine rclwrap_unselect_gs_power_loop_amp @ %def rclwrap_unselect_gs_power_loop_amp @ <>= public :: rclwrap_select_all_gs_powers_born_amp <>= subroutine rclwrap_select_all_gs_powers_born_amp (id) integer, intent(in) :: id end subroutine rclwrap_select_all_gs_powers_born_amp @ %def rclwrap_select_all_gs_powers_born_amp @ <>= public :: rclwrap_unselect_all_gs_powers_loop_amp <>= subroutine rclwrap_unselect_all_gs_powers_loop_amp (id) integer, intent(in) :: id end subroutine rclwrap_unselect_all_gs_powers_loop_amp @ %def rclwrap_unselect_all_gs_powers_loop_amp @ <>= public :: rclwrap_select_all_gs_powers_loop_amp <>= subroutine rclwrap_select_all_gs_powers_loop_amp (id) integer, intent(in) :: id end subroutine rclwrap_select_all_gs_powers_loop_amp @ %def rclwrap_select_all_gs_powers_loop_amp @ <>= public :: rclwrap_unselect_all_gs_powers_born_amp <>= subroutine rclwrap_unselect_all_gs_powers_born_amp (id) integer, intent(in) :: id end subroutine rclwrap_unselect_all_gs_powers_born_amp @ %def rclwrap_unselect_all_gs_powers_born_amp @ <>= public :: rclwrap_set_resonant_squared_momentum <>= subroutine rclwrap_set_resonant_squared_momentum (id, i_res, p2) integer, intent(in) :: id, i_res real(double), intent(in) :: p2 end subroutine rclwrap_set_resonant_squared_momentum @ %def rclwrap_set_resonant_squared_momentum @ <>= public :: rclwrap_compute_running_alpha_s <>= subroutine rclwrap_compute_running_alpha_s (Q, nf, n_loops) real(double), intent(in) :: Q integer, intent(in) :: nf, n_loops end subroutine rclwrap_compute_running_alpha_s @ %def rclwrap_compute_running_alpha_s @ <>= public :: rclwrap_set_dynamic_settings <>= subroutine rclwrap_set_dynamic_settings () end subroutine rclwrap_set_dynamic_settings @ %def rclwrap_set_dynamic_settings @ <>= public :: rclwrap_rescale_process <>= subroutine rclwrap_rescale_process (id, order, sqme) integer, intent(in) :: id character(len=*), intent(in) :: order real(double), dimension(0:1), intent(out), optional :: sqme end subroutine rclwrap_rescale_process @ %def rclwrap_rescale_process @ <>= public :: rclwrap_get_polarized_squared_amplitude <>= subroutine rclwrap_get_polarized_squared_amplitude (id, & alphas_power, order, hel, sqme) integer, intent(in) :: id, alphas_power character(len=*), intent(in) :: order integer, dimension(:), intent(in) :: hel real(double), intent(out) :: sqme end subroutine rclwrap_get_polarized_squared_amplitude @ %def rclwrap_get_polarized_squared_amplitude @ <>= public :: rclwrap_compute_color_correlation <>= subroutine rclwrap_compute_color_correlation (id, p, & i1, i2, sqme) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p integer, intent(in) :: i1, i2 real(double), intent(out), optional :: sqme end subroutine rclwrap_compute_color_correlation @ %def rclwrap_compute_color_correlation @ <>= public :: rclwrap_compute_all_color_correlations <>= subroutine rclwrap_compute_all_color_correlations (id, p) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p end subroutine rclwrap_compute_all_color_correlations @ %def rclwrap_compute_all_color_correlations @ <>= public :: rclwrap_rescale_color_correlation <>= subroutine rclwrap_rescale_color_correlation (id, i1, i2, sqme) integer, intent(in) :: id, i1, i2 real(double), intent(out), optional :: sqme end subroutine rclwrap_rescale_color_correlation @ %def rclwrap_rescale_color_correlation @ <>= public :: rclwrap_rescale_all_color_correlations <>= subroutine rclwrap_rescale_all_color_correlations (id) integer, intent(in) :: id end subroutine rclwrap_rescale_all_color_correlations @ %def rclwrap_rescale_all_color_correlations @ <>= public :: rclwrap_get_color_correlation <>= subroutine rclwrap_get_color_correlation (id, alphas_power, i1, i2, sqme) integer, intent(in) :: id, alphas_power, i1, i2 real(double), intent(out) :: sqme end subroutine rclwrap_get_color_correlation @ %def rclwrap_get_color_correlation @ <>= public :: rclwrap_compute_spin_correlation <>= subroutine rclwrap_compute_spin_correlation (id, p, i_photon, pol, sqme) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p integer, intent(in) :: i_photon complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme end subroutine rclwrap_compute_spin_correlation @ %def rclwrap_compute_spin_correlation @ <>= public :: rclwrap_rescale_spin_correlation <>= subroutine rclwrap_rescale_spin_correlation (id, i_photon, pol, sqme) integer, intent(in) :: id, i_photon complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme end subroutine rclwrap_rescale_spin_correlation @ %def rclwrap_rescale_spin_correlation @ <>= public :: rclwrap_get_spin_correlation <>= subroutine rclwrap_get_spin_correlation (id, alphas_power, sqme) integer, intent(in) :: id, alphas_power real(double), intent(out) :: sqme end subroutine rclwrap_get_spin_correlation @ %def rclwrap_get_spin_correlation @ <>= public :: rclwrap_compute_spin_color_correlation <>= subroutine rclwrap_compute_spin_color_correlation (id, p, & i_gluon, i_spectator, pol, sqme) integer, intent(in) :: id real(double), dimension(:,:), intent(in) :: p integer, intent(in) :: i_gluon, i_spectator complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme end subroutine rclwrap_compute_spin_color_correlation @ %def rclwrap_compute_spin_color_correlation @ <>= public :: rclwrap_rescale_spin_color_correlation <>= subroutine rclwrap_rescale_spin_color_correlation (id, i_gluon, & i_spectator, pol, sqme) integer, intent(in) :: id, i_gluon, i_spectator complex(double), dimension(:), intent(in) :: pol real(double), intent(out), optional :: sqme end subroutine rclwrap_rescale_spin_color_correlation @ %def rclwrap_rescale_spin_color_correlation @ <>= public :: rclwrap_get_spin_color_correlation <>= subroutine rclwrap_get_spin_color_correlation (id, alphas_power, & i_gluon, i_spectator, sqme) integer, intent(in) :: id, alphas_power, i_gluon, i_spectator real(double), intent(out) :: sqme end subroutine rclwrap_get_spin_color_correlation @ %def rclwrap_get_spin_color_correlation @ <>= public :: rclwrap_get_momenta <>= subroutine rclwrap_get_momenta (id, p) integer, intent(in) :: id real(double), dimension(:,:), intent(out) :: p end subroutine rclwrap_get_momenta @ %def rclwrap_get_momenta @ <>= public :: rclwrap_reset_recola <>= subroutine rclwrap_reset_recola end subroutine rclwrap_reset_recola @ %def rclwrap_reset_recola @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Recola Core} The recola core object and auxiliary types and objects. <<[[prc_recola.f90]]>>= <> module prc_recola use recola_wrapper !NODEP! use kinds use constants, only: pi, zero <> use string_utils, only: str use system_defs, only: TAB use diagnostics use io_units use lorentz use physics_defs use variables, only: var_list_t use os_interface, only: os_data_t use sm_qcd, only: qcd_t use model_data, only: model_data_t use prc_core, only: prc_core_state_t use prc_core_def, only: prc_core_driver_t, prc_core_def_t use prc_external use process_libraries, only: process_library_t <> <> <> <> <> contains <> end module prc_recola @ %def prc_recola @ \subsection{Sanity check} Checks the [[rclwrap_is_active]] flag and aborts the program if the dummy is used. <>= public :: abort_if_recola_not_active <>= subroutine abort_if_recola_not_active () if (.not. rclwrap_is_active) call msg_fatal ("You want to use Recola, ", & [var_str("but either the compiler with which Whizard has been build "), & var_str("is not supported by it, or you have not linked Recola "), & var_str("correctly to Whizard. Either reconfigure Whizard with a path to "), & var_str("a valid Recola installation (for details consult the manual), "), & var_str("or choose a different matrix-element method.")]) end subroutine abort_if_recola_not_active @ %def abort_if_recola_not_active @ \subsection{Process definition} When defining a RECOLA process, we store the process-specific flags and parameters. Correction types are either QCD, QED, or full SM. <>= integer, parameter :: RECOLA_UNDEFINED = 0, RECOLA_QCD = 1, & RECOLA_QED = 2, RECOLA_FULL = 3 @ %def RECOLA_QCD RECOLA_QED RECOLA_FULL @ <>= public :: recola_def_t <>= type, extends (prc_external_def_t) :: recola_def_t type(string_t) :: suffix type(string_t) :: order integer :: alpha_power = 0 integer :: alphas_power = 0 integer :: corr = RECOLA_UNDEFINED contains <> end type recola_def_t @ %def recola_def_t @ <>= procedure, nopass :: type_string => recola_def_type_string <>= function recola_def_type_string () result (string) type(string_t) :: string string = "recola" end function recola_def_type_string @ %def recola_def_type_string @ Not implemented yet. <>= procedure :: write => recola_def_write <>= subroutine recola_def_write (object, unit) class(recola_def_t), intent(in) :: object integer, intent(in) :: unit end subroutine recola_def_write @ %def recola_def_write @ <>= procedure :: read => recola_def_read <>= subroutine recola_def_read (object, unit) class(recola_def_t), intent(out) :: object integer, intent(in) :: unit end subroutine recola_def_read @ %def recola_def_read @ The initializer has the responsibility to store all process- and method-specific parameters, such that they can be used later by the writer and by the driver for this process. Also, it allocates the writer. For RECOLA, the writer (i) creates full-fledged \oMega\ matrix element -code which we need for the interface. (TODO: I guess that we don't -need the matrix element, just the management part. Maybe modify the -\oMega\ call such that no matrix-element code is written.) (ii) registers +code which we need for the interface. (ii) registers the process definition with the RECOLA library which has been linked. The latter task does not involve external code. Note that all management stuff is taken care of by the base type(s) methods. Here, we introduce only RECOLA-specific procedures, in addition. The NLO flag is true only for virtual matrix elements. <>= procedure :: init => recola_def_init <>= subroutine recola_def_init (object, basename, model_name, & prt_in, prt_out, nlo_type, alpha_power, alphas_power, & correction_type) class(recola_def_t), intent(inout) :: object type(string_t), intent(in) :: basename, model_name type(string_t), dimension(:), intent(in) :: prt_in, prt_out integer, intent(in) :: nlo_type integer, intent(in) :: alpha_power integer, intent(in) :: alphas_power type(string_t), intent(in) :: correction_type call msg_debug (D_ME_METHODS, "recola_def_init: " & // char (basename) // ", nlo_type", nlo_type) object%basename = basename object%alpha_power = alpha_power object%alphas_power = alphas_power select case (char (correction_type)) case ("QCD") object%corr = RECOLA_QCD case ("QED") object%corr = RECOLA_QED case ("Full") object%corr = RECOLA_FULL end select allocate (recola_writer_t :: object%writer) select case (nlo_type) case (BORN) object%suffix = '_BORN' object%order = "LO" case (NLO_REAL) object%suffix = '_REAL' object%order = "LO" if (object%corr == RECOLA_QCD) object%alphas_power = alphas_power + 1 if (object%corr == RECOLA_QED) object%alpha_power = alpha_power + 1 case (NLO_VIRTUAL) object%suffix = '_LOOP' object%order = "NLO" case (NLO_SUBTRACTION) object%suffix = '_SUB' object%order = "LO" case (NLO_MISMATCH) object%suffix = '_MISMATCH' object%order = "LO" case (NLO_DGLAP) object%suffix = '_DGLAP' object%order = "LO" end select select type (writer => object%writer) class is (recola_writer_t) call writer%init (model_name, prt_in, prt_out) call writer%set_id (basename // object%suffix) call writer%set_order (object%order) call writer%set_coupling_powers (object%alpha_power, object%alphas_power) end select end subroutine recola_def_init @ %def recola_def_init @ \subsection{Writer object} The RECOLA writer takes the additional resposibility of transferring process information to RECOLA. <>= type, extends (prc_external_writer_t) :: recola_writer_t private type(string_t) :: id type(string_t) :: order integer :: alpha_power = 0 integer :: alphas_power = 0 contains <> end type recola_writer_t @ %def recola_writer_t @ <>= procedure, nopass :: type_name => recola_writer_type_name <>= function recola_writer_type_name () result (string) type(string_t) :: string string = "recola" end function recola_writer_type_name @ %def recola_writer_type_name @ Set the process ID string as used by WHIZARD. <>= procedure :: set_id => recola_writer_set_id <>= subroutine recola_writer_set_id (writer, id) class(recola_writer_t), intent(inout) :: writer type(string_t), intent(in) :: id call msg_debug2 (D_ME_METHODS, "Recola writer: id = " // char (id)) writer%id = id end subroutine recola_writer_set_id @ %def recola_writer_set_id @ Set the NLO flag. <>= procedure :: set_order => recola_writer_set_order <>= subroutine recola_writer_set_order (writer, order) class(recola_writer_t), intent(inout) :: writer type(string_t), intent(in) :: order call msg_debug2 (D_ME_METHODS, "Recola writer: order = " // char (order)) writer%order = order end subroutine recola_writer_set_order @ %def recola_writer_set_order @ Set coupling powers. <>= procedure :: set_coupling_powers => recola_writer_set_coupling_powers <>= subroutine recola_writer_set_coupling_powers (writer, alpha_power, alphas_power) class(recola_writer_t), intent(inout) :: writer integer, intent(in) :: alpha_power integer, intent(in) :: alphas_power call msg_debug2 (D_ME_METHODS, "Recola writer: alphas_power", alphas_power) call msg_debug2 (D_ME_METHODS, "Recola writer: alpha_power", alpha_power) writer%alpha_power = alpha_power writer%alphas_power = alphas_power end subroutine recola_writer_set_coupling_powers @ %def recola_writer_set_coupling_powers @ The Makefile code contains all of the code that the [[prc_external]] base method generates, plus an extra clause that extracts a shorthand listing of all flavor combinations for the current process. This list is required by [[make source]], so it can be read and used for declaring the RECOLA processes. There is one glitch here: we use the component-specific source file but write a flavor list for the process, without component extension. That is, we must not have more than one component at this stage. NB: We might actually extend \oMega\ to produce this shorthand listing. <>= procedure :: write_makefile_code => recola_writer_write_makefile_code <>= function flv_file_name (id) type(string_t), intent(in) :: id type(string_t) :: flv_file_name flv_file_name = id // ".flv.dat" end function flv_file_name subroutine recola_writer_write_makefile_code & (writer, unit, id, os_data, verbose, testflag) class(recola_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 type(string_t) :: src_file type(string_t) :: flv_file call writer%base_write_makefile_code (unit, id, os_data, verbose, testflag) src_file = trim (char(id)) // ".f90" flv_file = flv_file_name (writer%id) write (unit, *) write (unit, "(5A)") "# Flavor state listing for RECOLA process generation" write (unit, "(5A)") char (flv_file), ": ", char (src_file) if (verbose) then write (unit, "(5A)", advance="no") TAB else write (unit, "(5A)") TAB, '@echo " MAKE ', char (flv_file), '"' write (unit, "(5A)", advance="no") TAB, "@" end if write (unit, "(5A)") & "grep 'data table_flavor_states' $< ", & "| sed -e 's/.*\/\(.*\)\/.*/\1/' -e 's/,//g' > $@" write (unit, "(5A)") "SOURCES += ", char (flv_file) write (unit, "(5A)") "CLEAN_SOURCES += ", char (flv_file) end subroutine recola_writer_write_makefile_code @ %def recola_writer_write_makefile_code @ To communicate the process definition to RECOLA, we must know the following: the process definition, expanded in terms of flavor states, and the process order (LO/NLO). We will ask for a new numeric ID, create a process string using RECOLA conventions, and define the process. The [[request_generate_processes]] enables the RECOLA internal process compiler, which can be called only after all processes have been defined. <>= procedure :: register_processes => prc_recola_register_processes <>= subroutine prc_recola_register_processes (writer, recola_ids) class(recola_writer_t), intent(in) :: writer integer :: recola_id integer :: i_flv integer :: n_tot integer :: unit, iostat integer, dimension (:), intent(inout) :: recola_ids integer, dimension(:), allocatable :: pdg type(string_t), dimension(:), allocatable :: particle_names type(string_t) :: process_string integer :: i_part !!! TODO (cw-2016-08-08): Include helicities call msg_message ("Recola: registering processes for '" // char (writer%id) // "'") i_flv = 0 n_tot = writer%n_in + writer%n_out allocate (pdg (n_tot)) allocate (particle_names (n_tot)) call open_flv_list (writer%id, unit) call rclwrap_request_generate_processes () SCAN_FLV_LIST: do read (unit, *, iostat = iostat) pdg if (iostat < 0) then exit SCAN_FLV_LIST else if (iostat > 0) then call err_flv_list (writer%id) end if i_flv = i_flv + 1 call rclwrap_get_new_recola_id (recola_id) recola_ids(i_flv) = recola_id particle_names(:) = get_recola_particle_string (pdg) process_string = var_str ("") do i_part = 1, n_tot process_string = process_string // & particle_names (i_part) // var_str (" ") if (i_part == writer%n_in) then process_string = process_string // var_str ("-> ") end if end do call msg_message ("Recola: " & // "process #" // char (str (recola_id)) & // ": " // char (process_string) & // "(" // char (writer%order) // ")") call rclwrap_add_process (recola_id, process_string, writer%order) call rclwrap_define_processes () end do SCAN_FLV_LIST call close_flv_list (unit) call msg_debug (D_ME_METHODS, "RECOLA: processes for '" & // char (writer%id) // "' registered") end subroutine prc_recola_register_processes @ %def prc_recola_register_processes @ Manage the list of flavor combinations for the current process. We rely on this being created along with the \oMega\ call. <>= subroutine open_flv_list (id, unit) type(string_t), intent(in) :: id integer, intent(out) :: unit type(string_t) :: flv_file integer :: iostat flv_file = flv_file_name (id) open (file = char (flv_file), newunit = unit, & status = "old", action = "read", & iostat = iostat) if (iostat /= 0) then call msg_fatal ("Recola: attempt to open flavor-list file '" & // char (flv_file) // "' failed") end if end subroutine open_flv_list subroutine err_flv_list (id) type(string_t), intent(in) :: id type(string_t) :: flv_file flv_file = flv_file_name (id) call msg_fatal ("Recola: error while reading from flavor-list file '" & // char (flv_file) // "'") end subroutine err_flv_list subroutine close_flv_list (unit) integer, intent(in) :: unit close (unit) end subroutine close_flv_list @ %def open_flv_list @ %def err_flv_list @ %def close_flv_list @ \subsection{Driver object} A core driver is required by design. However, we are not going to load any external dynamical libraries, so this is a dummy. <>= type, extends (prc_external_driver_t) :: recola_driver_t contains <> end type recola_driver_t @ %def recola_driver_t @ <>= procedure :: allocate_driver => recola_def_allocate_driver <>= subroutine recola_def_allocate_driver (object, driver, basename) class(recola_def_t), intent(in) :: object class(prc_core_driver_t), intent(out), allocatable :: driver type(string_t), intent(in) :: basename call msg_debug2 (D_ME_METHODS, "recola_def_allocate_driver") allocate (recola_driver_t :: driver) end subroutine recola_def_allocate_driver @ %def recola_def_allocate_driver @ <>= procedure, nopass :: type_name => recola_driver_type_name <>= function recola_driver_type_name () result (type) type(string_t) :: type type = "Recola" end function recola_driver_type_name @ %def recola_driver_type_name @ \subsection{Process object} We create [[prc_recola_t]] as an extension of the [[prc_external_t]], which in turn inherits from [[prc_core_t]]. This way, we can use a lot of the existing interfaces in the actual code. However, we have to stick to the rules and implement the deferred type-bound procedures of [[prc_core_t]]. <>= public :: prc_recola_t <>= type, extends (prc_external_t) :: prc_recola_t integer, dimension(:), allocatable :: recola_ids integer, dimension(:,:), allocatable :: color_state integer :: n_f = 0 logical :: helicity_and_color_arrays_are_replaced = .false. contains <> end type prc_recola_t @ %def prc_recola_t @ <>= procedure :: write_name => prc_recola_write_name <>= subroutine prc_recola_write_name (object, unit) class(prc_recola_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u,"(1x,A)") "Core: Recola" end subroutine prc_recola_write_name @ %def prc_recola_write_name @ <>= procedure :: has_matrix_element => prc_recola_has_matrix_element <>= function prc_recola_has_matrix_element (object) result (flag) logical :: flag class(prc_recola_t), intent(in) :: object flag = .true. end function prc_recola_has_matrix_element @ %def prc_recola_has_matrix_element @ Not implemented yet. <>= procedure :: write => prc_recola_write <>= subroutine prc_recola_write (object, unit) class(prc_recola_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine prc_recola_write @ %def prc_recola_write @ \subsection{Accompanying state object} This must be implemented, but is unused. <>= type, extends (prc_external_state_t) :: recola_state_t contains <> end type recola_state_t @ %def recola_state_t @ <>= procedure :: write => recola_state_write <>= subroutine recola_state_write (object, unit) class(recola_state_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine recola_state_write @ %def recola_state_write @ <>= procedure :: allocate_workspace => prc_recola_allocate_workspace <>= subroutine prc_recola_allocate_workspace (object, core_state) class(prc_recola_t), intent(in) :: object class(prc_core_state_t), intent(inout), allocatable :: core_state allocate (recola_state_t :: core_state) end subroutine prc_recola_allocate_workspace @ %def prc_recola_allocate_workspace @ \subsection{Recola process data} This information is stored in the associated [[def]] object. To obtain it, we need a type cast. <>= procedure :: get_alpha_power => prc_recola_get_alpha_power procedure :: get_alphas_power => prc_recola_get_alphas_power <>= function prc_recola_get_alpha_power (object) result (p) class(prc_recola_t), intent(in) :: object integer :: p p = 0 if (associated (object%def)) then select type (def => object%def) type is (recola_def_t) p = def%alpha_power end select end if end function prc_recola_get_alpha_power function prc_recola_get_alphas_power (object) result (p) class(prc_recola_t), intent(in) :: object integer :: p p = 0 if (associated (object%def)) then select type (def => object%def) type is (recola_def_t) p = def%alphas_power end select end if end function prc_recola_get_alphas_power @ %def prc_recola_get_alpha_power @ %def prc_recola_get_alphas_power @ <>= procedure :: compute_alpha_s => prc_recola_compute_alpha_s <>= subroutine prc_recola_compute_alpha_s (object, core_state, ren_scale) class(prc_recola_t), intent(in) :: object class(prc_external_state_t), intent(inout) :: core_state real(default), intent(in) :: ren_scale core_state%alpha_qcd = object%qcd%alpha%get (ren_scale) end subroutine prc_recola_compute_alpha_s @ %def prc_recola_compute_alpha_s @ <>= procedure :: includes_polarization => prc_recola_includes_polarization <>= function prc_recola_includes_polarization (object) result (polarized) logical :: polarized class(prc_recola_t), intent(in) :: object polarized = .false. end function prc_recola_includes_polarization @ %def prc_recola_includes_polarization @ \subsection{Prepare for process evaluation} This has become obsolete and is empty. <>= procedure :: prepare_external_code => & prc_recola_prepare_external_code <>= subroutine prc_recola_prepare_external_code & (core, flv_states, var_list, os_data, libname, model, i_core, is_nlo) class(prc_recola_t), intent(inout) :: core integer, intent(in), dimension(:,:), allocatable :: flv_states type(var_list_t), intent(in) :: var_list type(os_data_t), intent(in) :: os_data type(string_t), intent(in) :: libname type(model_data_t), intent(in), target :: model integer, intent(in) :: i_core logical, intent(in) :: is_nlo call msg_debug (D_ME_METHODS, "prc_recola_prepare_external_code (no-op)") end subroutine prc_recola_prepare_external_code @ %def prc_recola_prepare_external_code @ Set all Recola parameters to their correct values. We use the model object for masses and such. Note that the QCD object provides the [[n_f]] parameter which affects $\alpha_s$ evaluation. Note that this is executed before the [[init]] method below, which defines and prepares the Recola process objects. This is in line with the Recola workflow, however. <>= procedure :: set_parameters => prc_recola_set_parameters <>= subroutine prc_recola_set_parameters (object, qcd, model) class(prc_recola_t), intent(inout) :: object type(qcd_t), intent(in) :: qcd class(model_data_t), intent(in), target, optional :: model call msg_debug (D_ME_METHODS, "RECOLA: set_parameters") object%qcd = qcd call rclwrap_set_dynamic_settings () call rclwrap_set_pole_mass & (11, dble(model%get_real (var_str ('me'))), 0._double) call rclwrap_set_pole_mass & (13, dble(model%get_real (var_str ('mmu'))), 0._double) call rclwrap_set_pole_mass & (15, dble(model%get_real (var_str ('mtau'))), 0._double) call rclwrap_set_pole_mass (1, 0._double, 0._double) call rclwrap_set_pole_mass (2, 0._double, 0._double) call rclwrap_set_pole_mass (3, dble(model%get_real (var_str ('ms'))), 0._double) call rclwrap_set_pole_mass (4, dble(model%get_real (var_str ('mc'))), 0._double) call rclwrap_set_pole_mass (5, dble(model%get_real (var_str ('mb'))), 0._double) call rclwrap_set_pole_mass (6, dble(model%get_real (var_str ('mtop'))), & dble(model%get_real (var_str ('wtop')))) call rclwrap_set_pole_mass (23, dble(model%get_real (var_str ('mZ'))), & dble(model%get_real (var_str ('wZ')))) call rclwrap_set_pole_mass (24, dble(model%get_real (var_str ('mW'))), & dble(model%get_real (var_str ('wW')))) call rclwrap_set_pole_mass (25, dble(model%get_real (var_str ('mH'))), & dble(model%get_real (var_str ('wH')))) call rclwrap_use_gfermi_scheme (dble(model%get_real (var_str ('GF')))) call rclwrap_set_light_fermions (0._double) call rclwrap_set_delta_ir (0._double, dble(pi**2 / 6)) end subroutine prc_recola_set_parameters @ %def prc_recola_set_parameters @ <>= procedure :: set_mu_ir => prc_recola_set_mu_ir <>= subroutine prc_recola_set_mu_ir (object, mu) class(prc_recola_t), intent(inout) :: object real(default), intent(in) :: mu call rclwrap_set_mu_ir (dble(mu)) end subroutine prc_recola_set_mu_ir @ %def prc_recola_set_mu_ir @ Extend the base-type initialization method by Recola-specific initialization. We take the process definitions from the [[def]] object, which has been filled before. The [[writer]] component of the process-definition object can now complete its task and prepare the Recola processes. Sadly, we have to completely reset Recola first, since Recola does not allow to modify \emph{anything} after process definition. Also, we cannot really make use of Recola's multi-process capability without violating the Whizard convention that the parameter settings at process integration time apply, not at process definition time. Each new process (i.e., process-integration) object will thus trigger a complete new Recola instance. - -TODO: There is support just for one process, Recola ID = 1. This -should be expanded. <>= procedure :: init => prc_recola_init <>= subroutine prc_recola_init (object, def, lib, id, i_component) class(prc_recola_t), intent(inout) :: object class(prc_core_def_t), intent(in), target :: def type(process_library_t), intent(in), target :: lib type(string_t), intent(in) :: id integer, intent(in) :: i_component integer :: n_flv call msg_debug (D_ME_METHODS, "RECOLA: init process object") call object%base_init (def, lib, id, i_component) n_flv = object%get_n_flvs (1) allocate (object%recola_ids(n_flv)) select type (writer => object%def%writer) type is (recola_writer_t) call writer%register_processes (object%recola_ids) end select call rclwrap_generate_processes () call object%replace_helicity_and_color_arrays () end subroutine prc_recola_init @ %def prc_recola_init @ Recola can compute dressed amplitudes, but it needs helicity and color to be in its own format to do so. <>= procedure :: replace_helicity_and_color_arrays => & prc_recola_replace_helicity_and_color_arrays <>= subroutine prc_recola_replace_helicity_and_color_arrays (object) - ! TODO: Adjust routine for multiple recola ids class(prc_recola_t), intent(inout) :: object integer, dimension(:,:), allocatable :: col_recola integer :: i call msg_debug (D_ME_METHODS, "RECOLA: replace_helicity_and_color_arrays") deallocate (object%data%hel_state) call rclwrap_get_helicity_configurations & (object%recola_ids(1), object%data%hel_state) call rclwrap_get_color_configurations (object%recola_ids(1), col_recola) allocate (object%color_state (object%data%n_in + object%data%n_out, & size (col_recola, dim = 2))) do i = 1, size (col_recola, dim = 2) object%color_state (:, i) = col_recola (:, i) end do end subroutine prc_recola_replace_helicity_and_color_arrays @ %def prc_recola_replace_helicity_and_color_arrays @ \subsection{Compute matrix element} Computes the amplitude as a function of the phase space point, the flavor, helicity and color index. It is currently only used in the form by [[prc_omega_t]], all the other ones use different interfaces. H With RECOLA, we might be able to use this, too. The current implementation can fail due to missing helicity initialization. <>= procedure :: compute_amplitude => prc_recola_compute_amplitude <>= function prc_recola_compute_amplitude & (object, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced, & core_state) result (amp) complex(default) :: amp class(prc_recola_t), intent(in) :: object integer, intent(in) :: j type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: f, h, c real(default), intent(in) :: fac_scale, ren_scale real(default), intent(in), allocatable :: alpha_qcd_forced class(prc_core_state_t), intent(inout), allocatable, optional :: & core_state real(double), dimension(0:3, object%data%n_in + object%data%n_out) :: & p_recola integer :: i logical :: new_event complex(double) :: amp_dble call msg_debug2 (D_ME_METHODS, "prc_recola_compute_amplitude") if (present (core_state)) then if (allocated (core_state)) then select type (core_state) type is (recola_state_t) new_event = core_state%new_kinematics core_state%new_kinematics = .false. end select end if end if if (new_event) then do i = 1, object%data%n_in + object%data%n_out p_recola(:, i) = dble(p(i)%p) end do call rclwrap_compute_process (object%recola_ids(f), p_recola, 'LO') end if call rclwrap_get_amplitude (object%recola_ids(f), 0, 'LO', & object%color_state (:, c), object%data%hel_state (h, :), amp_dble) amp = amp_dble end function prc_recola_compute_amplitude @ %def prc_recola_compute_amplitude @ <>= procedure :: compute_sqme => prc_recola_compute_sqme <>= subroutine prc_recola_compute_sqme (object, i_flv, i_hel, p, & ren_scale, sqme, bad_point) class(prc_recola_t), intent(in) :: object integer, intent(in) :: i_flv, i_hel type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: ren_scale real(default), intent(out) :: sqme logical, intent(out) :: bad_point real(double) :: sqme_dble real(double), dimension(0:3, object%data%n_in + object%data%n_out) :: & p_recola real(default) :: alpha_s integer :: i integer :: alphas_power ! TODO sbrass: Helicity for RECOLA call msg_debug2 (D_ME_METHODS, "prc_recola_compute_sqme") do i = 1, object%data%n_in + object%data%n_out p_recola(:, i) = dble(p(i)%p) end do alpha_s = object%qcd%alpha%get (ren_scale) call msg_debug2 (D_ME_METHODS, "alpha_s", alpha_s) call msg_debug2 (D_ME_METHODS, "ren_scale", ren_scale) call rclwrap_set_alpha_s (dble (alpha_s), dble (ren_scale), object%qcd%n_f) call rclwrap_set_mu_ir (dble (ren_scale)) call rclwrap_compute_process (object%recola_ids(i_flv), p_recola, 'LO') call rclwrap_get_squared_amplitude & (object%recola_ids(i_flv), object%get_alphas_power (), 'LO', sqme_dble) sqme = real(sqme_dble, kind=default) bad_point = .false. end subroutine prc_recola_compute_sqme @ %def prc_recola_compute_sqme @ <>= procedure :: compute_sqme_virt => prc_recola_compute_sqme_virt <>= subroutine prc_recola_compute_sqme_virt (object, i_flv, i_hel, & p, ren_scale, sqme, bad_point) class(prc_recola_t), intent(in) :: object integer, intent(in) :: i_flv, i_hel type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: ren_scale real(default), dimension(4), intent(out) :: sqme real(default) :: amp logical, intent(out) :: bad_point real(double), dimension(0:3, object%data%n_in + object%data%n_out) :: & p_recola real(double) :: sqme_dble real(default) :: alpha_s integer :: i ! TODO sbrass Helicity for RECOLA call msg_debug2 (D_ME_METHODS, "prc_recola_compute_sqme_virt") sqme = zero do i = 1, object%data%n_in + object%data%n_out p_recola(:, i) = dble(p(i)%p) end do call rclwrap_set_mu_ir (dble (ren_scale)) alpha_s = object%qcd%alpha%get (ren_scale) call rclwrap_set_alpha_s (dble (alpha_s), dble (ren_scale), object%qcd%n_f) call rclwrap_compute_process (object%recola_ids(i_flv), p_recola, 'NLO') !!! JRR, TODO: generalize for QED corrections call rclwrap_get_squared_amplitude & (object%recola_ids(i_flv), object%get_alphas_power () + 1, 'NLO', sqme_dble) sqme(3) = sqme_dble call rclwrap_get_squared_amplitude & (object%recola_ids(i_flv), object%get_alphas_power (), 'LO', sqme_dble) sqme(4) = sqme_dble bad_point = .false. end subroutine prc_recola_compute_sqme_virt @ %def prc_recola_compute_sqme_virt @ For RECOLA, explicit color factors need to multiplied to the off-diagonal elements of the color correlation matrix. The factor 1/2 from the normalization accoring to the RECOLA manual is covered by the fact that we are taking only one half of the symmetric matrix. <>= procedure :: compute_sqme_color_c_raw => prc_recola_compute_sqme_color_c_raw <>= subroutine prc_recola_compute_sqme_color_c_raw (object, i_flv, i_hel, & p, ren_scale, sqme_color_c, bad_point) class(prc_recola_t), intent(in) :: object integer, intent(in) :: i_hel, i_flv type(vector4_t), dimension(:), intent(in) :: p real(double), dimension(0:3, object%data%n_in + object%data%n_out) :: & p_recola real(default), intent(in) :: ren_scale real(default), dimension(:), intent(out) :: sqme_color_c logical, intent(out) :: bad_point integer :: i1, i2, i, n_tot real(double) :: sqme_dble do i = 1, object%data%n_in + object%data%n_out p_recola(:, i) = dble(p(i)%p) end do n_tot = object%data%n_in + object%data%n_out i = 0 do i1 = 1, n_tot do i2 = 1, i1-1 i = i + 1 call rclwrap_compute_color_correlation & (object%recola_ids(i_flv), p_recola, i1, i2, sqme_dble) sqme_color_c(i) = real (sqme_dble, kind=default) select case (abs (object%data%flv_state (i1, i_flv))) case (1:6) sqme_color_c(i) = CF * sqme_color_c(i) case (9,21) sqme_color_c(i) = CA * sqme_color_c(i) end select end do end do end subroutine prc_recola_compute_sqme_color_c_raw @ %def prc_recola_compute_sqme_color_c_raw @ \subsection{Unit tests} <<[[prc_recola_ut.f90]]>>= <> module prc_recola_ut use unit_tests use prc_recola_uti <> <> contains <> end module prc_recola_ut @ %def prc_recola_ut @ <<[[prc_recola_uti.f90]]>>= <> module prc_recola_uti use recola_wrapper !NODEP! use, intrinsic :: iso_c_binding !NODEP! use kinds <> use constants use format_utils, only: write_separator use numeric_utils, only: assert_equal use os_interface use particle_specifiers, only: new_prt_spec use prc_core_def use process_constants use process_libraries use prc_core use prc_omega <> <> contains <> <> end module prc_recola_uti @ %def prc_recola_uti @ <>= public :: prc_recola_test <>= subroutine prc_recola_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine prc_recola_test @ %def prc_recola_test @ \subsubsection{Testing a fixed flavor matrix element computation} <>= function get_omega_parameter_array () result (par) real(default), dimension(25) :: par par = zero par(1) = 1.16637d-5 ! gf par(2) = 91.153480619182744_default ! mZ par(3) = 80.357973609877547_default ! mW par(4) = 125._default ! mH par(5) = rclwrap_get_alpha_s () ! alpha_s par(12) = 173.2_default ! mt par(14) = 2.4942663787728243_default ! wZ par(15) = 2.0842989982782196_default ! wW par(22) = one / sqrt (sqrt (two) * par(1)) ! par%v - Higgs expectation value par(23) = par(3) / par(2) ! par%cw par(24) = sqrt (one - par(23)**2) ! par%sw par(25) = two * par(24) * par(3) / par(22) end function get_omega_parameter_array @ %def get_omega_parameter_array @ <>= call test (prc_recola_1, "prc_recola_1", & "Registering a RECOLA process and computing the amplitude", & u, results) <>= public :: prc_recola_1 <>= subroutine prc_recola_1 (u) integer, intent(in) :: u real(double) :: p(0:3,1:4) real(double) :: sqrts = 500._double real(double) :: m_e = 0._double real(double) :: m_mu = 0._double real(double) :: p_x_out, p_y_out, p_z_out, p_z_in integer :: h_e_p, h_e_m, h_mu_p, h_mu_m, counter real(double) :: sqme integer :: i integer, dimension(:), allocatable :: col_recola, hel_recola complex(double) :: amp_recola complex(default) :: amp_recola_default real(default), parameter :: ee = 0.3 !!! Electromagnetic coupling type(process_library_t) :: lib class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry type(string_t), dimension(:), allocatable :: prt_in, prt_out type(os_data_t) :: os_data type(process_constants_t) :: data class(prc_core_driver_t), allocatable :: driver complex(default) :: amp integer, dimension(:,:), allocatable :: helicities write (u, "(A)") "* Test output: prc_recola_1" write (u, "(A)") "* Purpose: Test interface to RECOLA and compare matrix elements with O'Mega" write (u, "(A)") p_z_in = sqrt ((sqrts / 2)**2 - m_e**2) p_z_out = 0._double p_y_out = sqrts / 10._default p_x_out = sqrt ((sqrts / 2)**2 - p_y_out**2 - p_z_out**2 - m_mu**2) p(:,1) = [sqrts / 2, 0._double, 0._double, p_z_in] p(:,2) = [sqrts / 2, 0._double, 0._double, -p_z_in] p(:,3) = [sqrts / 2, p_x_out, p_y_out, p_z_out] p(:,4) = [sqrts / 2, -p_x_out, -p_y_out, -p_z_out] write (u, "(A)") "Use phase-space point: " do i = 1, 4 write (u, "(4(F12.3,1x))") p(:,1) end do write (u, "(A)") call write_separator (u) write (u, "(A)") write (u, "(A)") "* RECOLA: Evaluate process" counter = 1 call rclwrap_request_generate_processes () write (u, "(A)") "* RECOLA: Define process e+ e- -> mu+ mu- at leading order" call rclwrap_add_process (counter, var_str ('e+ e- -> mu+ mu-'), var_str ('LO')) call rclwrap_define_processes () write (u, "(A)") "* RECOLA: generate process" call rclwrap_generate_processes () call rclwrap_compute_process (1, p, 'LO') call rclwrap_get_helicity_configurations (1, helicities) allocate (hel_recola (4), col_recola (4)) col_recola = [0,0,0,0] write (u, "(A)") "* Setting up Omega to compute the same amplitude" call lib%init (var_str ("omega1")) allocate (prt_in (2), prt_out (2)) prt_in = [var_str ("e+"), var_str ("e-")] prt_out = [var_str ("mu+"), var_str ("mu-")] allocate (omega_def_t :: def) select type (def) type is (omega_def_t) call def%init (var_str ("SM"), prt_in, prt_out, & ufo = .false., ovm = .false., cms_scheme = .true.) end select allocate (entry) call entry%init (var_str ("omega1_a"), model_name = var_str ("SM"), & n_in = 2, n_components = 1) call entry%import_component (1, n_out = 2, & prt_in = new_prt_spec (prt_in), & prt_out = new_prt_spec (prt_out), & method = var_str ("omega"), & variant = def) call lib%append (entry) call os_data%init () call lib%configure (os_data) call lib%write_makefile (os_data, force = .true., verbose = .false.) call lib%clean (os_data, distclean = .false.) call lib%write_driver (force = .true.) call lib%load (os_data) call lib%connect_process (var_str ("omega1_a"), 1, data, driver) select type (driver) type is (omega_driver_t) call driver%init (get_omega_parameter_array (), 3) call driver%new_event (real(p, kind = default)) do i = 1, 6 call rclwrap_get_amplitude (1, 0, 'LO', col_recola, helicities (:,i), amp_recola) end do do i = 1, 16 call rclwrap_get_amplitude (1, 0, 'LO', col_recola, data%hel_state (:,i), amp_recola) amp_recola = amp_recola * cmplx (0, -1, double) amp_recola_default = amp_recola call driver%get_amplitude (1, i, 1, amp) write(u,"(A,4(I2),A)") "Helicity: [",data%hel_state (:,i),"]" call assert_equal (u, amp, amp_recola_default, rel_smallness = 1.E-7_default) end do end select call rclwrap_reset_recola () write (u, "(A)") write (u, "(A)") "* End of test output: prc_recola_1" end subroutine prc_recola_1 @ %def prc_recola_1 @ \subsubsection{Testing a fixed flavor matrix element computation for 2->3} <>= call test (prc_recola_2, "prc_recola_2", & "Registering a RECOLA process and computing the amplitude for 2->3 process", & u, results) <>= public :: prc_recola_2 <>= subroutine prc_recola_2 (u) integer, intent(in) :: u real(double) :: p(0:3,1:5) real(double) :: sqrts = 700._double real(double) :: m_e = 0._double real(double) :: m_mu = 0._double real(double) :: p_x_out, p_y_out, p_z_out, p_z_in real(double) :: sqme integer :: i integer, dimension(:), allocatable :: col_recola, hel_recola integer, dimension(:,:), allocatable :: helicities complex(double) :: amp_recola complex(default) :: amp_recola_default real(default), parameter :: ee = 0.3 !!! Electromagnetic coupling type(process_library_t) :: lib class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry type(string_t), dimension(:), allocatable :: prt_in, prt_out type(os_data_t) :: os_data type(process_constants_t) :: data class(prc_core_driver_t), allocatable :: driver complex(default) :: amp integer :: n_allowed write (u, "(A)") "* Test output: prc_recola_2" write (u, "(A)") "* Purpose: Test interface to RECOLA and compare matrix elements with O'Mega for 2->3 process" write (u, "(A)") p_z_in = sqrt ((sqrts / 2)**2 - m_e**2) p(:,1) = [sqrts / 2, 0._double, 0._double, p_z_in] p(:,2) = [sqrts / 2, 0._double, 0._double, -p_z_in] p(:,3) = [243.49323116_double, -141.69619338_double, -108.30640321_double, 165.77353656_double] p(:,4) = [337.53250628_double, 143.95931207_double, 110.19717026_double, -284.71124482_double] p(:,5) = [118.97426257_double, -2.2631186860_double, -1.8907670459_double, 118.93770827_double] write (u, "(A)") "Use phase-space point: " do i = 1, 5 write (u, "(4(F12.3,1x))") p(:,1) end do write (u, "(A)") call write_separator (u) write (u, "(A)") write (u, "(A)") "* RECOLA: Evaluate process" call rclwrap_request_generate_processes () write (u, "(A)") "* RECOLA: Define process e+ e- -> mu+ mu- A at leading order" call rclwrap_add_process (2, var_str ('e+ e- -> mu+ mu- A'), var_str ('LO')) call rclwrap_define_processes () write (u, "(A)") "* RECOLA: generate process" call rclwrap_generate_processes () call rclwrap_compute_process (2, p, 'LO') call rclwrap_get_helicity_configurations (2, helicities) allocate (hel_recola (5), col_recola (5)) col_recola = [0,0,0,0,0] write (u, "(A)") "* Setting up Omega to compute the same amplitude" call lib%init (var_str ("omega2")) allocate (prt_in (2), prt_out (3)) prt_in = [var_str ("e+"), var_str ("e-")] prt_out = [var_str ("mu+"), var_str ("mu-"), var_str("A")] allocate (omega_def_t :: def) select type (def) type is (omega_def_t) call def%init (var_str ("SM"), prt_in, prt_out, & ufo = .false., ovm = .false.) end select allocate (entry) call entry%init (var_str ("omega2_a"), model_name = var_str ("SM"), & n_in = 2, n_components = 1) call entry%import_component (1, n_out = 3, & prt_in = new_prt_spec (prt_in), & prt_out = new_prt_spec (prt_out), & method = var_str ("omega"), & variant = def) call lib%append (entry) call os_data%init () call lib%configure (os_data) call lib%write_makefile (os_data, force = .true., verbose = .false.) call lib%clean (os_data, distclean = .false.) call lib%write_driver (force = .true.) call lib%load (os_data) call lib%connect_process (var_str ("omega2_a"), 1, data, driver) select type (driver) type is (omega_driver_t) call driver%init (get_omega_parameter_array (), 3) call driver%new_event (real(p, kind = default)) do i = 1, 32 call rclwrap_get_amplitude & (2, 0, 'LO', col_recola, data%hel_state (:,i), amp_recola) if (data%hel_state(3,i) * data%hel_state(4,i) * & data%hel_state(5,i) == -1) then amp_recola = amp_recola * cmplx (0, -1, double) else amp_recola = amp_recola * cmplx (0, 1, double) end if amp_recola_default = amp_recola call driver%get_amplitude (1, i, 1, amp) write(u,"(A,5(I2),A)") "Helicity: [", data%hel_state (:,i),"]" write(u,"(A,2(F12.7,1x),A,2(F12.7,1x))") "RECOLA:", & amp_recola,", O'MEGA:", amp call assert_equal & (u, amp, amp_recola_default, rel_smallness = 1.E-6_default) end do end select call rclwrap_reset_recola () write (u, "(A)") write (u, "(A)") "* End of test output: prc_recola_2" end subroutine prc_recola_2 @ %def prc_recola_2 @ Index: trunk/src/physics/physics.nw =================================================================== --- trunk/src/physics/physics.nw (revision 8234) +++ trunk/src/physics/physics.nw (revision 8235) @@ -1,5316 +1,5310 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: physics and such \chapter{Physics} \includemodulegraph{physics} Here we collect definitions and functions that we need for (particle) physics in general, to make them available for the more specific needs of WHIZARD. \begin{description} \item[physics\_defs] Physical constants. \item[c\_particles] A simple data type for particles which is C compatible. \item[lorentz] Define three-vectors, four-vectors and Lorentz transformations and common operations for them. \item[sm\_physics] Here, running functions are stored for special kinematical setup like running coupling constants, Catani-Seymour dipoles, or Sudakov factors. \item[sm\_qcd] Definitions and methods for dealing with the running QCD coupling. \item[shower\_algorithms] Algorithms typically used in Parton Showers as well as in their matching to NLO computations, e.g. with the POWHEG method. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Physics Constants} There is also the generic [[constants]] module. The constants listed here are more specific for particle physics. <<[[physics_defs.f90]]>>= <> module physics_defs <> <> use constants, only: one, two, three <> <> <> <> contains <> end module physics_defs @ %def physics_defs @ \subsection{Units} Conversion from energy units to cross-section units. <>= real(default), parameter, public :: & conv = 0.38937966e12_default @ Conversion from millimeter to nanoseconds for lifetimes. <>= real(default), parameter, public :: & ns_per_mm = 1.e6_default / 299792458._default @ Rescaling factor. <>= real(default), parameter, public :: & pb_per_fb = 1.e-3_default @ String for the default energy and cross-section units. <>= character(*), parameter, public :: & energy_unit = "GeV" character(*), parameter, public :: & cross_section_unit = "fb" @ \subsection{SM and QCD constants} <>= real(default), parameter, public :: & NC = three, & CF = (NC**2 - one) / two / NC, & CA = NC, & TR = one / two @ \subsection{Parameter Reference values} These are used exclusively in the context of running QCD parameters. In other contexts, we rely on the uniform parameter set as provided by the model definition, modifiable by the user. <>= real(default), public, parameter :: MZ_REF = 91.188_default real(default), public, parameter :: ALPHA_QCD_MZ_REF = 0.1178_default real(default), public, parameter :: LAMBDA_QCD_REF = 200.e-3_default @ %def alpha_s_mz_ref mz_ref lambda_qcd_ref @ \subsection{Particle codes} Let us define a few particle codes independent of the model. We need an UNDEFINED value: <>= integer, parameter, public :: UNDEFINED = 0 @ %def UNDEFINED @ SM fermions: <>= integer, parameter, public :: ELECTRON = 11 integer, parameter, public :: ELECTRON_NEUTRINO = 12 integer, parameter, public :: MUON = 13 integer, parameter, public :: MUON_NEUTRINO = 14 integer, parameter, public :: TAU = 15 integer, parameter, public :: TAU_NEUTRINO = 16 @ %def ELECTRON MUON TAU @ Gauge bosons: <>= integer, parameter, public :: GLUON = 21 integer, parameter, public :: PHOTON = 22 integer, parameter, public :: Z_BOSON = 23 integer, parameter, public :: W_BOSON = 24 @ %def GLUON PHOTON Z_BOSON W_BOSON @ Light mesons: <>= integer, parameter, public :: PION = 111 integer, parameter, public :: PIPLUS = 211 integer, parameter, public :: PIMINUS = - PIPLUS @ %def PION PIPLUS PIMINUS @ Di-Quarks: <>= integer, parameter, public :: UD0 = 2101 integer, parameter, public :: UD1 = 2103 integer, parameter, public :: UU1 = 2203 @ %def UD0 UD1 UU1 @ Mesons: <>= integer, parameter, public :: K0L = 130 integer, parameter, public :: K0S = 310 integer, parameter, public :: K0 = 311 integer, parameter, public :: KPLUS = 321 integer, parameter, public :: DPLUS = 411 integer, parameter, public :: D0 = 421 integer, parameter, public :: B0 = 511 integer, parameter, public :: BPLUS = 521 @ %def K0L K0S K0 KPLUS DPLUS D0 B0 BPLUS @ Light baryons: <>= integer, parameter, public :: PROTON = 2212 integer, parameter, public :: NEUTRON = 2112 integer, parameter, public :: DELTAPLUSPLUS = 2224 integer, parameter, public :: DELTAPLUS = 2214 integer, parameter, public :: DELTA0 = 2114 integer, parameter, public :: DELTAMINUS = 1114 @ %def PROTON NEUTRON DELTAPLUSPLUS DELTAPLUS DELTA0 DELTAMINUS @ Strange baryons: <>= integer, parameter, public :: SIGMAPLUS = 3222 integer, parameter, public :: SIGMA0 = 3212 integer, parameter, public :: SIGMAMINUS = 3112 @ %def SIGMAPLUS SIGMA0 SIGMAMINUS @ Charmed baryons: <>= integer, parameter, public :: SIGMACPLUSPLUS = 4222 integer, parameter, public :: SIGMACPLUS = 4212 integer, parameter, public :: SIGMAC0 = 4112 @ %def SIGMACPLUSPLUS SIGMACPLUS SIGMAC0 @ Bottom baryons: <>= integer, parameter, public :: SIGMAB0 = 5212 integer, parameter, public :: SIGMABPLUS = 5222 @ %def SIGMAB0 SIGMABPLUS @ 81-100 are reserved for internal codes. Hadron and beam remnants: <>= integer, parameter, public :: BEAM_REMNANT = 9999 integer, parameter, public :: HADRON_REMNANT = 90 integer, parameter, public :: HADRON_REMNANT_SINGLET = 91 integer, parameter, public :: HADRON_REMNANT_TRIPLET = 92 integer, parameter, public :: HADRON_REMNANT_OCTET = 93 @ %def BEAM_REMNANT HADRON_REMNANT @ %def HADRON_REMNANT_SINGLET HADRON_REMNANT_TRIPLET HADRON_REMNANT_OCTET @ Further particle codes for internal use: <>= integer, parameter, public :: INTERNAL = 94 integer, parameter, public :: INVALID = 97 integer, parameter, public :: COMPOSITE = 99 @ %def INTERNAL INVALID COMPOSITE @ \subsection{Spin codes} Somewhat redundant, but for better readability we define named constants for spin types. If the mass is nonzero, this is equal to the number of degrees of freedom. <>= integer, parameter, public:: UNKNOWN = 0 integer, parameter, public :: SCALAR = 1, SPINOR = 2, VECTOR = 3, & VECTORSPINOR = 4, TENSOR = 5 @ %def UNKNOWN SCALAR SPINOR VECTOR VECTORSPINOR TENSOR @ Isospin types and charge types are counted in an analogous way, where charge type 1 is charge 0, 2 is charge 1/3, and so on. Zero always means unknown. Note that charge and isospin types have an explicit sign. Color types are defined as the dimension of the representation. \subsection{NLO status codes} Used to specify whether a [[term_instance_t]] of a [[process_instance_t]] is associated with a Born, real-subtracted, virtual-subtracted or subtraction-dummy matrix element. <>= integer, parameter, public :: BORN = 0 integer, parameter, public :: NLO_REAL = 1 integer, parameter, public :: NLO_VIRTUAL = 2 integer, parameter, public :: NLO_MISMATCH = 3 integer, parameter, public :: NLO_DGLAP = 4 integer, parameter, public :: NLO_SUBTRACTION = 5 integer, parameter, public :: NLO_FULL = 6 integer, parameter, public :: GKS = 7 integer, parameter, public :: COMPONENT_UNDEFINED = 99 @ % def BORN, NLO_REAL, NLO_VIRTUAL, NLO_SUBTRACTION, GKS @ [[NLO_FULL]] is not strictly a component status code but having it is convenient. We define the number of additional subtractions for beam-involved NLO calculations. Each subtraction refers to a rescaling of one of two beams. <>= integer, parameter, public :: n_beam_structure_int = 4 integer, parameter, public :: n_beam_gluon_offset = 2 @ %def n_beam_structure_int @ <>= public :: component_status <>= interface component_status module procedure component_status_of_string module procedure component_status_to_string end interface <>= elemental function component_status_of_string (string) result (i) integer :: i type(string_t), intent(in) :: string select case (char(string)) case ("born") i = BORN case ("real") i = NLO_REAL case ("virtual") i = NLO_VIRTUAL case ("mismatch") i = NLO_MISMATCH case ("dglap") i = NLO_DGLAP case ("subtraction") i = NLO_SUBTRACTION case ("full") i = NLO_FULL case ("GKS") i = GKS case default i = COMPONENT_UNDEFINED end select end function component_status_of_string elemental function component_status_to_string (i) result (string) type(string_t) :: string integer, intent(in) :: i select case (i) case (BORN) string = "born" case (NLO_REAL) string = "real" case (NLO_VIRTUAL) string = "virtual" case (NLO_MISMATCH) string = "mismatch" case (NLO_DGLAP) string = "dglap" case (NLO_SUBTRACTION) string = "subtraction" case (NLO_FULL) string = "full" case (GKS) string = "GKS" case default string = "undefined" end select end function component_status_to_string @ %def component_status @ <>= public :: is_nlo_component <>= elemental function is_nlo_component (comp) result (is_nlo) logical :: is_nlo integer, intent(in) :: comp select case (comp) case (BORN : GKS) is_nlo = .true. case default is_nlo = .false. end select end function is_nlo_component @ %def is_nlo_component @ <>= public :: is_subtraction_component <>= function is_subtraction_component (emitter, nlo_type) result (is_subtraction) logical :: is_subtraction integer, intent(in) :: emitter, nlo_type is_subtraction = nlo_type == NLO_REAL .and. emitter < 0 end function is_subtraction_component @ %def is_subtraction_component @ \subsection{Threshold} Some commonly used variables for the threshold computation <>= integer, parameter, public :: THR_POS_WP = 3 integer, parameter, public :: THR_POS_WM = 4 integer, parameter, public :: THR_POS_B = 5 integer, parameter, public :: THR_POS_BBAR = 6 integer, parameter, public :: THR_POS_GLUON = 7 integer, parameter, public :: THR_EMITTER_OFFSET = 4 integer, parameter, public :: NO_FACTORIZATION = 0 integer, parameter, public :: FACTORIZATION_THRESHOLD = 1 integer, dimension(2), parameter, public :: ass_quark = [5, 6] integer, dimension(2), parameter, public :: ass_boson = [3, 4] integer, parameter, public :: PROC_MODE_UNDEFINED = 0 integer, parameter, public :: PROC_MODE_TT = 1 integer, parameter, public :: PROC_MODE_WBWB = 2 @ @ <>= public :: thr_leg <>= function thr_leg (emitter) result (leg) integer :: leg integer, intent(in) :: emitter leg = emitter - THR_EMITTER_OFFSET end function thr_leg @ %def thr_leg @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{C-compatible Particle Type} For easy communication with C code, we introduce a simple C-compatible type for particles. The components are either default C integers or default C doubles. The [[c_prt]] type is transparent, and its contents should be regarded as part of the interface. <<[[c_particles.f90]]>>= <> module c_particles use, intrinsic :: iso_c_binding !NODEP! use io_units use format_defs, only: FMT_14, FMT_19 <> <> <> contains <> end module c_particles @ %def c_particles @ <>= public :: c_prt_t <>= type, bind(C) :: c_prt_t integer(c_int) :: type = 0 integer(c_int) :: pdg = 0 integer(c_int) :: polarized = 0 integer(c_int) :: h = 0 real(c_double) :: pe = 0 real(c_double) :: px = 0 real(c_double) :: py = 0 real(c_double) :: pz = 0 real(c_double) :: p2 = 0 end type c_prt_t @ %def c_prt_t @ This is for debugging only, there is no C binding. It is a simplified version of [[prt_write]]. <>= public :: c_prt_write <>= subroutine c_prt_write (prt, unit) type(c_prt_t), intent(in) :: prt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)", advance="no") "prt(" write (u, "(I0,':')", advance="no") prt%type if (prt%polarized /= 0) then write (u, "(I0,'/',I0,'|')", advance="no") prt%pdg, prt%h else write (u, "(I0,'|')", advance="no") prt%pdg end if write (u, "(" // FMT_14 // ",';'," // FMT_14 // ",','," // & FMT_14 // ",','," // FMT_14 // ")", advance="no") & prt%pe, prt%px, prt%py, prt%pz write (u, "('|'," // FMT_19 // ")", advance="no") prt%p2 write (u, "(A)") ")" end subroutine c_prt_write @ %def c_prt_write @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Lorentz algebra} Define Lorentz vectors, three-vectors, boosts, and some functions to manipulate them. To make maximum use of this, all functions, if possible, are declared elemental (or pure, if this is not possible). <<[[lorentz.f90]]>>= <> module lorentz <> use numeric_utils use io_units use constants, only: pi, twopi, degree, zero, one, two, eps0, tiny_07 use format_defs, only: FMT_11, FMT_13, FMT_15, FMT_19 use format_utils, only: pac_fmt use diagnostics use c_particles <> <> <> <> <> <> <> contains <> end module lorentz @ %def lorentz @ \subsection{Three-vectors} First of all, let us introduce three-vectors in a trivial way. The functions and overloaded elementary operations clearly are too much overhead, but we like to keep the interface for three-vectors and four-vectors exactly parallel. By the way, we might attach a label to a vector by extending the type definition later. <>= public :: vector3_t <>= type :: vector3_t real(default), dimension(3) :: p end type vector3_t @ %def vector3_t @ Output a vector <>= public :: vector3_write <>= subroutine vector3_write (p, unit, testflag) type(vector3_t), intent(in) :: p integer, intent(in), optional :: unit logical, intent(in), optional :: testflag character(len=7) :: fmt integer :: u u = given_output_unit (unit); if (u < 0) return call pac_fmt (fmt, FMT_19, FMT_15, testflag) write(u, "(1x,A,3(1x," // fmt // "))") 'P = ', p%p end subroutine vector3_write @ %def vector3_write @ This is a three-vector with zero components <>= public :: vector3_null <>= type(vector3_t), parameter :: vector3_null = & vector3_t ([ zero, zero, zero ]) @ %def vector3_null @ Canonical three-vector: <>= public :: vector3_canonical <>= elemental function vector3_canonical (k) result (p) type(vector3_t) :: p integer, intent(in) :: k p = vector3_null p%p(k) = 1 end function vector3_canonical @ %def vector3_canonical @ A moving particle ($k$-axis, or arbitrary axis). Note that the function for the generic momentum cannot be elemental. <>= public :: vector3_moving <>= interface vector3_moving module procedure vector3_moving_canonical module procedure vector3_moving_generic end interface <>= elemental function vector3_moving_canonical (p, k) result(q) type(vector3_t) :: q real(default), intent(in) :: p integer, intent(in) :: k q = vector3_null q%p(k) = p end function vector3_moving_canonical pure function vector3_moving_generic (p) result(q) real(default), dimension(3), intent(in) :: p type(vector3_t) :: q q%p = p end function vector3_moving_generic @ %def vector3_moving @ Equality and inequality <>= public :: operator(==), operator(/=) <>= interface operator(==) module procedure vector3_eq end interface interface operator(/=) module procedure vector3_neq end interface <>= elemental function vector3_eq (p, q) result (r) logical :: r type(vector3_t), intent(in) :: p,q r = all (abs (p%p - q%p) < eps0) end function vector3_eq elemental function vector3_neq (p, q) result (r) logical :: r type(vector3_t), intent(in) :: p,q r = any (abs(p%p - q%p) > eps0) end function vector3_neq @ %def == /= @ Define addition and subtraction <>= public :: operator(+), operator(-) <>= interface operator(+) module procedure add_vector3 end interface interface operator(-) module procedure sub_vector3 end interface <>= elemental function add_vector3 (p, q) result (r) type(vector3_t) :: r type(vector3_t), intent(in) :: p,q r%p = p%p + q%p end function add_vector3 elemental function sub_vector3 (p, q) result (r) type(vector3_t) :: r type(vector3_t), intent(in) :: p,q r%p = p%p - q%p end function sub_vector3 @ %def + - @ The multiplication sign is overloaded with scalar multiplication; similarly division: <>= public :: operator(*), operator(/) <>= interface operator(*) module procedure prod_integer_vector3, prod_vector3_integer module procedure prod_real_vector3, prod_vector3_real end interface interface operator(/) module procedure div_vector3_real, div_vector3_integer end interface <>= elemental function prod_real_vector3 (s, p) result (q) type(vector3_t) :: q real(default), intent(in) :: s type(vector3_t), intent(in) :: p q%p = s * p%p end function prod_real_vector3 elemental function prod_vector3_real (p, s) result (q) type(vector3_t) :: q real(default), intent(in) :: s type(vector3_t), intent(in) :: p q%p = s * p%p end function prod_vector3_real elemental function div_vector3_real (p, s) result (q) type(vector3_t) :: q real(default), intent(in) :: s type(vector3_t), intent(in) :: p q%p = p%p/s end function div_vector3_real elemental function prod_integer_vector3 (s, p) result (q) type(vector3_t) :: q integer, intent(in) :: s type(vector3_t), intent(in) :: p q%p = s * p%p end function prod_integer_vector3 elemental function prod_vector3_integer (p, s) result (q) type(vector3_t) :: q integer, intent(in) :: s type(vector3_t), intent(in) :: p q%p = s * p%p end function prod_vector3_integer elemental function div_vector3_integer (p, s) result (q) type(vector3_t) :: q integer, intent(in) :: s type(vector3_t), intent(in) :: p q%p = p%p/s end function div_vector3_integer @ %def * / @ The multiplication sign can also indicate scalar products: <>= interface operator(*) module procedure prod_vector3 end interface <>= elemental function prod_vector3 (p, q) result (s) real(default) :: s type(vector3_t), intent(in) :: p,q s = dot_product (p%p, q%p) end function prod_vector3 @ %def * <>= public :: cross_product <>= interface cross_product module procedure vector3_cross_product end interface <>= elemental function vector3_cross_product (p, q) result (r) type(vector3_t) :: r type(vector3_t), intent(in) :: p,q integer :: i do i=1,3 r%p(i) = dot_product (p%p, matmul(epsilon_three(i,:,:), q%p)) end do end function vector3_cross_product @ %def cross_product @ Exponentiation is defined only for integer powers. Odd powers mean take the square root; so [[p**1]] is the length of [[p]]. <>= public :: operator(**) <>= interface operator(**) module procedure power_vector3 end interface <>= elemental function power_vector3 (p, e) result (s) real(default) :: s type(vector3_t), intent(in) :: p integer, intent(in) :: e s = dot_product (p%p, p%p) if (e/=2) then if (mod(e,2)==0) then s = s**(e/2) else s = sqrt(s)**e end if end if end function power_vector3 @ %def ** @ Finally, we need a negation. <>= interface operator(-) module procedure negate_vector3 end interface <>= elemental function negate_vector3 (p) result (q) type(vector3_t) :: q type(vector3_t), intent(in) :: p integer :: i do i = 1, 3 if (abs (p%p(i)) < eps0) then q%p(i) = 0 else q%p(i) = -p%p(i) end if end do end function negate_vector3 @ %def - @ The sum function can be useful: <>= public :: sum <>= interface sum module procedure sum_vector3 end interface @ %def sum @ <>= public :: vector3_set_component <>= subroutine vector3_set_component (p, i, value) type(vector3_t), intent(inout) :: p integer, intent(in) :: i real(default), intent(in) :: value p%p(i) = value end subroutine vector3_set_component @ %def vector3_set_component @ <>= pure function sum_vector3 (p) result (q) type(vector3_t) :: q type(vector3_t), dimension(:), intent(in) :: p integer :: i do i=1, 3 q%p(i) = sum (p%p(i)) end do end function sum_vector3 @ %def sum @ Any component: <>= public :: vector3_get_component @ %def component <>= elemental function vector3_get_component (p, k) result (c) type(vector3_t), intent(in) :: p integer, intent(in) :: k real(default) :: c c = p%p(k) end function vector3_get_component @ %def vector3_get_component @ Extract all components. This is not elemental. <>= public :: vector3_get_components <>= pure function vector3_get_components (p) result (a) type(vector3_t), intent(in) :: p real(default), dimension(3) :: a a = p%p end function vector3_get_components @ %def vector3_get_components @ This function returns the direction of a three-vector, i.e., a normalized three-vector. If the vector is null, we return a null vector. <>= public :: direction <>= interface direction module procedure vector3_get_direction end interface <>= elemental function vector3_get_direction (p) result (q) type(vector3_t) :: q type(vector3_t), intent(in) :: p real(default) :: pp pp = p**1 if (pp > eps0) then q%p = p%p / pp else q%p = 0 end if end function vector3_get_direction @ %def direction @ \subsection{Four-vectors} In four-vectors the zero-component needs special treatment, therefore we do not use the standard operations. Sure, we pay for the extra layer of abstraction by losing efficiency; so we have to assume that the time-critical applications do not involve four-vector operations. <>= public :: vector4_t <>= type :: vector4_t real(default), dimension(0:3) :: p = & [zero, zero, zero, zero] contains <> end type vector4_t @ %def vector4_t @ Output a vector <>= public :: vector4_write <>= procedure :: write => vector4_write <>= subroutine vector4_write & (p, unit, show_mass, testflag, compressed, ultra) class(vector4_t), intent(in) :: p integer, intent(in), optional :: unit logical, intent(in), optional :: show_mass, testflag, compressed, ultra logical :: comp, sm, tf, extreme integer :: u character(len=7) :: fmt real(default) :: m comp = .false.; if (present (compressed)) comp = compressed sm = .false.; if (present (show_mass)) sm = show_mass tf = .false.; if (present (testflag)) tf = testflag extreme = .false.; if (present (ultra)) extreme = ultra if (extreme) then call pac_fmt (fmt, FMT_19, FMT_11, testflag) else call pac_fmt (fmt, FMT_19, FMT_13, testflag) end if u = given_output_unit (unit); if (u < 0) return if (comp) then write (u, "(4(F12.3,1X))", advance="no") p%p(0:3) else write (u, "(1x,A,1x," // fmt // ")") 'E = ', p%p(0) write (u, "(1x,A,3(1x," // fmt // "))") 'P = ', p%p(1:) if (sm) then m = p**1 if (tf) call pacify (m, tolerance = 1E-6_default) write (u, "(1x,A,1x," // fmt // ")") 'M = ', m end if end if end subroutine vector4_write @ %def vector4_write @ Binary I/O <>= public :: vector4_write_raw public :: vector4_read_raw <>= subroutine vector4_write_raw (p, u) type(vector4_t), intent(in) :: p integer, intent(in) :: u write (u) p%p end subroutine vector4_write_raw subroutine vector4_read_raw (p, u, iostat) type(vector4_t), intent(out) :: p integer, intent(in) :: u integer, intent(out), optional :: iostat read (u, iostat=iostat) p%p end subroutine vector4_read_raw @ %def vector4_write_raw vector4_read_raw @ This is a four-vector with zero components <>= public :: vector4_null <>= type(vector4_t), parameter :: vector4_null = & vector4_t ([ zero, zero, zero, zero ]) @ %def vector4_null @ Canonical four-vector: <>= public :: vector4_canonical <>= elemental function vector4_canonical (k) result (p) type(vector4_t) :: p integer, intent(in) :: k p = vector4_null p%p(k) = 1 end function vector4_canonical @ %def vector4_canonical @ A particle at rest: <>= public :: vector4_at_rest <>= elemental function vector4_at_rest (m) result (p) type(vector4_t) :: p real(default), intent(in) :: m p = vector4_t ([ m, zero, zero, zero ]) end function vector4_at_rest @ %def vector4_at_rest @ A moving particle ($k$-axis, or arbitrary axis) <>= public :: vector4_moving <>= interface vector4_moving module procedure vector4_moving_canonical module procedure vector4_moving_generic end interface <>= elemental function vector4_moving_canonical (E, p, k) result (q) type(vector4_t) :: q real(default), intent(in) :: E, p integer, intent(in) :: k q = vector4_at_rest(E) q%p(k) = p end function vector4_moving_canonical elemental function vector4_moving_generic (E, p) result (q) type(vector4_t) :: q real(default), intent(in) :: E type(vector3_t), intent(in) :: p q%p(0) = E q%p(1:) = p%p end function vector4_moving_generic @ %def vector4_moving @ Equality and inequality <>= interface operator(==) module procedure vector4_eq end interface interface operator(/=) module procedure vector4_neq end interface <>= elemental function vector4_eq (p, q) result (r) logical :: r type(vector4_t), intent(in) :: p,q r = all (abs (p%p - q%p) < eps0) end function vector4_eq elemental function vector4_neq (p, q) result (r) logical :: r type(vector4_t), intent(in) :: p,q r = any (abs (p%p - q%p) > eps0) end function vector4_neq @ %def == /= @ Addition and subtraction: <>= interface operator(+) module procedure add_vector4 end interface interface operator(-) module procedure sub_vector4 end interface <>= elemental function add_vector4 (p,q) result (r) type(vector4_t) :: r type(vector4_t), intent(in) :: p,q r%p = p%p + q%p end function add_vector4 elemental function sub_vector4 (p,q) result (r) type(vector4_t) :: r type(vector4_t), intent(in) :: p,q r%p = p%p - q%p end function sub_vector4 @ %def + - @ We also need scalar multiplication and division: <>= interface operator(*) module procedure prod_real_vector4, prod_vector4_real module procedure prod_integer_vector4, prod_vector4_integer end interface interface operator(/) module procedure div_vector4_real module procedure div_vector4_integer end interface <>= elemental function prod_real_vector4 (s, p) result (q) type(vector4_t) :: q real(default), intent(in) :: s type(vector4_t), intent(in) :: p q%p = s * p%p end function prod_real_vector4 elemental function prod_vector4_real (p, s) result (q) type(vector4_t) :: q real(default), intent(in) :: s type(vector4_t), intent(in) :: p q%p = s * p%p end function prod_vector4_real elemental function div_vector4_real (p, s) result (q) type(vector4_t) :: q real(default), intent(in) :: s type(vector4_t), intent(in) :: p q%p = p%p/s end function div_vector4_real elemental function prod_integer_vector4 (s, p) result (q) type(vector4_t) :: q integer, intent(in) :: s type(vector4_t), intent(in) :: p q%p = s * p%p end function prod_integer_vector4 elemental function prod_vector4_integer (p, s) result (q) type(vector4_t) :: q integer, intent(in) :: s type(vector4_t), intent(in) :: p q%p = s * p%p end function prod_vector4_integer elemental function div_vector4_integer (p, s) result (q) type(vector4_t) :: q integer, intent(in) :: s type(vector4_t), intent(in) :: p q%p = p%p/s end function div_vector4_integer @ %def * / @ Scalar products and squares in the Minkowski sense: <>= interface operator(*) module procedure prod_vector4 end interface interface operator(**) module procedure power_vector4 end interface <>= elemental function prod_vector4 (p, q) result (s) real(default) :: s type(vector4_t), intent(in) :: p,q s = p%p(0)*q%p(0) - dot_product(p%p(1:), q%p(1:)) end function prod_vector4 @ %def * @ The power operation for four-vectors is signed, i.e., [[p**1]] is positive for timelike and negative for spacelike vectors. Note that [[(p**1)**2]] is not necessarily equal to [[p**2]]. <>= elemental function power_vector4 (p, e) result (s) real(default) :: s type(vector4_t), intent(in) :: p integer, intent(in) :: e s = p * p if (e /= 2) then if (mod(e, 2) == 0) then s = s**(e / 2) else if (s >= 0) then s = sqrt(s)**e else s = -(sqrt(abs(s))**e) end if end if end function power_vector4 @ %def ** @ Finally, we introduce a negation <>= interface operator(-) module procedure negate_vector4 end interface <>= elemental function negate_vector4 (p) result (q) type(vector4_t) :: q type(vector4_t), intent(in) :: p integer :: i do i = 0, 3 if (abs (p%p(i)) < eps0) then q%p(i) = 0 else q%p(i) = -p%p(i) end if end do end function negate_vector4 @ %def - @ The sum function can be useful: <>= interface sum module procedure sum_vector4, sum_vector4_mask end interface @ %def sum @ <>= pure function sum_vector4 (p) result (q) type(vector4_t) :: q type(vector4_t), dimension(:), intent(in) :: p integer :: i do i = 0, 3 q%p(i) = sum (p%p(i)) end do end function sum_vector4 pure function sum_vector4_mask (p, mask) result (q) type(vector4_t) :: q type(vector4_t), dimension(:), intent(in) :: p logical, dimension(:), intent(in) :: mask integer :: i do i = 0, 3 q%p(i) = sum (p%p(i), mask=mask) end do end function sum_vector4_mask @ %def sum @ \subsection{Conversions} Manually set a component of the four-vector: <>= public :: vector4_set_component <>= subroutine vector4_set_component (p, k, c) type(vector4_t), intent(inout) :: p integer, intent(in) :: k real(default), intent(in) :: c p%p(k) = c end subroutine vector4_set_component @ %def vector4_get_component Any component: <>= public :: vector4_get_component <>= elemental function vector4_get_component (p, k) result (c) real(default) :: c type(vector4_t), intent(in) :: p integer, intent(in) :: k c = p%p(k) end function vector4_get_component @ %def vector4_get_component @ Extract all components. This is not elemental. <>= public :: vector4_get_components <>= pure function vector4_get_components (p) result (a) real(default), dimension(0:3) :: a type(vector4_t), intent(in) :: p a = p%p end function vector4_get_components @ %def vector4_get_components @ This function returns the space part of a four-vector, such that we can apply three-vector operations on it: <>= public :: space_part <>= interface space_part module procedure vector4_get_space_part end interface <>= elemental function vector4_get_space_part (p) result (q) type(vector3_t) :: q type(vector4_t), intent(in) :: p q%p = p%p(1:) end function vector4_get_space_part @ %def space_part @ This function returns the direction of a four-vector, i.e., a normalized three-vector. If the four-vector has zero space part, we return a null vector. <>= interface direction module procedure vector4_get_direction end interface <>= elemental function vector4_get_direction (p) result (q) type(vector3_t) :: q type(vector4_t), intent(in) :: p real(default) :: qq q%p = p%p(1:) qq = q**1 if (abs(qq) > eps0) then q%p = q%p / qq else q%p = 0 end if end function vector4_get_direction @ %def direction @ Change the sign of the spatial part of a four-vector <>= public :: vector4_invert_direction <>= elemental subroutine vector4_invert_direction (p) type(vector4_t), intent(inout) :: p p%p(1:3) = -p%p(1:3) end subroutine vector4_invert_direction @ %def vector4_invert_direction @ This function returns the four-vector as an ordinary array. A second version for an array of four-vectors. <>= public :: assignment (=) <>= interface assignment (=) module procedure array_from_vector4_1, array_from_vector4_2, & array_from_vector3_1, array_from_vector3_2, & vector4_from_array, vector3_from_array end interface <>= pure subroutine array_from_vector4_1 (a, p) real(default), dimension(:), intent(out) :: a type(vector4_t), intent(in) :: p a = p%p end subroutine array_from_vector4_1 pure subroutine array_from_vector4_2 (a, p) type(vector4_t), dimension(:), intent(in) :: p real(default), dimension(:,:), intent(out) :: a integer :: i forall (i=1:size(p)) a(:,i) = p(i)%p end forall end subroutine array_from_vector4_2 pure subroutine array_from_vector3_1 (a, p) real(default), dimension(:), intent(out) :: a type(vector3_t), intent(in) :: p a = p%p end subroutine array_from_vector3_1 pure subroutine array_from_vector3_2 (a, p) type(vector3_t), dimension(:), intent(in) :: p real(default), dimension(:,:), intent(out) :: a integer :: i forall (i=1:size(p)) a(:,i) = p(i)%p end forall end subroutine array_from_vector3_2 pure subroutine vector4_from_array (p, a) type(vector4_t), intent(out) :: p real(default), dimension(:), intent(in) :: a p%p(0:3) = a end subroutine vector4_from_array pure subroutine vector3_from_array (p, a) type(vector3_t), intent(out) :: p real(default), dimension(:), intent(in) :: a p%p(1:3) = a end subroutine vector3_from_array @ %def array_from_vector4 array_from_vector3 @ <>= public :: vector4 <>= pure function vector4 (a) result (p) type(vector4_t) :: p real(default), intent(in), dimension(4) :: a p%p = a end function vector4 @ %def vector4 @ <>= procedure :: to_pythia6 => vector4_to_pythia6 <>= pure function vector4_to_pythia6 (vector4, m) result (p) real(double), dimension(1:5) :: p class(vector4_t), intent(in) :: vector4 real(default), intent(in), optional :: m p(1:3) = vector4%p(1:3) p(4) = vector4%p(0) if (present (m)) then p(5) = m else p(5) = vector4 ** 1 end if end function vector4_to_pythia6 @ %def vector4_to_pythia6 @ Transform the momentum of a [[c_prt]] object into a four-vector and vice versa: <>= interface assignment (=) module procedure vector4_from_c_prt, c_prt_from_vector4 end interface <>= pure subroutine vector4_from_c_prt (p, c_prt) type(vector4_t), intent(out) :: p type(c_prt_t), intent(in) :: c_prt p%p(0) = c_prt%pe p%p(1) = c_prt%px p%p(2) = c_prt%py p%p(3) = c_prt%pz end subroutine vector4_from_c_prt pure subroutine c_prt_from_vector4 (c_prt, p) type(c_prt_t), intent(out) :: c_prt type(vector4_t), intent(in) :: p c_prt%pe = p%p(0) c_prt%px = p%p(1) c_prt%py = p%p(2) c_prt%pz = p%p(3) c_prt%p2 = p ** 2 end subroutine c_prt_from_vector4 @ %def vector4_from_c_prt c_prt_from_vector4 @ Initialize a [[c_prt_t]] object with the components of a four-vector as its kinematical entries. Compute the invariant mass, or use the optional mass-squared value instead. <>= public :: vector4_to_c_prt <>= elemental function vector4_to_c_prt (p, p2) result (c_prt) type(c_prt_t) :: c_prt type(vector4_t), intent(in) :: p real(default), intent(in), optional :: p2 c_prt%pe = p%p(0) c_prt%px = p%p(1) c_prt%py = p%p(2) c_prt%pz = p%p(3) if (present (p2)) then c_prt%p2 = p2 else c_prt%p2 = p ** 2 end if end function vector4_to_c_prt @ %def vector4_to_c_prt @ <>= public :: phs_point_t <>= type :: phs_point_t type(vector4_t), dimension(:), allocatable :: p integer :: n_momenta = 0 contains <> end type phs_point_t @ %def phs_point_t @ <>= interface operator(==) module procedure phs_point_eq end interface <>= elemental function phs_point_eq (phs_point_1, phs_point_2) result (eq) logical :: eq type(phs_point_t), intent(in) :: phs_point_1, phs_point_2 eq = all (phs_point_1%p == phs_point_2%p) end function phs_point_eq @ %def phs_point_eq @ <>= interface operator(*) module procedure prod_LT_phs_point end interface <>= elemental function prod_LT_phs_point (L, phs_point) result (phs_point_LT) type(phs_point_t) :: phs_point_LT type(lorentz_transformation_t), intent(in) :: L type(phs_point_t), intent(in) :: phs_point phs_point_LT = size (phs_point%p) phs_point_LT%p = L * phs_point%p end function prod_LT_phs_point @ %def prod_LT_phs_point @ <>= interface assignment(=) module procedure phs_point_from_n, phs_point_from_vector4, & phs_point_from_phs_point end interface <>= pure subroutine phs_point_from_n (phs_point, n_particles) type(phs_point_t), intent(out) :: phs_point integer, intent(in) :: n_particles allocate (phs_point%p (n_particles)) phs_point%n_momenta = n_particles phs_point%p = vector4_null end subroutine phs_point_from_n @ %def phs_point_init_from_n @ <>= <>= pure subroutine phs_point_from_vector4 (phs_point, p) type(phs_point_t), intent(out) :: phs_point type(vector4_t), intent(in), dimension(:) :: p phs_point%n_momenta = size (p) allocate (phs_point%p (phs_point%n_momenta), source = p) end subroutine phs_point_from_vector4 @ %def phs_point_init_from_p @ <>= pure subroutine phs_point_from_phs_point (phs_point, phs_point_in) type(phs_point_t), intent(out) :: phs_point type(phs_point_t), intent(in) :: phs_point_in phs_point%n_momenta = phs_point_in%n_momenta allocate (phs_point%p (phs_point%n_momenta)) phs_point%p = phs_point_in%p end subroutine phs_point_from_phs_point @ %def phs_point_from_phs_point @ <>= procedure :: get_sqrts_in => phs_point_get_sqrts_in <>= function phs_point_get_sqrts_in (phs_point, n_in) result (msq) real(default) :: msq class(phs_point_t), intent(in) :: phs_point integer, intent(in) :: n_in msq = (sum (phs_point%p(1:n_in)))**2 end function phs_point_get_sqrts_in @ %def phs_point_get_sqrts_in @ <>= procedure :: final => phs_point_final <>= subroutine phs_point_final (phs_point) class(phs_point_t), intent(inout) :: phs_point deallocate (phs_point%p) phs_point%n_momenta = 0 end subroutine phs_point_final @ %def phs_point_final @ <>= procedure :: write => phs_point_write <>= subroutine phs_point_write (phs_point, unit, show_mass, testflag, & check_conservation, ultra, n_in) class(phs_point_t), intent(in) :: phs_point integer, intent(in), optional :: unit logical, intent(in), optional :: show_mass logical, intent(in), optional :: testflag, ultra logical, intent(in), optional :: check_conservation integer, intent(in), optional :: n_in call vector4_write_set (phs_point%p, unit = unit, show_mass = show_mass, & testflag = testflag, check_conservation = check_conservation, & ultra = ultra, n_in = n_in) end subroutine phs_point_write @ %def phs_point_write @ <>= procedure :: get_x => phs_point_get_x <>= function phs_point_get_x (phs_point, E_beam) result (x) real(default), dimension(2) :: x class(phs_point_t), intent(in) :: phs_point real(default), intent(in) :: E_beam x = phs_point%p(1:2)%p(0) / E_beam end function phs_point_get_x @ %def phs_point_get_x @ \subsection{Angles} Return the angles in a canonical system. The angle $\phi$ is defined between $0\leq\phi<2\pi$. In degenerate cases, return zero. <>= public :: azimuthal_angle <>= interface azimuthal_angle module procedure vector3_azimuthal_angle module procedure vector4_azimuthal_angle end interface <>= elemental function vector3_azimuthal_angle (p) result (phi) real(default) :: phi type(vector3_t), intent(in) :: p if (any (abs (p%p(1:2)) > 0)) then phi = atan2(p%p(2), p%p(1)) if (phi < 0) phi = phi + twopi else phi = 0 end if end function vector3_azimuthal_angle elemental function vector4_azimuthal_angle (p) result (phi) real(default) :: phi type(vector4_t), intent(in) :: p phi = vector3_azimuthal_angle (space_part (p)) end function vector4_azimuthal_angle @ %def azimuthal_angle @ Azimuthal angle in degrees <>= public :: azimuthal_angle_deg <>= interface azimuthal_angle_deg module procedure vector3_azimuthal_angle_deg module procedure vector4_azimuthal_angle_deg end interface <>= elemental function vector3_azimuthal_angle_deg (p) result (phi) real(default) :: phi type(vector3_t), intent(in) :: p phi = vector3_azimuthal_angle (p) / degree end function vector3_azimuthal_angle_deg elemental function vector4_azimuthal_angle_deg (p) result (phi) real(default) :: phi type(vector4_t), intent(in) :: p phi = vector4_azimuthal_angle (p) / degree end function vector4_azimuthal_angle_deg @ %def azimuthal_angle_deg @ The azimuthal distance of two vectors. This is the difference of the azimuthal angles, but cannot be larger than $\pi$: The result is between $-\pi<\Delta\phi\leq\pi$. <>= public :: azimuthal_distance <>= interface azimuthal_distance module procedure vector3_azimuthal_distance module procedure vector4_azimuthal_distance end interface <>= elemental function vector3_azimuthal_distance (p, q) result (dphi) real(default) :: dphi type(vector3_t), intent(in) :: p,q dphi = vector3_azimuthal_angle (q) - vector3_azimuthal_angle (p) if (dphi <= -pi) then dphi = dphi + twopi else if (dphi > pi) then dphi = dphi - twopi end if end function vector3_azimuthal_distance elemental function vector4_azimuthal_distance (p, q) result (dphi) real(default) :: dphi type(vector4_t), intent(in) :: p,q dphi = vector3_azimuthal_distance & (space_part (p), space_part (q)) end function vector4_azimuthal_distance @ %def azimuthal_distance @ The same in degrees: <>= public :: azimuthal_distance_deg <>= interface azimuthal_distance_deg module procedure vector3_azimuthal_distance_deg module procedure vector4_azimuthal_distance_deg end interface <>= elemental function vector3_azimuthal_distance_deg (p, q) result (dphi) real(default) :: dphi type(vector3_t), intent(in) :: p,q dphi = vector3_azimuthal_distance (p, q) / degree end function vector3_azimuthal_distance_deg elemental function vector4_azimuthal_distance_deg (p, q) result (dphi) real(default) :: dphi type(vector4_t), intent(in) :: p,q dphi = vector4_azimuthal_distance (p, q) / degree end function vector4_azimuthal_distance_deg @ %def azimuthal_distance_deg @ The polar angle is defined $0\leq\theta\leq\pi$. Note that [[ATAN2]] has the reversed order of arguments: [[ATAN2(Y,X)]]. Here, $x$ is the 3-component while $y$ is the transverse momentum which is always nonnegative. Therefore, the result is nonnegative as well. <>= public :: polar_angle <>= interface polar_angle module procedure polar_angle_vector3 module procedure polar_angle_vector4 end interface <>= elemental function polar_angle_vector3 (p) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p if (any (abs (p%p) > 0)) then theta = atan2 (sqrt(p%p(1)**2 + p%p(2)**2), p%p(3)) else theta = 0 end if end function polar_angle_vector3 elemental function polar_angle_vector4 (p) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p theta = polar_angle (space_part (p)) end function polar_angle_vector4 @ %def polar_angle @ This is the cosine of the polar angle: $-1\leq\cos\theta\leq 1$. <>= public :: polar_angle_ct <>= interface polar_angle_ct module procedure polar_angle_ct_vector3 module procedure polar_angle_ct_vector4 end interface <>= elemental function polar_angle_ct_vector3 (p) result (ct) real(default) :: ct type(vector3_t), intent(in) :: p if (any (abs (p%p) > 0)) then ct = p%p(3) / p**1 else ct = 1 end if end function polar_angle_ct_vector3 elemental function polar_angle_ct_vector4 (p) result (ct) real(default) :: ct type(vector4_t), intent(in) :: p ct = polar_angle_ct (space_part (p)) end function polar_angle_ct_vector4 @ %def polar_angle_ct @ The polar angle in degrees. <>= public :: polar_angle_deg <>= interface polar_angle_deg module procedure polar_angle_deg_vector3 module procedure polar_angle_deg_vector4 end interface <>= elemental function polar_angle_deg_vector3 (p) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p theta = polar_angle (p) / degree end function polar_angle_deg_vector3 elemental function polar_angle_deg_vector4 (p) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p theta = polar_angle (p) / degree end function polar_angle_deg_vector4 @ %def polar_angle_deg @ This is the angle enclosed between two three-momenta. If one of the momenta is zero, we return an angle of zero. The range of the result is $0\leq\theta\leq\pi$. If there is only one argument, take the positive $z$ axis as reference. <>= public :: enclosed_angle <>= interface enclosed_angle module procedure enclosed_angle_vector3 module procedure enclosed_angle_vector4 end interface <>= elemental function enclosed_angle_vector3 (p, q) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p, q theta = acos (enclosed_angle_ct (p, q)) end function enclosed_angle_vector3 elemental function enclosed_angle_vector4 (p, q) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p, q theta = enclosed_angle (space_part (p), space_part (q)) end function enclosed_angle_vector4 @ %def enclosed_angle @ The cosine of the enclosed angle. <>= public :: enclosed_angle_ct <>= interface enclosed_angle_ct module procedure enclosed_angle_ct_vector3 module procedure enclosed_angle_ct_vector4 end interface <>= elemental function enclosed_angle_ct_vector3 (p, q) result (ct) real(default) :: ct type(vector3_t), intent(in) :: p, q if (any (abs (p%p) > 0) .and. any (abs (q%p) > 0)) then ct = p*q / (p**1 * q**1) if (ct>1) then ct = 1 else if (ct<-1) then ct = -1 end if else ct = 1 end if end function enclosed_angle_ct_vector3 elemental function enclosed_angle_ct_vector4 (p, q) result (ct) real(default) :: ct type(vector4_t), intent(in) :: p, q ct = enclosed_angle_ct (space_part (p), space_part (q)) end function enclosed_angle_ct_vector4 @ %def enclosed_angle_ct @ The enclosed angle in degrees. <>= public :: enclosed_angle_deg <>= interface enclosed_angle_deg module procedure enclosed_angle_deg_vector3 module procedure enclosed_angle_deg_vector4 end interface <>= elemental function enclosed_angle_deg_vector3 (p, q) result (theta) real(default) :: theta type(vector3_t), intent(in) :: p, q theta = enclosed_angle (p, q) / degree end function enclosed_angle_deg_vector3 elemental function enclosed_angle_deg_vector4 (p, q) result (theta) real(default) :: theta type(vector4_t), intent(in) :: p, q theta = enclosed_angle (p, q) / degree end function enclosed_angle_deg_vector4 @ %def enclosed_angle @ The polar angle of the first momentum w.r.t.\ the second momentum, evaluated in the rest frame of the second momentum. If the second four-momentum is not timelike, return zero. <>= public :: enclosed_angle_rest_frame public :: enclosed_angle_ct_rest_frame public :: enclosed_angle_deg_rest_frame <>= interface enclosed_angle_rest_frame module procedure enclosed_angle_rest_frame_vector4 end interface interface enclosed_angle_ct_rest_frame module procedure enclosed_angle_ct_rest_frame_vector4 end interface interface enclosed_angle_deg_rest_frame module procedure enclosed_angle_deg_rest_frame_vector4 end interface <>= elemental function enclosed_angle_rest_frame_vector4 (p, q) result (theta) type(vector4_t), intent(in) :: p, q real(default) :: theta theta = acos (enclosed_angle_ct_rest_frame (p, q)) end function enclosed_angle_rest_frame_vector4 elemental function enclosed_angle_ct_rest_frame_vector4 (p, q) result (ct) type(vector4_t), intent(in) :: p, q real(default) :: ct if (invariant_mass(q) > 0) then ct = enclosed_angle_ct ( & space_part (boost(-q, invariant_mass (q)) * p), & space_part (q)) else ct = 1 end if end function enclosed_angle_ct_rest_frame_vector4 elemental function enclosed_angle_deg_rest_frame_vector4 (p, q) & result (theta) type(vector4_t), intent(in) :: p, q real(default) :: theta theta = enclosed_angle_rest_frame (p, q) / degree end function enclosed_angle_deg_rest_frame_vector4 @ %def enclosed_angle_rest_frame @ %def enclosed_angle_ct_rest_frame @ %def enclosed_angle_deg_rest_frame @ \subsection{More kinematical functions (some redundant)} The scalar transverse momentum (assuming the $z$ axis is longitudinal) <>= public :: transverse_part <>= interface transverse_part module procedure transverse_part_vector4_beam_axis module procedure transverse_part_vector4_vector4 end interface <>= elemental function transverse_part_vector4_beam_axis (p) result (pT) real(default) :: pT type(vector4_t), intent(in) :: p pT = sqrt(p%p(1)**2 + p%p(2)**2) end function transverse_part_vector4_beam_axis elemental function transverse_part_vector4_vector4 (p1, p2) result (pT) real(default) :: pT type(vector4_t), intent(in) :: p1, p2 real(default) :: p1_norm, p2_norm, p1p2, pT2 p1_norm = space_part_norm(p1)**2 p2_norm = space_part_norm(p2)**2 ! p1p2 = p1%p(1:3)*p2%p(1:3) p1p2 = vector4_get_space_part(p1) * vector4_get_space_part(p2) pT2 = (p1_norm*p2_norm - p1p2)/p1_norm pT = sqrt (pT2) end function transverse_part_vector4_vector4 @ %def transverse_part @ The scalar longitudinal momentum (assuming the $z$ axis is longitudinal). Identical to [[momentum_z_component]]. <>= public :: longitudinal_part <>= interface longitudinal_part module procedure longitudinal_part_vector4 end interface <>= elemental function longitudinal_part_vector4 (p) result (pL) real(default) :: pL type(vector4_t), intent(in) :: p pL = p%p(3) end function longitudinal_part_vector4 @ %def longitudinal_part @ Absolute value of three-momentum <>= public :: space_part_norm <>= interface space_part_norm module procedure space_part_norm_vector4 end interface <>= elemental function space_part_norm_vector4 (p) result (p3) real(default) :: p3 type(vector4_t), intent(in) :: p p3 = sqrt (p%p(1)**2 + p%p(2)**2 + p%p(3)**2) end function space_part_norm_vector4 @ %def momentum @ The energy (the zeroth component) <>= public :: energy <>= interface energy module procedure energy_vector4 module procedure energy_vector3 module procedure energy_real end interface <>= elemental function energy_vector4 (p) result (E) real(default) :: E type(vector4_t), intent(in) :: p E = p%p(0) end function energy_vector4 @ Alternative: The energy corresponding to a given momentum and mass. If the mass is omitted, it is zero <>= elemental function energy_vector3 (p, mass) result (E) real(default) :: E type(vector3_t), intent(in) :: p real(default), intent(in), optional :: mass if (present (mass)) then E = sqrt (p**2 + mass**2) else E = p**1 end if end function energy_vector3 elemental function energy_real (p, mass) result (E) real(default) :: E real(default), intent(in) :: p real(default), intent(in), optional :: mass if (present (mass)) then E = sqrt (p**2 + mass**2) else E = abs (p) end if end function energy_real @ %def energy @ The invariant mass of four-momenta. Zero for lightlike, negative for spacelike momenta. <>= public :: invariant_mass <>= interface invariant_mass module procedure invariant_mass_vector4 end interface <>= elemental function invariant_mass_vector4 (p) result (m) real(default) :: m type(vector4_t), intent(in) :: p real(default) :: msq msq = p*p if (msq >= 0) then m = sqrt (msq) else m = - sqrt (abs (msq)) end if end function invariant_mass_vector4 @ %def invariant_mass @ The invariant mass squared. Zero for lightlike, negative for spacelike momenta. <>= public :: invariant_mass_squared <>= interface invariant_mass_squared module procedure invariant_mass_squared_vector4 end interface <>= elemental function invariant_mass_squared_vector4 (p) result (msq) real(default) :: msq type(vector4_t), intent(in) :: p msq = p*p end function invariant_mass_squared_vector4 @ %def invariant_mass_squared @ The transverse mass. If the mass squared is negative, this value also is negative. <>= public :: transverse_mass <>= interface transverse_mass module procedure transverse_mass_vector4 end interface <>= elemental function transverse_mass_vector4 (p) result (m) real(default) :: m type(vector4_t), intent(in) :: p real(default) :: msq msq = p%p(0)**2 - p%p(1)**2 - p%p(2)**2 if (msq >= 0) then m = sqrt (msq) else m = - sqrt (abs (msq)) end if end function transverse_mass_vector4 @ %def transverse_mass @ The rapidity (defined if particle is massive or $p_\perp>0$) <>= public :: rapidity <>= interface rapidity module procedure rapidity_vector4 end interface <>= elemental function rapidity_vector4 (p) result (y) real(default) :: y type(vector4_t), intent(in) :: p y = .5 * log( (energy (p) + longitudinal_part (p)) & & /(energy (p) - longitudinal_part (p))) end function rapidity_vector4 @ %def rapidity @ The pseudorapidity (defined if $p_\perp>0$) <>= public :: pseudorapidity <>= interface pseudorapidity module procedure pseudorapidity_vector4 end interface <>= elemental function pseudorapidity_vector4 (p) result (eta) real(default) :: eta type(vector4_t), intent(in) :: p eta = -log( tan (.5 * polar_angle (p))) end function pseudorapidity_vector4 @ %def pseudorapidity @ The rapidity distance (defined if both $p_\perp>0$) <>= public :: rapidity_distance <>= interface rapidity_distance module procedure rapidity_distance_vector4 end interface <>= elemental function rapidity_distance_vector4 (p, q) result (dy) type(vector4_t), intent(in) :: p, q real(default) :: dy dy = rapidity (q) - rapidity (p) end function rapidity_distance_vector4 @ %def rapidity_distance @ The pseudorapidity distance (defined if both $p_\perp>0$) <>= public :: pseudorapidity_distance <>= interface pseudorapidity_distance module procedure pseudorapidity_distance_vector4 end interface <>= elemental function pseudorapidity_distance_vector4 (p, q) result (deta) real(default) :: deta type(vector4_t), intent(in) :: p, q deta = pseudorapidity (q) - pseudorapidity (p) end function pseudorapidity_distance_vector4 @ %def pseudorapidity_distance @ The distance on the $\eta-\phi$ cylinder: <>= public :: eta_phi_distance <>= interface eta_phi_distance module procedure eta_phi_distance_vector4 end interface <>= elemental function eta_phi_distance_vector4 (p, q) result (dr) type(vector4_t), intent(in) :: p, q real(default) :: dr dr = sqrt ( & pseudorapidity_distance (p, q)**2 & + azimuthal_distance (p, q)**2) end function eta_phi_distance_vector4 @ %def eta_phi_distance @ \subsection{Lorentz transformations} <>= public :: lorentz_transformation_t <>= type :: lorentz_transformation_t private real(default), dimension(0:3, 0:3) :: L contains <> end type lorentz_transformation_t @ %def lorentz_transformation_t @ Output: <>= public :: lorentz_transformation_write <>= procedure :: write => lorentz_transformation_write <>= subroutine lorentz_transformation_write (L, unit, testflag, ultra) class(lorentz_transformation_t), intent(in) :: L integer, intent(in), optional :: unit logical, intent(in), optional :: testflag, ultra integer :: u, i logical :: ult character(len=7) :: fmt ult = .false.; if (present (ultra)) ult = ultra if (ult) then call pac_fmt (fmt, FMT_19, FMT_11, ultra) else call pac_fmt (fmt, FMT_19, FMT_13, testflag) end if u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A,3(1x," // fmt // "))") "L00 = ", L%L(0,0) write (u, "(1x,A,3(1x," // fmt // "))") "L0j = ", L%L(0,1:3) do i = 1, 3 write (u, "(1x,A,I0,A,3(1x," // fmt // "))") & "L", i, "0 = ", L%L(i,0) write (u, "(1x,A,I0,A,3(1x," // fmt // "))") & "L", i, "j = ", L%L(i,1:3) end do end subroutine lorentz_transformation_write @ %def lorentz_transformation_write @ Extract all components: <>= public :: lorentz_transformation_get_components <>= pure function lorentz_transformation_get_components (L) result (a) type(lorentz_transformation_t), intent(in) :: L real(default), dimension(0:3,0:3) :: a a = L%L end function lorentz_transformation_get_components @ %def lorentz_transformation_get_components @ \subsection{Functions of Lorentz transformations} For the inverse, we make use of the fact that $\Lambda^{\mu\nu}\Lambda_{\mu\rho}=\delta^\nu_\rho$. So, lowering the indices and transposing is sufficient. <>= public :: inverse <>= interface inverse module procedure lorentz_transformation_inverse end interface <>= elemental function lorentz_transformation_inverse (L) result (IL) type(lorentz_transformation_t) :: IL type(lorentz_transformation_t), intent(in) :: L IL%L(0,0) = L%L(0,0) IL%L(0,1:) = -L%L(1:,0) IL%L(1:,0) = -L%L(0,1:) IL%L(1:,1:) = transpose(L%L(1:,1:)) end function lorentz_transformation_inverse @ %def lorentz_transformation_inverse @ %def inverse @ \subsection{Invariants} These are used below. The first array index is varying fastest in [[FORTRAN]]; therefore the extra minus in the odd-rank tensor epsilon. <>= integer, dimension(3,3), parameter :: delta_three = & & reshape( source = [ 1,0,0, 0,1,0, 0,0,1 ], & & shape = [3,3] ) integer, dimension(3,3,3), parameter :: epsilon_three = & & reshape( source = [ 0, 0,0, 0,0,-1, 0,1,0, & & 0, 0,1, 0,0, 0, -1,0,0, & & 0,-1,0, 1,0, 0, 0,0,0 ],& & shape = [3,3,3] ) @ %def delta_three epsilon_three @ This could be of some use: <>= public :: identity <>= type(lorentz_transformation_t), parameter :: & & identity = & & lorentz_transformation_t ( & & reshape( source = [ one, zero, zero, zero, & & zero, one, zero, zero, & & zero, zero, one, zero, & & zero, zero, zero, one ],& & shape = [4,4] ) ) @ %def identity <>= public :: space_reflection <>= type(lorentz_transformation_t), parameter :: & & space_reflection = & & lorentz_transformation_t ( & & reshape( source = [ one, zero, zero, zero, & & zero,-one, zero, zero, & & zero, zero,-one, zero, & & zero, zero, zero,-one ],& & shape = [4,4] ) ) @ %def space_reflection @ Builds a unit vector orthogal to the input vector in the xy-plane. <>= public :: create_orthogonal <>= function create_orthogonal (p_in) result (p_out) type(vector3_t), intent(in) :: p_in type(vector3_t) :: p_out real(default) :: ab ab = sqrt (p_in%p(1)**2 + p_in%p(2)**2) if (abs (ab) < eps0) then p_out%p(1) = 1 p_out%p(2) = 0 p_out%p(3) = 0 else p_out%p(1) = p_in%p(2) p_out%p(2) = -p_in%p(1) p_out%p(3) = 0 p_out = p_out / ab end if end function create_orthogonal @ %def create_orthogonal @ <>= public :: create_unit_vector <>= function create_unit_vector (p_in) result (p_out) type(vector4_t), intent(in) :: p_in type(vector3_t) :: p_out p_out%p = p_in%p(1:3) / space_part_norm (p_in) end function create_unit_vector @ %def create_unit_vector @ <>= public :: normalize <>= function normalize(p) result (p_norm) type(vector3_t) :: p_norm type(vector3_t), intent(in) :: p real(default) :: abs abs = sqrt (p%p(1)**2 + p%p(2)**2 + p%p(3)**2) p_norm = p / abs end function normalize @ %def normalize @ Computes the invariant mass of the momenta sum given by the indices in [[i_res_born]] and the optional argument [[i_emitter]]. <>= public :: compute_resonance_mass <>= pure function compute_resonance_mass (p, i_res_born, i_gluon) result (m) real(default) :: m type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), dimension(:) :: i_res_born integer, intent(in), optional :: i_gluon type(vector4_t) :: p_res p_res = get_resonance_momentum (p, i_res_born, i_gluon) m = p_res**1 end function compute_resonance_mass @ %def compute_resonance_mass @ <>= public :: get_resonance_momentum <>= pure function get_resonance_momentum (p, i_res_born, i_gluon) result (p_res) type(vector4_t) :: p_res type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), dimension(:) :: i_res_born integer, intent(in), optional :: i_gluon integer :: i p_res = vector4_null do i = 1, size (i_res_born) p_res = p_res + p (i_res_born(i)) end do if (present (i_gluon)) p_res = p_res + p (i_gluon) end function get_resonance_momentum @ %def get_resonance_momentum @ <>= public :: create_two_particle_decay <>= function create_two_particle_decay (s, p1, p2) result (p_rest) type(vector4_t), dimension(3) :: p_rest real(default), intent(in) :: s type(vector4_t), intent(in) :: p1, p2 real(default) :: m1_sq, m2_sq real(default) :: E1, E2, p m1_sq = p1**2; m2_sq = p2**2 p = sqrt (lambda (s, m1_sq, m2_sq)) / (two * sqrt (s)) E1 = sqrt (m1_sq + p**2); E2 = sqrt (m2_sq + p**2) p_rest(1)%p = [sqrt (s), zero, zero, zero] p_rest(2)%p(0) = E1 p_rest(2)%p(1:3) = p * p1%p(1:3) / space_part_norm (p1) p_rest(3)%p(0) = E2; p_rest(3)%p(1:3) = -p_rest(2)%p(1:3) end function create_two_particle_decay @ %def create_two_particle_decay @ This function creates a phase-space point for a $1 \to 3$ decay in the decaying particle's rest frame. There are three rest frames for this system, corresponding to $s$-, $t$,- and $u$-channel momentum exchange, also referred to as Gottfried-Jackson frames. Below, we choose the momentum with index 1 to be aligned along the $z$-axis. We then have \begin{align*} s_1 &= \left(p_1 + p_2\right)^2, \\ s_2 &= \left(p_2 + p_3\right)^2, \\ s_3 &= \left(p_1 + p_3\right)^2, \\ s_1 + s_2 + s_3 &= s + m_1^2 + m_2^2 + m_3^2. \end{align*} From these we can construct \begin{align*} E_1^{R23} = \frac{s - s_2 - m_1^2}{2\sqrt{s_2}} &\quad P_1^{R23} = \frac{\lambda^{1/2}(s, s_2, m_1^2)}{2\sqrt{s_2}},\\ E_2^{R23} = \frac{s_2 + m_2^2 - m_3^2}{2\sqrt{s_2}} &\quad P_2^{R23} = \frac{\lambda^{1/2}(s_2, m_2^2, m_3^2)}{2\sqrt{s_2}},\\ E_3^{R23} = \frac{s_2 + m_3^2 - m_2^2}{2\sqrt{s_2}} &\quad P_3^{R23} = P_2^{R23}, \end{align*} where $R23$ denotes the Gottfried-Jackson frame of our choice. Finally, the scattering angle $\theta_{12}^{R23}$ between momentum $1$ and $2$ can be determined to be \begin{equation*} \cos\theta_{12}^{R23} = \frac{(s - s_2 - m_1^2)(s_2 + m_2^2 - m_3^2) + 2s_2 (m_1^2 + m_2^2 - s_1)} {\lambda^{1/2}(s, s_2, m_1^2) \lambda^{1/2}(s_2, m_2^2, m_3^2)} \end{equation*} <>= public :: create_three_particle_decay <>= function create_three_particle_decay (p1, p2, p3) result (p_rest) type(vector4_t), dimension(4) :: p_rest type(vector4_t), intent(in) :: p1, p2, p3 real(default) :: E1, E2, E3 real(default) :: pr1, pr2, pr3 real(default) :: s, s1, s2, s3 real(default) :: m1_sq, m2_sq, m3_sq real(default) :: cos_theta_12 type(vector3_t) :: v3_unit type(lorentz_transformation_t) :: rot m1_sq = p1**2 m2_sq = p2**2 m3_sq = p3**2 s1 = (p1 + p2)**2 s2 = (p2 + p3)**2 s3 = (p3 + p1)**2 s = s1 + s2 + s3 - m1_sq - m2_sq - m3_sq E1 = (s - s2 - m1_sq) / (two * sqrt (s2)) E2 = (s2 + m2_sq - m3_sq) / (two * sqrt (s2)) E3 = (s2 + m3_sq - m2_sq) / (two * sqrt (s2)) pr1 = sqrt (lambda (s, s2, m1_sq)) / (two * sqrt (s2)) pr2 = sqrt (lambda (s2, m2_sq, m3_sq)) / (two * sqrt(s2)) pr3 = pr2 cos_theta_12 = ((s - s2 - m1_sq) * (s2 + m2_sq - m3_sq) + two * s2 * (m1_sq + m2_sq - s1)) / & sqrt (lambda (s, s2, m1_sq) * lambda (s2, m2_sq, m3_sq)) v3_unit%p = [zero, zero, one] p_rest(1)%p(0) = E1 p_rest(1)%p(1:3) = v3_unit%p * pr1 p_rest(2)%p(0) = E2 p_rest(2)%p(1:3) = v3_unit%p * pr2 p_rest(3)%p(0) = E3 p_rest(3)%p(1:3) = v3_unit%p * pr3 p_rest(4)%p(0) = (s + s2 - m1_sq) / (2 * sqrt (s2)) p_rest(4)%p(1:3) = - p_rest(1)%p(1:3) rot = rotation (cos_theta_12, sqrt (one - cos_theta_12**2), 2) p_rest(2) = rot * p_rest(2) p_rest(3)%p(1:3) = - p_rest(2)%p(1:3) end function create_three_particle_decay @ %def create_three_particle_decay @ <>= public :: evaluate_one_to_two_splitting_special <>= abstract interface subroutine evaluate_one_to_two_splitting_special (p_origin, & p1_in, p2_in, p1_out, p2_out, msq_in, jac) import type(vector4_t), intent(in) :: p_origin type(vector4_t), intent(in) :: p1_in, p2_in type(vector4_t), intent(inout) :: p1_out, p2_out real(default), intent(in), optional :: msq_in real(default), intent(inout), optional :: jac end subroutine evaluate_one_to_two_splitting_special end interface @ %def evaluate_one_to_two_splitting_special @ <>= public :: generate_on_shell_decay <>= recursive subroutine generate_on_shell_decay (p_dec, & p_in, p_out, i_real, msq_in, jac, evaluate_special) type(vector4_t), intent(in) :: p_dec type(vector4_t), intent(in), dimension(:) :: p_in type(vector4_t), intent(inout), dimension(:) :: p_out integer, intent(in) :: i_real real(default), intent(in), optional :: msq_in real(default), intent(inout), optional :: jac procedure(evaluate_one_to_two_splitting_special), intent(in), & pointer, optional :: evaluate_special type(vector4_t) :: p_dec_new integer :: n_recoil n_recoil = size (p_in) - 1 if (n_recoil > 1) then if (present (evaluate_special)) then call evaluate_special (p_dec, p_in(1), sum (p_in (2 : n_recoil + 1)), & p_out(i_real), p_dec_new) call generate_on_shell_decay (p_dec_new, p_in (2 : ), p_out, & i_real + 1, msq_in, jac, evaluate_special) else call evaluate_one_to_two_splitting (p_dec, p_in(1), & sum (p_in (2 : n_recoil + 1)), p_out(i_real), p_dec_new, msq_in, jac) call generate_on_shell_decay (p_dec_new, p_in (2 : ), p_out, & i_real + 1, msq_in, jac) end if else call evaluate_one_to_two_splitting (p_dec, p_in(1), p_in(2), & p_out(i_real), p_out(i_real + 1), msq_in, jac) end if end subroutine generate_on_shell_decay subroutine evaluate_one_to_two_splitting (p_origin, & p1_in, p2_in, p1_out, p2_out, msq_in, jac) type(vector4_t), intent(in) :: p_origin type(vector4_t), intent(in) :: p1_in, p2_in type(vector4_t), intent(inout) :: p1_out, p2_out real(default), intent(in), optional :: msq_in real(default), intent(inout), optional :: jac type(lorentz_transformation_t) :: L type(vector4_t) :: p1_rest, p2_rest real(default) :: m, msq, msq1, msq2 real(default) :: E1, E2, p real(default) :: lda, rlda_soft call get_rest_frame (p1_in, p2_in, p1_rest, p2_rest) msq = p_origin**2; m = sqrt(msq) msq1 = p1_in**2; msq2 = p2_in**2 lda = lambda (msq, msq1, msq2) if (lda < zero) then print *, 'Encountered lambda < 0 in 1 -> 2 splitting! ' print *, 'lda: ', lda print *, 'm: ', m, 'msq: ', msq print *, 'm1: ', sqrt (msq1), 'msq1: ', msq1 print *, 'm2: ', sqrt (msq2), 'msq2: ', msq2 stop end if p = sqrt (lda) / (two * m) E1 = sqrt (msq1 + p**2) E2 = sqrt (msq2 + p**2) p1_out = shift_momentum (p1_rest, E1, p) p2_out = shift_momentum (p2_rest, E2, p) L = boost (p_origin, p_origin**1) p1_out = L * p1_out p2_out = L * p2_out if (present (jac) .and. present (msq_in)) then jac = jac * sqrt(lda) / msq rlda_soft = sqrt (lambda (msq_in, msq1, msq2)) !!! We have to undo the Jacobian which has already been !!! supplied by the Born phase space. jac = jac * msq_in / rlda_soft end if contains subroutine get_rest_frame (p1_in, p2_in, p1_out, p2_out) type(vector4_t), intent(in) :: p1_in, p2_in type(vector4_t), intent(out) :: p1_out, p2_out type(lorentz_transformation_t) :: L L = inverse (boost (p1_in + p2_in, (p1_in + p2_in)**1)) p1_out = L * p1_in; p2_out = L * p2_in end subroutine get_rest_frame function shift_momentum (p_in, E, p) result (p_out) type(vector4_t) :: p_out type(vector4_t), intent(in) :: p_in real(default), intent(in) :: E, p type(vector3_t) :: vec vec = p_in%p(1:3) / space_part_norm (p_in) p_out = vector4_moving (E, p * vec) end function shift_momentum end subroutine evaluate_one_to_two_splitting @ %def generate_on_shell_decay @ \subsection{Boosts} We build Lorentz transformations from boosts and rotations. In both cases we can supply a three-vector which defines the axis and (hyperbolic) angle. For a boost, this is the vector $\vec\beta=\vec p/E$, such that a particle at rest with mass $m$ is boosted to a particle with three-vector $\vec p$. Here, we have \begin{equation} \beta = \tanh\chi = p/E, \qquad \gamma = \cosh\chi = E/m, \qquad \beta\gamma = \sinh\chi = p/m \end{equation} <>= public :: boost <>= interface boost module procedure boost_from_rest_frame module procedure boost_from_rest_frame_vector3 module procedure boost_generic module procedure boost_canonical end interface @ %def boost @ In the first form, the argument is some four-momentum, the space part of which determines a direction, and the associated mass (which is not checked against the four-momentum). The boost vector $\gamma\vec\beta$ is then given by $\vec p/m$. This boosts from the rest frame of a particle to the current frame. To be explicit, if $\vec p$ is the momentum of a particle and $m$ its mass, $L(\vec p/m)$ is the transformation that turns $(m;\vec 0)$ into $(E;\vec p)$. Conversely, the inverse transformation boosts a vector \emph{into} the rest frame of a particle, in particular $(E;\vec p)$ into $(m;\vec 0)$. <>= elemental function boost_from_rest_frame (p, m) result (L) type(lorentz_transformation_t) :: L type(vector4_t), intent(in) :: p real(default), intent(in) :: m L = boost_from_rest_frame_vector3 (space_part (p), m) end function boost_from_rest_frame elemental function boost_from_rest_frame_vector3 (p, m) result (L) type(lorentz_transformation_t) :: L type(vector3_t), intent(in) :: p real(default), intent(in) :: m type(vector3_t) :: beta_gamma real(default) :: bg2, g, c integer :: i,j if (m > eps0) then beta_gamma = p / m bg2 = beta_gamma**2 else bg2 = 0 L = identity return end if if (bg2 > eps0) then g = sqrt(1 + bg2); c = (g-1)/bg2 else g = one + bg2 / two c = one / two end if L%L(0,0) = g L%L(0,1:) = beta_gamma%p L%L(1:,0) = L%L(0,1:) do i=1,3 do j=1,3 L%L(i,j) = delta_three(i,j) + c*beta_gamma%p(i)*beta_gamma%p(j) end do end do end function boost_from_rest_frame_vector3 @ %def boost_from_rest_frame @ A canonical boost is a boost along one of the coordinate axes, which we may supply as an integer argument. Here, $\gamma\beta$ is scalar. <>= elemental function boost_canonical (beta_gamma, k) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: beta_gamma integer, intent(in) :: k real(default) :: g g = sqrt(1 + beta_gamma**2) L = identity L%L(0,0) = g L%L(0,k) = beta_gamma L%L(k,0) = L%L(0,k) L%L(k,k) = L%L(0,0) end function boost_canonical @ %def boost_canonical @ Instead of a canonical axis, we can supply an arbitrary axis which need not be normalized. If it is zero, return the unit matrix. <>= elemental function boost_generic (beta_gamma, axis) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: beta_gamma type(vector3_t), intent(in) :: axis if (any (abs (axis%p) > 0)) then L = boost_from_rest_frame_vector3 (beta_gamma * axis, axis**1) else L = identity end if end function boost_generic @ %def boost_generic @ \subsection{Rotations} For a rotation, the vector defines the rotation axis, and its length the rotation angle. <>= public :: rotation <>= interface rotation module procedure rotation_generic module procedure rotation_canonical module procedure rotation_generic_cs module procedure rotation_canonical_cs end interface @ %def rotation @ If $\cos\phi$ and $\sin\phi$ is already known, we do not have to calculate them. Of course, the user has to ensure that $\cos^2\phi+\sin^2\phi=1$, and that the given axis [[n]] is normalized to one. In the second form, the length of [[axis]] is the rotation angle. <>= elemental function rotation_generic_cs (cp, sp, axis) result (R) type(lorentz_transformation_t) :: R real(default), intent(in) :: cp, sp type(vector3_t), intent(in) :: axis integer :: i,j R = identity do i=1,3 do j=1,3 R%L(i,j) = cp*delta_three(i,j) + (1-cp)*axis%p(i)*axis%p(j) & & - sp*dot_product(epsilon_three(i,j,:), axis%p) end do end do end function rotation_generic_cs elemental function rotation_generic (axis) result (R) type(lorentz_transformation_t) :: R type(vector3_t), intent(in) :: axis real(default) :: phi if (any (abs(axis%p) > 0)) then phi = abs(axis**1) R = rotation_generic_cs (cos(phi), sin(phi), axis/phi) else R = identity end if end function rotation_generic @ %def rotation_generic_cs rotation_generic @ Alternatively, give just the angle and label the coordinate axis by an integer. <>= elemental function rotation_canonical_cs (cp, sp, k) result (R) type(lorentz_transformation_t) :: R real(default), intent(in) :: cp, sp integer, intent(in) :: k integer :: i,j R = identity do i=1,3 do j=1,3 R%L(i,j) = -sp*epsilon_three(i,j,k) end do R%L(i,i) = cp end do R%L(k,k) = 1 end function rotation_canonical_cs elemental function rotation_canonical (phi, k) result (R) type(lorentz_transformation_t) :: R real(default), intent(in) :: phi integer, intent(in) :: k R = rotation_canonical_cs(cos(phi), sin(phi), k) end function rotation_canonical @ %def rotation_canonical_cs rotation_canonical @ This is viewed as a method for the first argument (three-vector): Reconstruct the rotation that rotates it into the second three-vector. <>= public :: rotation_to_2nd <>= interface rotation_to_2nd module procedure rotation_to_2nd_generic module procedure rotation_to_2nd_canonical end interface <>= elemental function rotation_to_2nd_generic (p, q) result (R) type(lorentz_transformation_t) :: R type(vector3_t), intent(in) :: p, q type(vector3_t) :: a, b, ab real(default) :: ct, st if (any (abs (p%p) > 0) .and. any (abs (q%p) > 0)) then a = direction (p) b = direction (q) ab = cross_product(a,b) ct = a * b; st = ab**1 if (abs(st) > eps0) then R = rotation_generic_cs (ct, st, ab / st) else if (ct < 0) then R = space_reflection else R = identity end if else R = identity end if end function rotation_to_2nd_generic @ %def rotation_to_2nd_generic @ The same for a canonical axis: The function returns the transformation that rotates the $k$-axis into the direction of $p$. <>= elemental function rotation_to_2nd_canonical (k, p) result (R) type(lorentz_transformation_t) :: R integer, intent(in) :: k type(vector3_t), intent(in) :: p type(vector3_t) :: b, ab real(default) :: ct, st integer :: i, j if (any (abs (p%p) > 0)) then b = direction (p) ab%p = 0 do i = 1, 3 do j = 1, 3 ab%p(j) = ab%p(j) + b%p(i) * epsilon_three(i,j,k) end do end do ct = b%p(k); st = ab**1 if (abs(st) > eps0) then R = rotation_generic_cs (ct, st, ab / st) else if (ct < 0) then R = space_reflection else R = identity end if else R = identity end if end function rotation_to_2nd_canonical @ %def rotation_to_2nd_canonical @ \subsection{Composite Lorentz transformations} This function returns the transformation that, given a pair of vectors $p_{1,2}$, (a) boosts from the rest frame of the c.m. system (with invariant mass $m$) into the lab frame where $p_i$ are defined, and (b) turns the given axis (or the canonical vectors $\pm e_k$) in the rest frame into the directions of $p_{1,2}$ in the lab frame. Note that the energy components are not used; for a consistent result one should have $(p_1+p_2)^2 = m^2$. <>= public :: transformation <>= interface transformation module procedure transformation_rec_generic module procedure transformation_rec_canonical end interface @ %def transformation <>= elemental function transformation_rec_generic (axis, p1, p2, m) result (L) type(vector3_t), intent(in) :: axis type(vector4_t), intent(in) :: p1, p2 real(default), intent(in) :: m type(lorentz_transformation_t) :: L L = boost (p1 + p2, m) L = L * rotation_to_2nd (axis, space_part (inverse (L) * p1)) end function transformation_rec_generic elemental function transformation_rec_canonical (k, p1, p2, m) result (L) integer, intent(in) :: k type(vector4_t), intent(in) :: p1, p2 real(default), intent(in) :: m type(lorentz_transformation_t) :: L L = boost (p1 + p2, m) L = L * rotation_to_2nd (k, space_part (inverse (L) * p1)) end function transformation_rec_canonical @ %def transformation_rec_generic transformation_rec_canonical @ \subsection{Applying Lorentz transformations} Multiplying vectors and Lorentz transformations is straightforward. <>= interface operator(*) module procedure prod_LT_vector4 module procedure prod_LT_LT module procedure prod_vector4_LT end interface <>= elemental function prod_LT_vector4 (L, p) result (np) type(vector4_t) :: np type(lorentz_transformation_t), intent(in) :: L type(vector4_t), intent(in) :: p np%p = matmul (L%L, p%p) end function prod_LT_vector4 elemental function prod_LT_LT (L1, L2) result (NL) type(lorentz_transformation_t) :: NL type(lorentz_transformation_t), intent(in) :: L1,L2 NL%L = matmul (L1%L, L2%L) end function prod_LT_LT elemental function prod_vector4_LT (p, L) result (np) type(vector4_t) :: np type(vector4_t), intent(in) :: p type(lorentz_transformation_t), intent(in) :: L np%p = matmul (p%p, L%L) end function prod_vector4_LT @ %def * @ \subsection{Special Lorentz transformations} These routines have their application in the generation and extraction of angles in the phase-space sampling routine. Since this part of the program is time-critical, we calculate the composition of transformations directly instead of multiplying rotations and boosts. This Lorentz transformation is the composition of a rotation by $\phi$ around the $3$ axis, a rotation by $\theta$ around the $2$ axis, and a boost along the $3$ axis: \begin{equation} L = B_3(\beta\gamma)\,R_2(\theta)\,R_3(\phi) \end{equation} Instead of the angles we provide sine and cosine. <>= public :: LT_compose_r3_r2_b3 <>= elemental function LT_compose_r3_r2_b3 & (cp, sp, ct, st, beta_gamma) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: cp, sp, ct, st, beta_gamma real(default) :: gamma if (abs(beta_gamma) < eps0) then L%L(0,0) = 1 L%L(1:,0) = 0 L%L(0,1:) = 0 L%L(1,1:) = [ ct*cp, -ct*sp, st ] L%L(2,1:) = [ sp, cp, zero ] L%L(3,1:) = [ -st*cp, st*sp, ct ] else gamma = sqrt(1 + beta_gamma**2) L%L(0,0) = gamma L%L(1,0) = 0 L%L(2,0) = 0 L%L(3,0) = beta_gamma L%L(0,1:) = beta_gamma * [ -st*cp, st*sp, ct ] L%L(1,1:) = [ ct*cp, -ct*sp, st ] L%L(2,1:) = [ sp, cp, zero ] L%L(3,1:) = gamma * [ -st*cp, st*sp, ct ] end if end function LT_compose_r3_r2_b3 @ %def LT_compose_r3_r2_b3 @ Different ordering: \begin{equation} L = B_3(\beta\gamma)\,R_3(\phi)\,R_2(\theta) \end{equation} <>= public :: LT_compose_r2_r3_b3 <>= elemental function LT_compose_r2_r3_b3 & (ct, st, cp, sp, beta_gamma) result (L) type(lorentz_transformation_t) :: L real(default), intent(in) :: ct, st, cp, sp, beta_gamma real(default) :: gamma if (abs(beta_gamma) < eps0) then L%L(0,0) = 1 L%L(1:,0) = 0 L%L(0,1:) = 0 L%L(1,1:) = [ ct*cp, -sp, st*cp ] L%L(2,1:) = [ ct*sp, cp, st*sp ] L%L(3,1:) = [ -st , zero, ct ] else gamma = sqrt(1 + beta_gamma**2) L%L(0,0) = gamma L%L(1,0) = 0 L%L(2,0) = 0 L%L(3,0) = beta_gamma L%L(0,1:) = beta_gamma * [ -st , zero, ct ] L%L(1,1:) = [ ct*cp, -sp, st*cp ] L%L(2,1:) = [ ct*sp, cp, st*sp ] L%L(3,1:) = gamma * [ -st , zero, ct ] end if end function LT_compose_r2_r3_b3 @ %def LT_compose_r2_r3_b3 @ This function returns the previous Lorentz transformation applied to an arbitrary four-momentum and extracts the space part of the result: \begin{equation} \vec n = [B_3(\beta\gamma)\,R_2(\theta)\,R_3(\phi)\,p]_{\rm space\ part} \end{equation} The second variant applies if there is no rotation <>= public :: axis_from_p_r3_r2_b3, axis_from_p_b3 <>= elemental function axis_from_p_r3_r2_b3 & (p, cp, sp, ct, st, beta_gamma) result (n) type(vector3_t) :: n type(vector4_t), intent(in) :: p real(default), intent(in) :: cp, sp, ct, st, beta_gamma real(default) :: gamma, px, py px = cp * p%p(1) - sp * p%p(2) py = sp * p%p(1) + cp * p%p(2) n%p(1) = ct * px + st * p%p(3) n%p(2) = py n%p(3) = -st * px + ct * p%p(3) if (abs(beta_gamma) > eps0) then gamma = sqrt(1 + beta_gamma**2) n%p(3) = n%p(3) * gamma + p%p(0) * beta_gamma end if end function axis_from_p_r3_r2_b3 elemental function axis_from_p_b3 (p, beta_gamma) result (n) type(vector3_t) :: n type(vector4_t), intent(in) :: p real(default), intent(in) :: beta_gamma real(default) :: gamma n%p = p%p(1:3) if (abs(beta_gamma) > eps0) then gamma = sqrt(1 + beta_gamma**2) n%p(3) = n%p(3) * gamma + p%p(0) * beta_gamma end if end function axis_from_p_b3 @ %def axis_from_p_r3_r2_b3 axis_from_p_b3 @ \subsection{Special functions} The K\"all\'en function, mostly used for the phase space. This is equivalent to $\lambda(x,y,z)=x^2+y^2+z^2-2xy-2xz-2yz$. <>= public :: lambda <>= elemental function lambda (m1sq, m2sq, m3sq) real(default) :: lambda real(default), intent(in) :: m1sq, m2sq, m3sq lambda = (m1sq - m2sq - m3sq)**2 - 4*m2sq*m3sq end function lambda @ %def lambda @ Return a pair of head-to-head colliding momenta, given the collider energy, particle masses, and optionally the momentum of the c.m. system. <>= public :: colliding_momenta <>= function colliding_momenta (sqrts, m, p_cm) result (p) type(vector4_t), dimension(2) :: p real(default), intent(in) :: sqrts real(default), dimension(2), intent(in), optional :: m real(default), intent(in), optional :: p_cm real(default), dimension(2) :: dmsq real(default) :: ch, sh real(default), dimension(2) :: E0, p0 integer, dimension(2), parameter :: sgn = [1, -1] if (abs(sqrts) < eps0) then call msg_fatal (" Colliding beams: sqrts is zero (please set sqrts)") p = vector4_null; return else if (sqrts <= 0) then call msg_fatal (" Colliding beams: sqrts is negative") p = vector4_null; return end if if (present (m)) then dmsq = sgn * (m(1)**2-m(2)**2) E0 = (sqrts + dmsq/sqrts) / 2 if (any (E0 < m)) then call msg_fatal & (" Colliding beams: beam energy is less than particle mass") p = vector4_null; return end if p0 = sgn * sqrt (E0**2 - m**2) else E0 = sqrts / 2 p0 = sgn * E0 end if if (present (p_cm)) then sh = p_cm / sqrts ch = sqrt (1 + sh**2) p = vector4_moving (E0 * ch + p0 * sh, E0 * sh + p0 * ch, 3) else p = vector4_moving (E0, p0, 3) end if end function colliding_momenta @ %def colliding_momenta @ This subroutine is for the purpose of numerical checks and comparisons. The idea is to set a number to zero if it is numerically equivalent with zero. The equivalence is established by comparing with a [[tolerance]] argument. We implement this for vectors and transformations. <>= public :: pacify <>= interface pacify module procedure pacify_vector3 module procedure pacify_vector4 module procedure pacify_LT end interface pacify <>= elemental subroutine pacify_vector3 (p, tolerance) type(vector3_t), intent(inout) :: p real(default), intent(in) :: tolerance where (abs (p%p) < tolerance) p%p = zero end subroutine pacify_vector3 elemental subroutine pacify_vector4 (p, tolerance) type(vector4_t), intent(inout) :: p real(default), intent(in) :: tolerance where (abs (p%p) < tolerance) p%p = zero end subroutine pacify_vector4 elemental subroutine pacify_LT (LT, tolerance) type(lorentz_transformation_t), intent(inout) :: LT real(default), intent(in) :: tolerance where (abs (LT%L) < tolerance) LT%L = zero end subroutine pacify_LT @ %def pacify @ <>= public :: vector_set_reshuffle <>= subroutine vector_set_reshuffle (p1, list, p2) type(vector4_t), intent(in), dimension(:), allocatable :: p1 integer, intent(in), dimension(:), allocatable :: list type(vector4_t), intent(out), dimension(:), allocatable :: p2 integer :: n, n_p n_p = size (p1) if (size (list) /= n_p) return allocate (p2 (n_p)) do n = 1, n_p p2(n) = p1(list(n)) end do end subroutine vector_set_reshuffle @ %def vector_set_reshuffle @ <>= public :: vector_set_is_cms <>= function vector_set_is_cms (p, n_in) result (is_cms) logical :: is_cms type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: n_in integer :: i type(vector4_t) :: p_sum p_sum%p = 0._default do i = 1, n_in p_sum = p_sum + p(i) end do is_cms = all (abs (p_sum%p(1:3)) < tiny_07) end function vector_set_is_cms @ %def vector_set_is_cms @ <>= public :: vector_set_is_lab <>= function vector_set_is_lab (p, n_in) result (is_lab) logical :: is_lab type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: n_in is_lab = .not. vector_set_is_cms (p, n_in) end function vector_set_is_lab @ %def vector_set_is_lab @ <>= public :: vector4_write_set <>= subroutine vector4_write_set (p, unit, show_mass, testflag, & check_conservation, ultra, n_in) type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), optional :: unit logical, intent(in), optional :: show_mass logical, intent(in), optional :: testflag, ultra logical, intent(in), optional :: check_conservation integer, intent(in), optional :: n_in logical :: extreme integer :: i, j real(default), dimension(0:3) :: p_tot character(len=7) :: fmt integer :: u logical :: yorn, is_test integer :: n extreme = .false.; if (present (ultra)) extreme = ultra is_test = .false.; if (present (testflag)) is_test = testflag u = given_output_unit (unit); if (u < 0) return n = 2; if (present (n_in)) n = n_in p_tot = 0 yorn = .false.; if (present (check_conservation)) yorn = check_conservation do i = 1, size (p) if (yorn .and. i > n) then forall (j=0:3) p_tot(j) = p_tot(j) - p(i)%p(j) else forall (j=0:3) p_tot(j) = p_tot(j) + p(i)%p(j) end if call vector4_write (p(i), u, show_mass=show_mass, & testflag=testflag, ultra=ultra) end do if (extreme) then call pac_fmt (fmt, FMT_19, FMT_11, testflag) else call pac_fmt (fmt, FMT_19, FMT_15, testflag) end if if (is_test) call pacify (p_tot, 1.E-9_default) if (.not. is_test) then write (u, "(A5)") 'Total: ' write (u, "(1x,A,1x," // fmt // ")") "E = ", p_tot(0) write (u, "(1x,A,3(1x," // fmt // "))") "P = ", p_tot(1:) end if end subroutine vector4_write_set @ %def vector4_write_set @ <>= public :: vector4_check_momentum_conservation <>= subroutine vector4_check_momentum_conservation (p, n_in, unit, & abs_smallness, rel_smallness, verbose) type(vector4_t), dimension(:), intent(in) :: p integer, intent(in) :: n_in integer, intent(in), optional :: unit real(default), intent(in), optional :: abs_smallness, rel_smallness logical, intent(in), optional :: verbose integer :: u, i type(vector4_t) :: psum_in, psum_out logical, dimension(0:3) :: p_diff logical :: verb u = given_output_unit (unit); if (u < 0) return verb = .false.; if (present (verbose)) verb = verbose psum_in = vector4_null do i = 1, n_in psum_in = psum_in + p(i) end do psum_out = vector4_null do i = n_in + 1, size (p) psum_out = psum_out + p(i) end do !!! !!! !!! Workaround for gfortran-4.8.4 bug do i = 0, 3 p_diff(i) = vanishes (psum_in%p(i) - psum_out%p(i), & abs_smallness = abs_smallness, rel_smallness = rel_smallness) end do if (.not. all (p_diff)) then call msg_warning ("Momentum conservation: FAIL", unit = u) if (verb) then write (u, "(A)") "Incoming:" call vector4_write (psum_in, u) write (u, "(A)") "Outgoing:" call vector4_write (psum_out, u) end if else if (verb) then write (u, "(A)") "Momentum conservation: CHECK" end if end if end subroutine vector4_check_momentum_conservation @ %def vector4_check_momentum_conservation @ This computes the quantities \begin{align*} \langle ij \rangle &= \sqrt{|S_{ij}|} e^{i\phi_{ij}}, [ij] &= \sqrt{|S_{ij}|} e^{\i\tilde{\phi}_{ij}}, \end{align*} with $S_{ij} = \left(p_i + p_j\right)^2$. The phase space factor $\phi_{ij}$ is determined by \begin{align*} \cos\phi_{ij} &= \frac{p_i^1p_j^+ - p_j^1p_i^+}{\sqrt{p_i^+p_j^+S_{ij}}}, \sin\phi_{ij} &= \frac{p_i^2p_j^+ - p_j^2p_i^+}{\sqrt{p_i^+p_j^+S_{ij}}}. \end{align*} After $\langle ij \rangle$ has been computed according to these formulae, $[ij]$ can be obtained by using the relation $S_{ij} = \langle ij \rangle [ji]$ and taking into account that $[ij] = -[ji]$. Thus, a minus-sign has to be applied. <>= public :: spinor_product <>= subroutine spinor_product (p1, p2, prod1, prod2) type(vector4_t), intent(in) :: p1, p2 complex(default), intent(out) :: prod1, prod2 real(default) :: sij complex(default) :: phase real(default) :: pp_1, pp_2 pp_1 = p1%p(0) + p1%p(3) pp_2 = p2%p(0) + p2%p(3) sij = (p1+p2)**2 phase = cmplx ((p1%p(1)*pp_2 - p2%p(1)*pp_1)/sqrt (sij*pp_1*pp_2), & (p1%p(2)*pp_2 - p2%p(2)*pp_1)/sqrt (sij*pp_1*pp_2), & default) !!! prod1 = sqrt (sij) * phase !!! [ij] if (abs(prod1) > 0) then prod2 = - sij / prod1 else prod2 = 0 end if end subroutine spinor_product @ %def spinor_product @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Special Physics functions} Here, we declare functions that are specific for the Standard Model, including QCD: fixed and running $\alpha_s$, Catani-Seymour dipole terms, loop functions, etc. To make maximum use of this, all functions, if possible, are declared elemental (or pure, if this is not possible). <<[[sm_physics.f90]]>>= <> module sm_physics <> use io_units use constants use numeric_utils use diagnostics use physics_defs use lorentz <> <> <> contains <> end module sm_physics @ %def sm_physics @ \subsection{Running $\alpha_s$} @ Then we define the coefficients of the beta function of QCD (as a reference cf. the Particle Data Group), where $n_f$ is the number of active flavors in two different schemes: \begin{align} \beta_0 &=\; 11 - \frac23 n_f \\ \beta_1 &=\; 51 - \frac{19}{3} n_f \\ \beta_2 &=\; 2857 - \frac{5033}{9} n_f + \frac{325}{27} n_f^2 \end{align} \begin{align} b_0 &=\; \frac{1}{12 \pi} \left( 11 C_A - 2 n_f \right) \\ b_1 &=\; \frac{1}{24 \pi^2} \left( 17 C_A^2 - 5 C_A n_f - 3 C_F n_f \right) \\ b_2 &=\; \frac{1}{(4\pi)^3} \biggl( \frac{2857}{54} C_A^3 - \frac{1415}{54} * C_A^2 n_f - \frac{205}{18} C_A C_F n_f + C_F^2 n_f + \frac{79}{54} C_A n_f**2 + \frac{11}{9} C_F n_f**2 \biggr) \end{align} <>= public :: beta0, beta1, beta2, coeff_b0, coeff_b1, coeff_b2 <>= pure function beta0 (nf) real(default), intent(in) :: nf real(default) :: beta0 beta0 = 11.0_default - two/three * nf end function beta0 pure function beta1 (nf) real(default), intent(in) :: nf real(default) :: beta1 beta1 = 51.0_default - 19.0_default/three * nf end function beta1 pure function beta2 (nf) real(default), intent(in) :: nf real(default) :: beta2 beta2 = 2857.0_default - 5033.0_default / 9.0_default * & nf + 325.0_default/27.0_default * nf**2 end function beta2 pure function coeff_b0 (nf) real(default), intent(in) :: nf real(default) :: coeff_b0 coeff_b0 = (11.0_default * CA - two * nf) / (12.0_default * pi) end function coeff_b0 pure function coeff_b1 (nf) real(default), intent(in) :: nf real(default) :: coeff_b1 coeff_b1 = (17.0_default * CA**2 - five * CA * nf - three * CF * nf) / & (24.0_default * pi**2) end function coeff_b1 pure function coeff_b2 (nf) real(default), intent(in) :: nf real(default) :: coeff_b2 coeff_b2 = (2857.0_default/54.0_default * CA**3 - & 1415.0_default/54.0_default * & CA**2 * nf - 205.0_default/18.0_default * CA*CF*nf & + 79.0_default/54.0_default * CA*nf**2 + & 11.0_default/9.0_default * CF * nf**2) / (four*pi)**3 end function coeff_b2 @ %def beta0 beta1 beta2 @ %def coeff_b0 coeff_b1 coeff_b2 @ There should be two versions of running $\alpha_s$, one which takes the scale and $\Lambda_{\text{QCD}}$ as input, and one which takes the scale and e.g. $\alpha_s(m_Z)$ as input. Here, we take the one which takes the QCD scale and scale as inputs from the PDG book. <>= public :: running_as, running_as_lam <>= pure function running_as (scale, al_mz, mz, order, nf) result (ascale) real(default), intent(in) :: scale real(default), intent(in), optional :: al_mz, nf, mz integer, intent(in), optional :: order integer :: ord real(default) :: az, m_z, as_log, n_f, b0, b1, b2, ascale real(default) :: as0, as1 if (present (mz)) then m_z = mz else m_z = MZ_REF end if if (present (order)) then ord = order else ord = 0 end if if (present (al_mz)) then az = al_mz else az = ALPHA_QCD_MZ_REF end if if (present (nf)) then n_f = nf else n_f = 5 end if b0 = coeff_b0 (n_f) b1 = coeff_b1 (n_f) b2 = coeff_b2 (n_f) as_log = one + b0 * az * log(scale**2/m_z**2) as0 = az / as_log as1 = as0 - as0**2 * b1/b0 * log(as_log) select case (ord) case (0) ascale = as0 case (1) ascale = as1 case (2) ascale = as1 + as0**3 * (b1**2/b0**2 * ((log(as_log))**2 - & log(as_log) + as_log - one) - b2/b0 * (as_log - one)) case default ascale = as0 end select end function running_as pure function running_as_lam (nf, scale, lambda, order) result (ascale) real(default), intent(in) :: nf, scale real(default), intent(in), optional :: lambda integer, intent(in), optional :: order real(default) :: lambda_qcd real(default) :: as0, as1, logmul, b0, b1, b2, ascale integer :: ord if (present (lambda)) then lambda_qcd = lambda else lambda_qcd = LAMBDA_QCD_REF end if if (present (order)) then ord = order else ord = 0 end if b0 = beta0(nf) logmul = log(scale**2/lambda_qcd**2) as0 = four*pi / b0 / logmul if (ord > 0) then b1 = beta1(nf) as1 = as0 * (one - two* b1 / b0**2 * log(logmul) / logmul) end if select case (ord) case (0) ascale = as0 case (1) ascale = as1 case (2) b2 = beta2(nf) ascale = as1 + as0 * four * b1**2/b0**4/logmul**2 * & ((log(logmul) - 0.5_default)**2 + & b2*b0/8.0_default/b1**2 - five/four) case default ascale = as0 end select end function running_as_lam @ %def running_as @ %def running_as_lam @ \subsection{Catani-Seymour Parameters} These are fundamental constants of the Catani-Seymour dipole formalism. Since the corresponding parameters for the gluon case depend on the number of flavors which is treated as an argument, there we do have functions and not parameters. \begin{equation} \gamma_q = \gamma_{\bar q} = \frac{3}{2} C_F \qquad \gamma_g = \frac{11}{6} C_A - \frac{2}{3} T_R N_f \end{equation} \begin{equation} K_q = K_{\bar q} = \left( \frac{7}{2} - \frac{\pi^2}{6} \right) C_F \qquad K_g = \left( \frac{67}{18} - \frac{\pi^2}{6} \right) C_A - \frac{10}{9} T_R N_f \end{equation} <>= real(kind=default), parameter, public :: gamma_q = three/two * CF, & k_q = (7.0_default/two - pi**2/6.0_default) * CF @ %def gamma_q @ <>= public :: gamma_g, k_g <>= elemental function gamma_g (nf) result (gg) real(kind=default), intent(in) :: nf real(kind=default) :: gg gg = 11.0_default/6.0_default * CA - two/three * TR * nf end function gamma_g elemental function k_g (nf) result (kg) real(kind=default), intent(in) :: nf real(kind=default) :: kg kg = (67.0_default/18.0_default - pi**2/6.0_default) * CA - & 10.0_default/9.0_default * TR * nf end function k_g @ %def gamma_g @ %def k_g @ \subsection{Mathematical Functions} The dilogarithm. This simplified version is bound to double precision, and restricted to argument values less or equal to unity, so we do not need complex algebra. The wrapper converts it to default precision (which is, of course, a no-op if double=default). The routine calculates the dilogarithm through mapping on the area where there is a quickly convergent series (adapted from an F77 routine by Hans Kuijf, 1988): Map $x$ such that $x$ is not in the neighbourhood of $1$. Note that $|z|=-\ln(1-x)$ is always smaller than $1.10$, but $\frac{1.10^{19}}{19!}{\rm Bernoulli}_{19}=2.7\times 10^{-15}$. <>= public :: Li2 <>= elemental function Li2 (x) use kinds, only: double real(default), intent(in) :: x real(default) :: Li2 Li2 = real( Li2_double (real(x, kind=double)), kind=default) end function Li2 @ %def: Li2 @ <>= elemental function Li2_double (x) result (Li2) use kinds, only: double real(kind=double), intent(in) :: x real(kind=double) :: Li2 real(kind=double), parameter :: pi2_6 = pi**2/6 if (abs(1-x) < tiny_07) then Li2 = pi2_6 else if (abs(1-x) < 0.5_double) then Li2 = pi2_6 - log(1-x) * log(x) - Li2_restricted (1-x) else if (abs(x) > 1.d0) then ! Li2 = 0 ! call msg_bug (" Dilogarithm called outside of defined range.") !!! Reactivate Dilogarithm identity Li2 = -pi2_6 - 0.5_default * log(-x) * log(-x) - Li2_restricted (1/x) else Li2 = Li2_restricted (x) end if contains elemental function Li2_restricted (x) result (Li2) real(kind=double), intent(in) :: x real(kind=double) :: Li2 real(kind=double) :: tmp, z, z2 z = - log (1-x) z2 = z**2 ! Horner's rule for the powers z^3 through z^19 tmp = 43867._double/798._double tmp = tmp * z2 /342._double - 3617._double/510._double tmp = tmp * z2 /272._double + 7._double/6._double tmp = tmp * z2 /210._double - 691._double/2730._double tmp = tmp * z2 /156._double + 5._double/66._double tmp = tmp * z2 /110._double - 1._double/30._double tmp = tmp * z2 / 72._double + 1._double/42._double tmp = tmp * z2 / 42._double - 1._double/30._double tmp = tmp * z2 / 20._double + 1._double/6._double ! The first three terms of the power series Li2 = z2 * z * tmp / 6._double - 0.25_double * z2 + z end function Li2_restricted end function Li2_double @ %def Li2_double @ \subsection{Loop Integrals} These functions appear in the calculation of the effective one-loop coupling of a (pseudo)scalar to a vector boson pair. <>= public :: faux <>= elemental function faux (x) result (y) real(default), intent(in) :: x complex(default) :: y if (1 <= x) then y = asin(sqrt(1/x))**2 else y = - 1/4.0_default * (log((1 + sqrt(1 - x))/ & (1 - sqrt(1 - x))) - cmplx (0.0_default, pi, kind=default))**2 end if end function faux @ %def faux @ <>= public :: fonehalf <>= elemental function fonehalf (x) result (y) real(default), intent(in) :: x complex(default) :: y if (abs(x) < eps0) then y = 0 else y = - 2.0_default * x * (1 + (1 - x) * faux(x)) end if end function fonehalf @ %def fonehalf @ <>= public :: fonehalf_pseudo <>= function fonehalf_pseudo (x) result (y) real(default), intent(in) :: x complex(default) :: y if (abs(x) < eps0) then y = 0 else y = - 2.0_default * x * faux(x) end if end function fonehalf_pseudo @ %def fonehalf_pseudo @ <>= public :: fone <>= elemental function fone (x) result (y) real(default), intent(in) :: x complex(default) :: y if (abs(x) < eps0) then y = 2.0_default else y = 2.0_default + 3.0_default * x + & 3.0_default * x * (2.0_default - x) * & faux(x) end if end function fone @ %def fone @ <>= public :: gaux <>= elemental function gaux (x) result (y) real(default), intent(in) :: x complex(default) :: y if (1 <= x) then y = sqrt(x - 1) * asin(sqrt(1/x)) else y = sqrt(1 - x) * (log((1 + sqrt(1 - x)) / & (1 - sqrt(1 - x))) - & cmplx (0.0_default, pi, kind=default)) / 2.0_default end if end function gaux @ %def gaux @ <>= public :: tri_i1 <>= elemental function tri_i1 (a,b) result (y) real(default), intent(in) :: a,b complex(default) :: y if (a < eps0 .or. b < eps0) then y = 0 else y = a*b/2.0_default/(a-b) + a**2 * b**2/2.0_default/(a-b)**2 * & (faux(a) - faux(b)) + & a**2 * b/(a-b)**2 * (gaux(a) - gaux(b)) end if end function tri_i1 @ %def tri_i1 @ <>= public :: tri_i2 <>= elemental function tri_i2 (a,b) result (y) real(default), intent(in) :: a,b complex(default) :: y if (a < eps0 .or. b < eps0) then y = 0 else y = - a * b / 2.0_default / (a-b) * (faux(a) - faux(b)) end if end function tri_i2 @ %def tri_i2 @ \subsection{More on $\alpha_s$} These functions are for the running of the strong coupling constants, $\alpha_s$. <>= public :: run_b0 <>= elemental function run_b0 (nf) result (bnull) integer, intent(in) :: nf real(default) :: bnull bnull = 33.0_default - 2.0_default * nf end function run_b0 @ %def run_b0 @ <>= public :: run_b1 <>= elemental function run_b1 (nf) result (bone) integer, intent(in) :: nf real(default) :: bone bone = 6.0_default * (153.0_default - 19.0_default * nf)/run_b0(nf)**2 end function run_b1 @ %def run_b1 @ <>= public :: run_aa <>= elemental function run_aa (nf) result (aaa) integer, intent(in) :: nf real(default) :: aaa aaa = 12.0_default * PI / run_b0(nf) end function run_aa @ %def run_aa @ <>= public :: run_bb <>= elemental function run_bb (nf) result (bbb) integer, intent(in) :: nf real(default) :: bbb bbb = run_b1(nf) / run_aa(nf) end function run_bb @ %def run_bb @ \subsection{Functions for Catani-Seymour dipoles} For the automated Catani-Seymour dipole subtraction, we need the following functions. <>= public :: ff_dipole <>= pure subroutine ff_dipole (v_ijk,y_ijk,p_ij,pp_k,p_i,p_j,p_k) type(vector4_t), intent(in) :: p_i, p_j, p_k type(vector4_t), intent(out) :: p_ij, pp_k real(kind=default), intent(out) :: y_ijk real(kind=default) :: z_i real(kind=default), intent(out) :: v_ijk z_i = (p_i*p_k) / ((p_k*p_j) + (p_k*p_i)) y_ijk = (p_i*p_j) / ((p_i*p_j) + (p_i*p_k) + (p_j*p_k)) p_ij = p_i + p_j - y_ijk/(1.0_default - y_ijk) * p_k pp_k = (1.0/(1.0_default - y_ijk)) * p_k !!! We don't multiply by alpha_s right here: v_ijk = 8.0_default * PI * CF * & (2.0 / (1.0 - z_i*(1.0 - y_ijk)) - (1.0 + z_i)) end subroutine ff_dipole @ %def ff_dipole @ <>= public :: fi_dipole <>= pure subroutine fi_dipole (v_ija,x_ija,p_ij,pp_a,p_i,p_j,p_a) type(vector4_t), intent(in) :: p_i, p_j, p_a type(vector4_t), intent(out) :: p_ij, pp_a real(kind=default), intent(out) :: x_ija real(kind=default) :: z_i real(kind=default), intent(out) :: v_ija z_i = (p_i*p_a) / ((p_a*p_j) + (p_a*p_i)) x_ija = ((p_i*p_a) + (p_j*p_a) - (p_i*p_j)) & / ((p_i*p_a) + (p_j*p_a)) p_ij = p_i + p_j - (1.0_default - x_ija) * p_a pp_a = x_ija * p_a !!! We don't not multiply by alpha_s right here: v_ija = 8.0_default * PI * CF * & (2.0 / (1.0 - z_i + (1.0 - x_ija)) - (1.0 + z_i)) / x_ija end subroutine fi_dipole @ %def fi_dipole @ <>= public :: if_dipole <>= pure subroutine if_dipole (v_kja,u_j,p_aj,pp_k,p_k,p_j,p_a) type(vector4_t), intent(in) :: p_k, p_j, p_a type(vector4_t), intent(out) :: p_aj, pp_k real(kind=default), intent(out) :: u_j real(kind=default) :: x_kja real(kind=default), intent(out) :: v_kja u_j = (p_a*p_j) / ((p_a*p_j) + (p_a*p_k)) x_kja = ((p_a*p_k) + (p_a*p_j) - (p_j*p_k)) & / ((p_a*p_j) + (p_a*p_k)) p_aj = x_kja * p_a pp_k = p_k + p_j - (1.0_default - x_kja) * p_a v_kja = 8.0_default * PI * CF * & (2.0 / (1.0 - x_kja + u_j) - (1.0 + x_kja)) / x_kja end subroutine if_dipole @ %def if_dipole @ This function depends on a variable number of final state particles whose kinematics all get changed by the initial-initial dipole insertion. <>= public :: ii_dipole <>= pure subroutine ii_dipole (v_jab,v_j,p_in,p_out,flag_1or2) type(vector4_t), dimension(:), intent(in) :: p_in type(vector4_t), dimension(size(p_in)-1), intent(out) :: p_out logical, intent(in) :: flag_1or2 real(kind=default), intent(out) :: v_j real(kind=default), intent(out) :: v_jab type(vector4_t) :: p_a, p_b, p_j type(vector4_t) :: k, kk type(vector4_t) :: p_aj real(kind=default) :: x_jab integer :: i !!! flag_1or2 decides whether this a 12 or 21 dipole if (flag_1or2) then p_a = p_in(1) p_b = p_in(2) else p_b = p_in(1) p_a = p_in(2) end if !!! We assume that the unresolved particle has always the last !!! momentum p_j = p_in(size(p_in)) x_jab = ((p_a*p_b) - (p_a*p_j) - (p_b*p_j)) / (p_a*p_b) v_j = (p_a*p_j) / (p_a * p_b) p_aj = x_jab * p_a k = p_a + p_b - p_j kk = p_aj + p_b do i = 3, size(p_in)-1 p_out(i) = p_in(i) - 2.0*((k+kk)*p_in(i))/((k+kk)*(k+kk)) * (k+kk) + & (2.0 * (k*p_in(i)) / (k*k)) * kk end do if (flag_1or2) then p_out(1) = p_aj p_out(2) = p_b else p_out(1) = p_b p_out(2) = p_aj end if v_jab = 8.0_default * PI * CF * & (2.0 / (1.0 - x_jab) - (1.0 + x_jab)) / x_jab end subroutine ii_dipole @ %def ii_dipole @ \subsection{Distributions for integrated dipoles and such} Note that the following formulae are only meaningful for $0 \leq x \leq 1$. The Dirac delta distribution, modified for Monte-Carlo sampling, centered at $x=1-\frac{\epsilon}{2}$: <>= public :: delta <>= elemental function delta (x,eps) result (z) real(kind=default), intent(in) :: x, eps real(kind=default) :: z if (x > one - eps) then z = one / eps else z = 0 end if end function delta @ %def delta @ The $+$-distribution, $P_+(x) = \left( \frac{1}{1-x}\right)_+$, for the regularization of soft-collinear singularities. The constant part for the Monte-Carlo sampling is the integral over the splitting function divided by the weight for the WHIZARD numerical integration over the interval. <>= public :: plus_distr <>= elemental function plus_distr (x,eps) result (plusd) real(kind=default), intent(in) :: x, eps real(kind=default) :: plusd if (x > one - eps) then plusd = log(eps) / eps else plusd = one / (one - x) end if end function plus_distr @ %def plus_distr @ The splitting function in $D=4$ dimensions, regularized as $+$-distributions if necessary: \begin{align} P^{qq} (x) = P^{\bar q\bar q} (x) &= \; C_F \cdot \left( \frac{1 + x^2}{1-x} \right)_+ \\ P^{qg} (x) = P^{\bar q g} (x) &= \; C_F \cdot \frac{1 + (1-x)^2}{x}\\ P^{gq} (x) = P^{g \bar q} (x) &= \; T_R \cdot \left[ x^2 + (1-x)^2 \right] \\ P^{gg} (x) &= \; 2 C_A \biggl[ \left( \frac{1}{1-x} \right)_+ + \frac{1-x}{x} - 1 + x(1-x) \biggl] \notag{}\\ &\quad + \delta(1-x) \left( \frac{11}{6} C_A - \frac{2}{3} N_f T_R \right) \end{align} Since the number of flavors summed over in the gluon splitting function might depend on the physics case under consideration, it is implemented as an input variable. <>= public :: pqq <>= elemental function pqq (x,eps) result (pqqx) real(kind=default), intent(in) :: x, eps real(kind=default) :: pqqx if (x > (1.0_default - eps)) then pqqx = (eps - one) / two + two * log(eps) / eps - & three * (eps - one) / eps / two else pqqx = (one + x**2) / (one - x) end if pqqx = CF * pqqx end function pqq @ %def pqq @ <>= public :: pgq <>= elemental function pgq (x) result (pgqx) real(kind=default), intent(in) :: x real(kind=default) :: pgqx pgqx = TR * (x**2 + (one - x)**2) end function pgq @ %def pgq @ <>= public :: pqg <>= elemental function pqg (x) result (pqgx) real(kind=default), intent(in) :: x real(kind=default) :: pqgx pqgx = CF * (one + (one - x)**2) / x end function pqg @ %def pqg @ <>= public :: pgg <>= elemental function pgg (x, nf, eps) result (pggx) real(kind=default), intent(in) :: x, nf, eps real(kind=default) :: pggx pggx = two * CA * ( plus_distr (x, eps) + (one-x)/x - one + & x*(one-x)) + delta (x, eps) * gamma_g(nf) end function pgg @ %def pgg @ For the $qq$ and $gg$ cases, there exist ``regularized'' versions of the splitting functions: \begin{align} P^{qq}_{\text{reg}} (x) &= - C_F \cdot (1 + x) \\ P^{gg}_{\text{reg}} (x) &= 2 C_A \left[ \frac{1-x}{x} - 1 + x(1-x) \right] \end{align} <>= public :: pqq_reg <>= elemental function pqq_reg (x) result (pqqregx) real(kind=default), intent(in) :: x real(kind=default) :: pqqregx pqqregx = - CF * (one + x) end function pqq_reg @ %def pqq_reg @ <>= public :: pgg_reg <>= elemental function pgg_reg (x) result (pggregx) real(kind=default), intent(in) :: x real(kind=default) :: pggregx pggregx = two * CA * ((one - x)/x - one + x*(one - x)) end function pgg_reg @ %def pgg_reg @ Here, we collect the expressions needed for integrated Catani-Seymour dipoles, and the so-called flavor kernels. We always distinguish between the ``ordinary'' Catani-Seymour version, and the one including a phase-space slicing parameter, $\alpha$. The standard flavor kernels $\overline{K}^{ab}$ are: \begin{align} \overline{K}^{qg} (x) = \overline{K}^{\bar q g} (x) & = \; P^{qg} (x) \log ((1-x)/x) + CF \times x \\ %%% \overline{K}^{gq} (x) = \overline{K}^{g \bar q} (x) & = \; P^{gq} (x) \log ((1-x)/x) + TR \times 2x(1-x) \\ %%% \overline{K}^{qq} &=\; C_F \biggl[ \left( \frac{2}{1-x} \log \frac{1-x}{x} \right)_+ - (1+x) \log ((1-x)/x) + (1-x) \biggr] \notag{}\\ &\quad - (5 - \pi^2) \cdot C_F \cdot \delta(1-x) \\ %%% \overline{K}^{gg} &=\; 2 C_A \biggl[ \left( \frac{1}{1-x} \log \frac{1-x}{x} \right)_+ + \left( \frac{1-x}{x} - 1 + x(1-x) \right) \log((1-x)/x) \biggr] \notag{}\\ &\quad - \delta(1-x) \biggl[ \left( \frac{50}{9} - \pi^2 \right) C_A - \frac{16}{9} T_R N_f \biggr] \end{align} <>= public :: kbarqg <>= function kbarqg (x) result (kbarqgx) real(kind=default), intent(in) :: x real(kind=default) :: kbarqgx kbarqgx = pqg(x) * log((one-x)/x) + CF * x end function kbarqg @ %def kbarqg @ <>= public :: kbargq <>= function kbargq (x) result (kbargqx) real(kind=default), intent(in) :: x real(kind=default) :: kbargqx kbargqx = pgq(x) * log((one-x)/x) + two * TR * x * (one - x) end function kbargq @ %def kbarqg @ <>= public :: kbarqq <>= function kbarqq (x,eps) result (kbarqqx) real(kind=default), intent(in) :: x, eps real(kind=default) :: kbarqqx kbarqqx = CF*(log_plus_distr(x,eps) - (one+x) * log((one-x)/x) + (one - & x) - (five - pi**2) * delta(x,eps)) end function kbarqq @ %def kbarqq @ <>= public :: kbargg <>= function kbargg (x,eps,nf) result (kbarggx) real(kind=default), intent(in) :: x, eps, nf real(kind=default) :: kbarggx kbarggx = CA * (log_plus_distr(x,eps) + two * ((one-x)/x - one + & x*(one-x) * log((1-x)/x))) - delta(x,eps) * & ((50.0_default/9.0_default - pi**2) * CA - & 16.0_default/9.0_default * TR * nf) end function kbargg @ %def kbargg @ The $\tilde{K}$ are used when two identified hadrons participate: \begin{equation} \tilde{K}^{ab} (x) = P^{ab}_{\text{reg}} (x) \cdot \log (1-x) + \delta^{ab} \mathbf{T}_a^2 \biggl[ \left( \frac{2}{1-x} \log (1-x) \right)_+ - \frac{\pi^2}{3} \delta(1-x) \biggr] \end{equation} <>= public :: ktildeqq <>= function ktildeqq (x,eps) result (ktildeqqx) real(kind=default), intent(in) :: x, eps real(kind=default) :: ktildeqqx ktildeqqx = pqq_reg (x) * log(one-x) + CF * ( - log2_plus_distr (x,eps) & - pi**2/three * delta(x,eps)) end function ktildeqq @ %def ktildeqq @ <>= public :: ktildeqg <>= function ktildeqg (x,eps) result (ktildeqgx) real(kind=default), intent(in) :: x, eps real(kind=default) :: ktildeqgx ktildeqgx = pqg (x) * log(one-x) end function ktildeqg @ %def ktildeqg @ <>= public :: ktildegq <>= function ktildegq (x,eps) result (ktildegqx) real(kind=default), intent(in) :: x, eps real(kind=default) :: ktildegqx ktildegqx = pgq (x) * log(one-x) end function ktildegq @ %def ktildeqg @ <>= public :: ktildegg <>= function ktildegg (x,eps) result (ktildeggx) real(kind=default), intent(in) :: x, eps real(kind=default) :: ktildeggx ktildeggx = pgg_reg (x) * log(one-x) + CA * ( - & log2_plus_distr (x,eps) - pi**2/three * delta(x,eps)) end function ktildegg @ %def ktildegg @ The insertion operator might not be necessary for a GOLEM interface but is demanded by the Les Houches NLO accord. It is a three-dimensional array, where the index always gives the inverse power of the DREG expansion parameter, $\epsilon$. <>= public :: insert_q <>= pure function insert_q () real(kind=default), dimension(0:2) :: insert_q insert_q(0) = gamma_q + k_q - pi**2/three * CF insert_q(1) = gamma_q insert_q(2) = CF end function insert_q @ %def insert_q @ <>= public :: insert_g <>= pure function insert_g (nf) real(kind=default), intent(in) :: nf real(kind=default), dimension(0:2) :: insert_g insert_g(0) = gamma_g (nf) + k_g (nf) - pi**2/three * CA insert_g(1) = gamma_g (nf) insert_g(2) = CA end function insert_g @ %def insert_g @ For better convergence, one can exclude regions of phase space with a slicing parameter from the dipole subtraction procedure. First of all, the $K$ functions get modified: \begin{equation} K_i (\alpha) = K_i - \mathbf{T}_i^2 \log^2 \alpha + \gamma_i ( \alpha - 1 - \log\alpha) \end{equation} <>= public :: k_q_al, k_g_al <>= pure function k_q_al (alpha) real(kind=default), intent(in) :: alpha real(kind=default) :: k_q_al k_q_al = k_q - CF * (log(alpha))**2 + gamma_q * & (alpha - one - log(alpha)) end function k_q_al pure function k_g_al (alpha, nf) real(kind=default), intent(in) :: alpha, nf real(kind=default) :: k_g_al k_g_al = k_g (nf) - CA * (log(alpha))**2 + gamma_g (nf) * & (alpha - one - log(alpha)) end function k_g_al @ %def k_q_al @ %def k_g_al @ The $+$-distribution, but with a phase-space slicing parameter, $\alpha$, $P_{1-\alpha}(x) = \left( \frac{1}{1-x} \right)_{1-x}$. Since we need the fatal error message here, this function cannot be elemental. <>= public :: plus_distr_al <>= function plus_distr_al (x,alpha,eps) result (plusd_al) real(kind=default), intent(in) :: x, eps, alpha real(kind=default) :: plusd_al if ((one - alpha) >= (one - eps)) then plusd_al = zero call msg_fatal ('sm_physics, plus_distr_al: alpha and epsilon chosen wrongly') elseif (x < (1.0_default - alpha)) then plusd_al = 0 else if (x > (1.0_default - eps)) then plusd_al = log(eps/alpha)/eps else plusd_al = one/(one-x) end if end function plus_distr_al @ %def plus_distr_al @ Introducing phase-space slicing parameters, these standard flavor kernels $\overline{K}^{ab}$ become: \begin{align} \overline{K}^{qg}_\alpha (x) = \overline{K}^{\bar q g}_\alpha (x) & = \; P^{qg} (x) \log (\alpha (1-x)/x) + C_F \times x \\ %%% \overline{K}^{gq}_\alpha (x) = \overline{K}^{g \bar q}_\alpha (x) & = \; P^{gq} (x) \log (\alpha (1-x)/x) + T_R \times 2x(1-x) \\ %%% \overline{K}^{qq}_\alpha &= C_F (1 - x) + P^{qq}_{\text{reg}} (x) \log \frac{\alpha(1-x)}{x} \notag{}\\ &\quad + C_F \delta (1 - x) \log^2 \alpha + C_F \left( \frac{2}{1-x} \log \frac{1-x}{x} \right)_+ \notag{}\\ &\quad - \left( \gamma_q + K_q(\alpha) - \frac56 \pi^2 C_F \right) \cdot \delta(1-x) \; C_F \Bigl[ + \frac{2}{1-x} \log \left( \frac{\alpha (2-x)}{1+\alpha-x} \right) - \theta(1 - \alpha - x) \cdot \left( \frac{2}{1-x} \log \frac{2-x}{1-x} \right) \Bigr] \\ %%% \overline{K}^{gg}_\alpha &=\; P^{gg}_{\text{reg}} (x) \log \frac{\alpha(1-x)}{x} + C_A \delta (1 - x) \log^2 \alpha \notag{}\\ &\quad + C_A \left( \frac{2}{1-x} \log \frac{1-x}{x} \right)_+ - \left( \gamma_g + K_g(\alpha) - \frac56 \pi^2 C_A \right) \cdot \delta(1-x) \; C_A \Bigl[ + \frac{2}{1-x} \log \left( \frac{\alpha (2-x)}{1+\alpha-x} \right) - \theta(1 - \alpha - x) \cdot \left( \frac{2}{1-x} \log \frac{2-x}{1-x} \right) \Bigr] \end{align} <>= public :: kbarqg_al <>= function kbarqg_al (x,alpha,eps) result (kbarqgx) real(kind=default), intent(in) :: x, alpha, eps real(kind=default) :: kbarqgx kbarqgx = pqg (x) * log(alpha*(one-x)/x) + CF * x end function kbarqg_al @ %def kbarqg_al @ <>= public :: kbargq_al <>= function kbargq_al (x,alpha,eps) result (kbargqx) real(kind=default), intent(in) :: x, alpha, eps real(kind=default) :: kbargqx kbargqx = pgq (x) * log(alpha*(one-x)/x) + two * TR * x * (one-x) end function kbargq_al @ %def kbargq_al @ <>= public :: kbarqq_al <>= function kbarqq_al (x,alpha,eps) result (kbarqqx) real(kind=default), intent(in) :: x, alpha, eps real(kind=default) :: kbarqqx kbarqqx = CF * (one - x) + pqq_reg(x) * log(alpha*(one-x)/x) & + CF * log_plus_distr(x,eps) & - (gamma_q + k_q_al(alpha) - CF * & five/6.0_default * pi**2 - CF * (log(alpha))**2) * & delta(x,eps) + & CF * two/(one -x)*log(alpha*(two-x)/(one+alpha-x)) if (x < (one-alpha)) then kbarqqx = kbarqqx - CF * two/(one-x) * log((two-x)/(one-x)) end if end function kbarqq_al @ %def kbarqq_al <>= public :: kbargg_al <>= function kbargg_al (x,alpha,eps,nf) result (kbarggx) real(kind=default), intent(in) :: x, alpha, eps, nf real(kind=default) :: kbarggx kbarggx = pgg_reg(x) * log(alpha*(one-x)/x) & + CA * log_plus_distr(x,eps) & - (gamma_g(nf) + k_g_al(alpha,nf) - CA * & five/6.0_default * pi**2 - CA * (log(alpha))**2) * & delta(x,eps) + & CA * two/(one -x)*log(alpha*(two-x)/(one+alpha-x)) if (x < (one-alpha)) then kbarggx = kbarggx - CA * two/(one-x) * log((two-x)/(one-x)) end if end function kbargg_al @ %def kbargg_al @ The $\tilde{K}$ flavor kernels in the presence of a phase-space slicing parameter, are: \begin{equation} \tilde{K}^{ab} (x,\alpha) = P^{qq, \text{reg}} (x) \log\frac{1-x}{\alpha} + .......... \end{equation} <>= public :: ktildeqq_al <>= function ktildeqq_al (x,alpha,eps) result (ktildeqqx) real(kind=default), intent(in) :: x, eps, alpha real(kind=default) :: ktildeqqx ktildeqqx = pqq_reg(x) * log((one-x)/alpha) + CF*( & - log2_plus_distr_al(x,alpha,eps) - Pi**2/three * delta(x,eps) & + (one+x**2)/(one-x) * log(min(one,(alpha/(one-x)))) & + two/(one-x) * log((one+alpha-x)/alpha)) if (x > (one-alpha)) then ktildeqqx = ktildeqqx - CF*two/(one-x)*log(two-x) end if end function ktildeqq_al @ %def ktildeqq_al @ This is a logarithmic $+$-distribution, $\left( \frac{\log((1-x)/x)}{1-x} \right)_+$. For the sampling, we need the integral over this function over the incomplete sampling interval $[0,1-\epsilon]$, which is $\log^2(x) + 2 Li_2(x) - \frac{\pi^2}{3}$. As this function is negative definite for $\epsilon > 0.1816$, we take a hard upper limit for that sampling parameter, irrespective of the fact what the user chooses. <>= public :: log_plus_distr <>= function log_plus_distr (x,eps) result (lpd) real(kind=default), intent(in) :: x, eps real(kind=default) :: lpd, eps2 eps2 = min (eps, 0.1816_default) if (x > (1.0_default - eps2)) then lpd = ((log(eps2))**2 + two*Li2(eps2) - pi**2/three)/eps2 else lpd = two*log((one-x)/x)/(one-x) end if end function log_plus_distr @ %def log_plus_distr @ Logarithmic $+$-distribution, $2 \left( \frac{\log(1/(1-x))}{1-x} \right)_+$. <>= public :: log2_plus_distr <>= function log2_plus_distr (x,eps) result (lpd) real(kind=default), intent(in) :: x, eps real(kind=default) :: lpd if (x > (1.0_default - eps)) then lpd = - (log(eps))**2/eps else lpd = two*log(one/(one-x))/(one-x) end if end function log2_plus_distr @ %def log2_plus_distr @ Logarithmic $+$-distribution with phase-space slicing parameter, $2 \left( \frac{\log(1/(1-x))}{1-x} \right)_{1-\alpha}$. <>= public :: log2_plus_distr_al <>= function log2_plus_distr_al (x,alpha,eps) result (lpd_al) real(kind=default), intent(in) :: x, eps, alpha real(kind=default) :: lpd_al if ((one - alpha) >= (one - eps)) then lpd_al = zero call msg_fatal ('alpha and epsilon chosen wrongly') elseif (x < (one - alpha)) then lpd_al = 0 elseif (x > (1.0_default - eps)) then lpd_al = - ((log(eps))**2 - (log(alpha))**2)/eps else lpd_al = two*log(one/(one-x))/(one-x) end if end function log2_plus_distr_al @ %def log2_plus_distr_al @ \subsection{Splitting Functions} @ Analogue to the regularized distributions of the last subsection, we give here the unregularized splitting functions, relevant for the parton shower algorithm. We can use this unregularized version since there will be a cut-off $\epsilon$ that ensures that $\{z,1-z\}>\epsilon(t)$. This cut-off seperates resolvable from unresolvable emissions. [[p_xxx]] are the kernels that are summed over helicity: <>= public :: p_qqg public :: p_gqq public :: p_ggg @ $q\to q g$ <>= elemental function p_qqg (z) result (P) real(default), intent(in) :: z real(default) :: P P = CF * (one + z**2) / (one - z) end function p_qqg @ $g\to q \bar{q}$ <>= elemental function p_gqq (z) result (P) real(default), intent(in) :: z real(default) :: P P = TR * (z**2 + (one - z)**2) end function p_gqq @ $g\to g g$ <>= elemental function p_ggg (z) result (P) real(default), intent(in) :: z real(default) :: P P = NC * ((one - z) / z + z / (one - z) + z * (one - z)) end function p_ggg @ %def p_qqg p_gqq p_ggg @ Analytically integrated splitting kernels: <>= public :: integral_over_p_qqg public :: integral_over_p_gqq public :: integral_over_p_ggg <>= pure function integral_over_p_qqg (zmin, zmax) result (integral) real(default), intent(in) :: zmin, zmax real(default) :: integral integral = (two / three) * (- zmax**2 + zmin**2 - & two * (zmax - zmin) + four * log((one - zmin) / (one - zmax))) end function integral_over_p_qqg pure function integral_over_p_gqq (zmin, zmax) result (integral) real(default), intent(in) :: zmin, zmax real(default) :: integral integral = 0.5_default * ((two / three) * & (zmax**3 - zmin**3) - (zmax**2 - zmin**2) + (zmax - zmin)) end function integral_over_p_gqq pure function integral_over_p_ggg (zmin, zmax) result (integral) real(default), intent(in) :: zmin, zmax real(default) :: integral integral = three * ((log(zmax) - two * zmax - & log(one - zmax) + zmax**2 / two - zmax**3 / three) - & (log(zmin) - zmin - zmin - log(one - zmin) + zmin**2 & / two - zmin**3 / three) ) end function integral_over_p_ggg @ %def integral_over_p_gqq integral_over_p_ggg integral_over_p_qqg @ We can also use (massless) helicity dependent splitting functions: <>= public :: p_qqg_pol @ $q_a\to q_b g_c$, the helicity of the quark is not changed by gluon emission and the gluon is preferably polarized in the branching plane ($l_c=1$): <>= elemental function p_qqg_pol (z, l_a, l_b, l_c) result (P) real(default), intent(in) :: z integer, intent(in) :: l_a, l_b, l_c real(default) :: P if (l_a /= l_b) then P = zero return end if if (l_c == -1) then P = one - z else P = (one + z)**2 / (one - z) end if P = P * CF end function p_qqg_pol @ \subsection{Top width} In order to produce sensible results, the widths have to be recomputed for each parameter and order. We start with the LO-expression for the top width given by the decay $t\,\to\,W^+,b$, cf. [[doi:10.1016/0550-3213(91)90530-B]]:\\ The analytic formula given there is \begin{equation*} \Gamma = \frac{G_F m_t^2}{16\sqrt{2}\pi} \left[\mathcal{F}_0(\varepsilon, \xi^{-1/2}) - \frac{2\alpha_s}{3\pi} \mathcal{F}_1 (\varepsilon, \xi^{-1/2})\right], \end{equation*} with \begin{align*} \mathcal{F}_0 &= \frac{\sqrt{\lambda}}{2} f_0, \\ f_0 &= 4\left[(1-\varepsilon^2)^2 + w^2(1+\varepsilon^2) - 2w^4\right], \\ \lambda = 1 + w^4 + \varepsilon^4 - 2(w^2 + \varepsilon^2 + w^2\varepsilon^2). \end{align*} Defining \begin{equation*} u_q = \frac{1 + \varepsilon^2 - w^2 - \lambda^{1/2}}{1 + \varepsilon^2 - w^2 + \lambda^{1/2}} \end{equation*} and \begin{equation*} u_w = \frac{1 - \varepsilon^2 + w^2 - \lambda^{1/2}}{1 - \varepsilon^2 + w^2 + \lambda^{1/2}} \end{equation*} the factor $\mathcal{F}_1$ can be expressed as \begin{align*} \mathcal{F}_1 = \frac{1}{2}f_0(1+\varepsilon^2-w^2) & \left[\pi^2 + 2Li_2(u_w) - 2Li_2(1-u_w) - 4Li_2(u_q) \right. \\ & -4Li_2(u_q u_w) + \log\left(\frac{1-u_q}{w^2}\right)\log(1-u_q) - \log^2(1-u_q u_w) \\ & \left.+\frac{1}{4}\log^2\left(\frac{w^2}{u_w}\right) - \log(u_w) \log\left[\frac{(1-u_q u_w)^2}{1-u_q}\right] -2\log(u_q)\log\left[(1-u_q)(1-u_q u_w)\right]\right] \\ & -\sqrt{\lambda}f_0(2\log(w) + 3\log(\varepsilon) - 2\log{\lambda}) \\ & +4(1-\varepsilon^2)\left[(1-\varepsilon^2)^2 + w^2(1+\varepsilon^2) - 4w^4\right]\log(u_w) \\ & \left[(3 - \varepsilon^2 + 11\varepsilon^4 - \varepsilon^6) + w^2(6 - 12\varepsilon^2 +2\varepsilon^4) - w^4(21 + 5\varepsilon^2) + 12w^6\right] \log(u_q) \\ & 6\sqrt{\lambda} (1-\varepsilon^2) (1 + \varepsilon^2 - w^2) \log(\varepsilon) + \sqrt{\lambda}\left[-5 + 22\varepsilon^2 - 5\varepsilon^4 - 9w^2(1+\varepsilon^2) + 6w^4\right]. \end{align*} @ <>= public :: top_width_sm_lo <>= elemental function top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb) & result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb real(default) :: kappa kappa = sqrt ((mtop**2 - (mw + mb)**2) * (mtop**2 - (mw - mb)**2)) gamma = alpha / four * mtop / (two * sinthw**2) * & vtb**2 * kappa / mtop**2 * & ((mtop**2 + mb**2) / (two * mtop**2) + & (mtop**2 - mb**2)**2 / (two * mtop**2 * mw**2) - & mw**2 / mtop**2) end function top_width_sm_lo @ %def top_width_sm_lo @ <>= public :: g_mu_from_alpha <>= elemental function g_mu_from_alpha (alpha, mw, sinthw) result (g_mu) real(default) :: g_mu real(default), intent(in) :: alpha, mw, sinthw g_mu = pi * alpha / sqrt(two) / mw**2 / sinthw**2 end function g_mu_from_alpha @ %def g_mu_from_alpha @ <>= public :: alpha_from_g_mu <>= elemental function alpha_from_g_mu (g_mu, mw, sinthw) result (alpha) real(default) :: alpha real(default), intent(in) :: g_mu, mw, sinthw alpha = g_mu * sqrt(two) / pi * mw**2 * sinthw**2 end function alpha_from_g_mu @ %def alpha_from_g_mu @ Cf. (3.3)-(3.7) in [[1207.5018]]. <>= public :: top_width_sm_qcd_nlo_massless_b <>= elemental function top_width_sm_qcd_nlo_massless_b & (alpha, sinthw, vtb, mtop, mw, alphas) result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, alphas real(default) :: prefac, g_mu, w2 g_mu = g_mu_from_alpha (alpha, mw, sinthw) prefac = g_mu * mtop**3 * vtb**2 / (16 * sqrt(two) * pi) w2 = mw**2 / mtop**2 gamma = prefac * (f0 (w2) - (two * alphas) / (3 * Pi) * f1 (w2)) end function top_width_sm_qcd_nlo_massless_b @ %def top_width_sm_qcd_nlo_massless_b @ <>= public :: f0 <>= elemental function f0 (w2) result (f) real(default) :: f real(default), intent(in) :: w2 f = two * (one - w2)**2 * (1 + 2 * w2) end function f0 @ %def f0 @ <>= public :: f1 <>= elemental function f1 (w2) result (f) real(default) :: f real(default), intent(in) :: w2 f = f0 (w2) * (pi**2 + two * Li2 (w2) - two * Li2 (one - w2)) & + four * w2 * (one - w2 - two * w2**2) * log (w2) & + two * (one - w2)**2 * (five + four * w2) * log (one - w2) & - (one - w2) * (five + 9 * w2 - 6 * w2**2) end function f1 @ %def f1 @ Basically, the same as above but with $m_b$ dependence, cf. Jezabek / Kuehn 1989. <>= public :: top_width_sm_qcd_nlo_jk <>= elemental function top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb, alphas real(default) :: prefac, g_mu, eps2, i_xi g_mu = g_mu_from_alpha (alpha, mw, sinthw) prefac = g_mu * mtop**3 * vtb**2 / (16 * sqrt(two) * pi) eps2 = (mb / mtop)**2 i_xi = (mw / mtop)**2 gamma = prefac * (ff0 (eps2, i_xi) - & (two * alphas) / (3 * Pi) * ff1 (eps2, i_xi)) end function top_width_sm_qcd_nlo_jk @ %def top_width_sm_qcd_nlo_jk @ Same as above, $m_b > 0$, with the slightly different implementation (2.6) of arXiv:1204.1513v1 by Campbell and Ellis. <>= public :: top_width_sm_qcd_nlo_ce <>= elemental function top_width_sm_qcd_nlo_ce & (alpha, sinthw, vtb, mtop, mw, mb, alpha_s) result (gamma) real(default) :: gamma real(default), intent(in) :: alpha, sinthw, vtb, mtop, mw, mb, alpha_s real(default) :: pm, pp, p0, p3 real(default) :: yw, yp real(default) :: W0, Wp, Wm, w2 real(default) :: beta2 real(default) :: f real(default) :: g_mu, gamma0 beta2 = (mb / mtop)**2 w2 = (mw / mtop)**2 p0 = (one - w2 + beta2) / two p3 = sqrt (lambda (one, w2, beta2)) / two pp = p0 + p3 pm = p0 - p3 W0 = (one + w2 - beta2) / two Wp = W0 + p3 Wm = W0 - p3 yp = log (pp / pm) / two yw = log (Wp / Wm) / two f = (one - beta2)**2 + w2 * (one + beta2) - two * w2**2 g_mu = g_mu_from_alpha (alpha, mw, sinthw) gamma0 = g_mu * mtop**3 * vtb**2 / (8 * pi * sqrt(two)) gamma = gamma0 * alpha_s / twopi * CF * & (8 * f * p0 * (Li2(one - pm) - Li2(one - pp) - two * Li2(one - pm / pp) & + yp * log((four * p3**2) / (pp**2 * Wp)) + yw * log (pp)) & + four * (one - beta2) * ((one - beta2)**2 + w2 * (one + beta2) - four * w2**2) * yw & + (3 - beta2 + 11 * beta2**2 - beta2**3 + w2 * (6 - 12 * beta2 + two * beta2**2) & - w2**2 * (21 + 5 * beta2) + 12 * w2**3) * yp & + 8 * f * p3 * log (sqrt(w2) / (four * p3**2)) & + 6 * (one - four * beta2 + 3 * beta2**2 + w2 * (3 + beta2) - four * w2**2) * p3 * log(sqrt(beta2)) & + (5 - 22 * beta2 + 5 * beta2**2 + 9 * w2 * (one + beta2) - 6 * w2**2) * p3) end function top_width_sm_qcd_nlo_ce @ %def top_width_sm_qcd_nlo_ce @ <>= public :: ff0 <>= elemental function ff0 (eps2, w2) result (f) real(default) :: f real(default), intent(in) :: eps2, w2 f = one / two * sqrt(ff_lambda (eps2, w2)) * ff_f0 (eps2, w2) end function ff0 @ %def ff0 @ <>= public :: ff_f0 <>= elemental function ff_f0 (eps2, w2) result (f) real(default) :: f real(default), intent(in) :: eps2, w2 f = four * ((1 - eps2)**2 + w2 * (1 + eps2) - 2 * w2**2) end function ff_f0 @ %def ff_f0 @ <>= public :: ff_lambda <>= elemental function ff_lambda (eps2, w2) result (l) real(default) :: l real(default), intent(in) :: eps2, w2 l = one + w2**2 + eps2**2 - two * (w2 + eps2 + w2 * eps2) end function ff_lambda @ %def ff_lambda @ <>= public :: ff1 <>= elemental function ff1 (eps2, w2) result (f) real(default) :: f real(default), intent(in) :: eps2, w2 real(default) :: uq, uw, sq_lam, fff sq_lam = sqrt (ff_lambda (eps2, w2)) fff = ff_f0 (eps2, w2) uw = (one - eps2 + w2 - sq_lam) / & (one - eps2 + w2 + sq_lam) uq = (one + eps2 - w2 - sq_lam) / & (one + eps2 - w2 + sq_lam) f = one / two * fff * (one + eps2 - w2) * & (pi**2 + two * Li2 (uw) - two * Li2 (one - uw) - four * Li2 (uq) & - four * Li2 (uq * uw) + log ((one - uq) / w2) * log (one - uq) & - log (one - uq * uw)**2 + one / four * log (w2 / uw)**2 & - log (uw) * log ((one - uq * uw)**2 / (one - uq)) & - two * log (uq) * log ((one - uq) * (one - uq * uw))) & - sq_lam * fff * (two * log (sqrt (w2)) & + three * log (sqrt (eps2)) - two * log (sq_lam**2)) & + four * (one - eps2) * ((one - eps2)**2 + w2 * (one + eps2) & - four * w2**2) * log (uw) & + (three - eps2 + 11 * eps2**2 - eps2**3 + w2 * & (6 - 12 * eps2 + 2 * eps2**2) - w2**2 * (21 + five * eps2) & + 12 * w2**3) * log (uq) & + 6 * sq_lam * (one - eps2) * & (one + eps2 - w2) * log (sqrt (eps2)) & + sq_lam * (- five + 22 * eps2 - five * eps2**2 - 9 * w2 * & (one + eps2) + 6 * w2**2) end function ff1 @ %def ff1 \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sm_physics_ut.f90]]>>= <> module sm_physics_ut use unit_tests use sm_physics_uti <> <> contains <> end module sm_physics_ut @ %def sm_physics_ut @ <<[[sm_physics_uti.f90]]>>= <> module sm_physics_uti <> use numeric_utils use format_defs, only: FMT_15 use constants use sm_physics <> <> contains <> end module sm_physics_uti @ %def sm_physics_ut @ API: driver for the unit tests below. <>= public :: sm_physics_test <>= subroutine sm_physics_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sm_physics_test @ %def sm_physics_test @ \subsubsection{Splitting functions} <>= call test (sm_physics_1, "sm_physics_1", & "Splitting functions", & u, results) <>= public :: sm_physics_1 <>= subroutine sm_physics_1 (u) integer, intent(in) :: u real(default) :: z = 0.75_default write (u, "(A)") "* Test output: sm_physics_1" write (u, "(A)") "* Purpose: check analytic properties" write (u, "(A)") write (u, "(A)") "* Splitting functions:" write (u, "(A)") call assert (u, vanishes (p_qqg_pol (z, +1, -1, +1)), "+-+") call assert (u, vanishes (p_qqg_pol (z, +1, -1, -1)), "+--") call assert (u, vanishes (p_qqg_pol (z, -1, +1, +1)), "-++") call assert (u, vanishes (p_qqg_pol (z, -1, +1, -1)), "-+-") !call assert (u, nearly_equal ( & !p_qqg_pol (z, +1, +1, -1) + p_qqg_pol (z, +1, +1, +1), & !p_qqg (z)), "pol sum") write (u, "(A)") write (u, "(A)") "* Test output end: sm_physics_1" end subroutine sm_physics_1 @ %def sm_physics_1 @ \subsubsection{Top width} <>= call test(sm_physics_2, "sm_physics_2", & "Top width", u, results) <>= public :: sm_physics_2 <>= subroutine sm_physics_2 (u) integer, intent(in) :: u real(default) :: mtop, mw, mz, mb, g_mu, sinthw, alpha, vtb, gamma0 real(default) :: w2, alphas, alphas_mz, gamma1 write (u, "(A)") "* Test output: sm_physics_2" write (u, "(A)") "* Purpose: Check different top width computations" write (u, "(A)") write (u, "(A)") "* Values from [[1207.5018]] (massless b)" mtop = 172.0 mw = 80.399 mz = 91.1876 mb = zero mb = 0.00001 g_mu = 1.16637E-5 sinthw = sqrt(one - mw**2 / mz**2) alpha = alpha_from_g_mu (g_mu, mw, sinthw) vtb = one w2 = mw**2 / mtop**2 write (u, "(A)") "* Check Li2 implementation" call assert_equal (u, Li2(w2), 0.2317566263959552_default, & "Li2(w2)", rel_smallness=1.0E-6_default) call assert_equal (u, Li2(one - w2), 1.038200378935867_default, & "Li2(one - w2)", rel_smallness=1.0E-6_default) write (u, "(A)") "* Check LO Width" gamma0 = top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb) call assert_equal (u, gamma0, 1.4655_default, & "top_width_sm_lo", rel_smallness=1.0E-5_default) alphas = zero gamma0 = top_width_sm_qcd_nlo_massless_b & (alpha, sinthw, vtb, mtop, mw, alphas) call assert_equal (u, gamma0, 1.4655_default, & "top_width_sm_qcd_nlo_massless_b", rel_smallness=1.0E-5_default) gamma0 = top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) call assert_equal (u, gamma0, 1.4655_default, & "top_width_sm_qcd_nlo", rel_smallness=1.0E-5_default) write (u, "(A)") "* Check NLO Width" alphas_mz = 0.1202 ! MSTW2008 NLO fit alphas = running_as (mtop, alphas_mz, mz, 1, 5.0_default) gamma1 = top_width_sm_qcd_nlo_massless_b & (alpha, sinthw, vtb, mtop, mw, alphas) call assert_equal (u, gamma1, 1.3376_default, rel_smallness=1.0E-4_default) gamma1 = top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) ! It would be nice to get one more significant digit but the ! expression is numerically rather unstable for mb -> 0 call assert_equal (u, gamma1, 1.3376_default, rel_smallness=1.0E-3_default) write (u, "(A)") "* Values from threshold validation (massive b)" alpha = one / 125.924 ! ee = 0.315901 ! cw = 0.881903 ! v = 240.024 mtop = 172.0 ! This is the value for M1S !!! mb = 4.2 sinthw = 0.47143 mz = 91.188 mw = 80.419 call assert_equal (u, sqrt(one - mw**2 / mz**2), sinthw, & "sinthw", rel_smallness=1.0E-6_default) write (u, "(A)") "* Check LO Width" gamma0 = top_width_sm_lo (alpha, sinthw, vtb, mtop, mw, mb) call assert_equal (u, gamma0, 1.5386446_default, & "gamma0", rel_smallness=1.0E-7_default) alphas = zero gamma0 = top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) call assert_equal (u, gamma0, 1.5386446_default, & "gamma0", rel_smallness=1.0E-7_default) write (u, "(A)") "* Check NLO Width" alphas_mz = 0.118 !(Z pole, NLL running to mu_h) alphas = running_as (mtop, alphas_mz, mz, 1, 5.0_default) write (u, "(A," // FMT_15 // ")") "* alphas = ", alphas gamma1 = top_width_sm_qcd_nlo_jk & (alpha, sinthw, vtb, mtop, mw, mb, alphas) write (u, "(A," // FMT_15 // ")") "* Gamma1 = ", gamma1 mb = zero gamma1 = top_width_sm_qcd_nlo_massless_b & (alpha, sinthw, vtb, mtop, mw, alphas) alphas = running_as (mtop, alphas_mz, mz, 1, 5.0_default) write (u, "(A," // FMT_15 // ")") "* Gamma1(mb=0) = ", gamma1 write (u, "(A)") write (u, "(A)") "* Test output end: sm_physics_2" end subroutine sm_physics_2 @ %def sm_physics_2 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{QCD Coupling} We provide various distinct implementations of the QCD coupling. In this module, we define an abstract data type and three implementations: fixed, running with $\alpha_s(M_Z)$ as input, and running with $\Lambda_{\text{QCD}}$ as input. We use the functions defined above in the module [[sm_physics]] but provide a common interface. Later modules may define additional implementations. <<[[sm_qcd.f90]]>>= <> module sm_qcd <> use io_units use format_defs, only: FMT_12 use numeric_utils use diagnostics use md5 use physics_defs use sm_physics <> <> <> <> contains <> end module sm_qcd @ %def sm_qcd @ \subsection{Coupling: Abstract Data Type} This is the abstract version of the QCD coupling implementation. <>= public :: alpha_qcd_t <>= type, abstract :: alpha_qcd_t contains <> end type alpha_qcd_t @ %def alpha_qcd_t @ There must be an output routine. <>= procedure (alpha_qcd_write), deferred :: write <>= abstract interface subroutine alpha_qcd_write (object, unit) import class(alpha_qcd_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine alpha_qcd_write end interface @ %def alpha_qcd_write @ This method computes the running coupling, given a certain scale. All parameters (reference value, order of the approximation, etc.) must be set before calling this. <>= procedure (alpha_qcd_get), deferred :: get <>= abstract interface function alpha_qcd_get (alpha_qcd, scale) result (alpha) import class(alpha_qcd_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha end function alpha_qcd_get end interface @ %def alpha_qcd_get @ \subsection{Fixed Coupling} In this version, the $\alpha_s$ value is fixed, the [[scale]] argument of the [[get]] method is ignored. There is only one parameter, the value. By default, this is the value at $M_Z$. <>= public :: alpha_qcd_fixed_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_fixed_t real(default) :: val = ALPHA_QCD_MZ_REF contains <> end type alpha_qcd_fixed_t @ %def alpha_qcd_fixed_t @ Output. <>= procedure :: write => alpha_qcd_fixed_write <>= subroutine alpha_qcd_fixed_write (object, unit) class(alpha_qcd_fixed_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A)") "QCD parameters (fixed coupling):" write (u, "(5x,A," // FMT_12 // ")") "alpha = ", object%val end subroutine alpha_qcd_fixed_write @ %def alpha_qcd_fixed_write @ Calculation: the scale is ignored in this case. <>= procedure :: get => alpha_qcd_fixed_get <>= function alpha_qcd_fixed_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_fixed_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha alpha = alpha_qcd%val end function alpha_qcd_fixed_get @ %def alpha_qcd_fixed_get @ \subsection{Running Coupling} In this version, the $\alpha_s$ value runs relative to the value at a given reference scale. There are two parameters: the value of this scale (default: $M_Z$), the value of $\alpha_s$ at this scale, and the number of effective flavors. Furthermore, we have the order of the approximation. <>= public :: alpha_qcd_from_scale_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_from_scale_t real(default) :: mu_ref = MZ_REF real(default) :: ref = ALPHA_QCD_MZ_REF integer :: order = 0 integer :: nf = 5 contains <> end type alpha_qcd_from_scale_t @ %def alpha_qcd_from_scale_t @ Output. <>= procedure :: write => alpha_qcd_from_scale_write <>= subroutine alpha_qcd_from_scale_write (object, unit) class(alpha_qcd_from_scale_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A)") "QCD parameters (running coupling):" write (u, "(5x,A," // FMT_12 // ")") "Scale mu = ", object%mu_ref write (u, "(5x,A," // FMT_12 // ")") "alpha(mu) = ", object%ref write (u, "(5x,A,I0)") "LL order = ", object%order write (u, "(5x,A,I0)") "N(flv) = ", object%nf end subroutine alpha_qcd_from_scale_write @ %def alpha_qcd_from_scale_write @ Calculation: here, we call the function for running $\alpha_s$ that was defined in [[sm_physics]] above. The function does not take into account thresholds, so the number of flavors should be the correct one for the chosen scale. Normally, this should be the $Z$ boson mass. <>= procedure :: get => alpha_qcd_from_scale_get <>= function alpha_qcd_from_scale_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_from_scale_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha alpha = running_as (scale, & alpha_qcd%ref, alpha_qcd%mu_ref, alpha_qcd%order, & real (alpha_qcd%nf, kind=default)) end function alpha_qcd_from_scale_get @ %def alpha_qcd_from_scale_get @ \subsection{Running Coupling, determined by $\Lambda_{\text{QCD}}$} In this version, the input are the value $\Lambda_{\text{QCD}}$ and the order of the approximation. <>= public :: alpha_qcd_from_lambda_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_from_lambda_t real(default) :: lambda = LAMBDA_QCD_REF integer :: order = 0 integer :: nf = 5 contains <> end type alpha_qcd_from_lambda_t @ %def alpha_qcd_from_lambda_t @ Output. <>= procedure :: write => alpha_qcd_from_lambda_write <>= subroutine alpha_qcd_from_lambda_write (object, unit) class(alpha_qcd_from_lambda_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A)") "QCD parameters (Lambda_QCD as input):" write (u, "(5x,A," // FMT_12 // ")") "Lambda_QCD = ", object%lambda write (u, "(5x,A,I0)") "LL order = ", object%order write (u, "(5x,A,I0)") "N(flv) = ", object%nf end subroutine alpha_qcd_from_lambda_write @ %def alpha_qcd_from_lambda_write @ Calculation: here, we call the second function for running $\alpha_s$ that was defined in [[sm_physics]] above. The $\Lambda$ value should be the one that is appropriate for the chosen number of effective flavors. Again, thresholds are not incorporated. <>= procedure :: get => alpha_qcd_from_lambda_get <>= function alpha_qcd_from_lambda_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_from_lambda_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha alpha = running_as_lam (real (alpha_qcd%nf, kind=default), scale, & alpha_qcd%lambda, alpha_qcd%order) end function alpha_qcd_from_lambda_get @ %def alpha_qcd_from_lambda_get @ \subsection{Wrapper type} We could get along with a polymorphic QCD type, but a monomorphic wrapper type with a polymorphic component is easier to handle and probably safer (w.r.t.\ compiler bugs). However, we keep the object transparent, so we can set the type-specific parameters directly (by a [[dispatch]] routine). - -TODO: The [[n_f]] parameter is a later addition which is not printed -nor used in the MD5 sum. The default $-1$ indicates that it has not -been set. We may change this behavior for a more consistent handling of -the $n_f$ parameter (cf.\ [[alphas_nf]]) within WHIZARD. This would -affect various MD5 sums in tests. <>= public :: qcd_t <>= type :: qcd_t class(alpha_qcd_t), allocatable :: alpha character(32) :: md5sum = "" integer :: n_f = -1 contains <> end type qcd_t @ %def qcd_t @ Output. We first print the polymorphic [[alpha]] which contains a headline, then any extra components. <>= procedure :: write => qcd_write <>= subroutine qcd_write (qcd, unit, show_md5sum) class(qcd_t), intent(in) :: qcd integer, intent(in), optional :: unit logical, intent(in), optional :: show_md5sum logical :: show_md5 integer :: u u = given_output_unit (unit); if (u < 0) return show_md5 = .true.; if (present (show_md5sum)) show_md5 = show_md5sum if (allocated (qcd%alpha)) then call qcd%alpha%write (u) else write (u, "(3x,A)") "QCD parameters (coupling undefined)" end if if (show_md5 .and. qcd%md5sum /= "") & write (u, "(5x,A,A,A)") "md5sum = '", qcd%md5sum, "'" end subroutine qcd_write @ %def qcd_write @ Compute an MD5 sum for the [[alpha_s]] setup. This is done by writing them to a temporary file, using a standard format. <>= procedure :: compute_alphas_md5sum => qcd_compute_alphas_md5sum <>= subroutine qcd_compute_alphas_md5sum (qcd) class(qcd_t), intent(inout) :: qcd integer :: unit if (allocated (qcd%alpha)) then unit = free_unit () open (unit, status="scratch", action="readwrite") call qcd%alpha%write (unit) rewind (unit) qcd%md5sum = md5sum (unit) close (unit) end if end subroutine qcd_compute_alphas_md5sum @ %def qcd_compute_alphas_md5sum @ @ Retrieve the MD5 sum of the qcd setup. <>= procedure :: get_md5sum => qcd_get_md5sum <>= function qcd_get_md5sum (qcd) result (md5sum) character(32) :: md5sum class(qcd_t), intent(inout) :: qcd md5sum = qcd%md5sum end function qcd_get_md5sum @ %def qcd_get_md5sum @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sm_qcd_ut.f90]]>>= <> module sm_qcd_ut use unit_tests use sm_qcd_uti <> <> contains <> end module sm_qcd_ut @ %def sm_qcd_ut @ <<[[sm_qcd_uti.f90]]>>= <> module sm_qcd_uti <> use physics_defs, only: MZ_REF use sm_qcd <> <> contains <> end module sm_qcd_uti @ %def sm_qcd_ut @ API: driver for the unit tests below. <>= public :: sm_qcd_test <>= subroutine sm_qcd_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sm_qcd_test @ %def sm_qcd_test @ \subsubsection{QCD Coupling} We check two different implementations of the abstract QCD coupling. <>= call test (sm_qcd_1, "sm_qcd_1", & "running alpha_s", & u, results) <>= public :: sm_qcd_1 <>= subroutine sm_qcd_1 (u) integer, intent(in) :: u type(qcd_t) :: qcd write (u, "(A)") "* Test output: sm_qcd_1" write (u, "(A)") "* Purpose: compute running alpha_s" write (u, "(A)") write (u, "(A)") "* Fixed:" write (u, "(A)") allocate (alpha_qcd_fixed_t :: qcd%alpha) call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) deallocate (qcd%alpha) write (u, "(A)") "* Running from MZ (LO):" write (u, "(A)") allocate (alpha_qcd_from_scale_t :: qcd%alpha) call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from MZ (NLO):" write (u, "(A)") select type (alpha => qcd%alpha) type is (alpha_qcd_from_scale_t) alpha%order = 1 end select call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from MZ (NNLO):" write (u, "(A)") select type (alpha => qcd%alpha) type is (alpha_qcd_from_scale_t) alpha%order = 2 end select call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) deallocate (qcd%alpha) write (u, "(A)") "* Running from Lambda_QCD (LO):" write (u, "(A)") allocate (alpha_qcd_from_lambda_t :: qcd%alpha) call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from Lambda_QCD (NLO):" write (u, "(A)") select type (alpha => qcd%alpha) type is (alpha_qcd_from_lambda_t) alpha%order = 1 end select call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, *) write (u, "(A)") "* Running from Lambda_QCD (NNLO):" write (u, "(A)") select type (alpha => qcd%alpha) type is (alpha_qcd_from_lambda_t) alpha%order = 2 end select call qcd%compute_alphas_md5sum () call qcd%write (u) write (u, *) write (u, "(1x,A,F10.7)") "alpha_s (mz) =", & qcd%alpha%get (MZ_REF) write (u, "(1x,A,F10.7)") "alpha_s (1 TeV) =", & qcd%alpha%get (1000._default) write (u, "(A)") write (u, "(A)") "* Test output end: sm_qcd_1" end subroutine sm_qcd_1 @ %def sm_qcd_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Shower algorithms} <<[[shower_algorithms.f90]]>>= <> module shower_algorithms <> use diagnostics use constants <> <> <> contains <> <> end module shower_algorithms @ %def shower_algorithms @ We want to generate emission variables [[x]]$\in\mathds{R}^d$ proportional to \begin{align} &\quad f(x)\; \Delta(f, h(x)) \quad\text{with}\\ \Delta(f, H) &= \exp\left\{-\int\text{d}^d x'f(x') \Theta(h(x') - H)\right\} \end{align} The [[true_function]] $f$ is however too complicated and we are only able to generate [[x]] according to the [[overestimator]] $F$. This algorithm is described in Appendix B of 0709.2092 and is proven e.g.~in 1211.7204 and hep-ph/0606275. Intuitively speaking, we overestimate the emission probability and can therefore set [[scale_max = scale]] if the emission is rejected. <>= subroutine generate_vetoed (x, overestimator, true_function, & sudakov, inverse_sudakov, scale_min) real(default), dimension(:), intent(out) :: x !class(rng_t), intent(inout) :: rng procedure(XXX_function), pointer, intent(in) :: overestimator, true_function procedure(sudakov_p), pointer, intent(in) :: sudakov, inverse_sudakov real(default), intent(in) :: scale_min real(default) :: random, scale_max, scale scale_max = inverse_sudakov (one) do while (scale_max > scale_min) !call rng%generate (random) scale = inverse_sudakov (random * sudakov (scale_max)) call generate_on_hypersphere (x, overestimator, scale) !call rng%generate (random) if (random < true_function (x) / overestimator (x)) then return !!! accept x end if scale_max = scale end do end subroutine generate_vetoed @ %def generate_vetoed @ <>= subroutine generate_on_hypersphere (x, overestimator, scale) real(default), dimension(:), intent(out) :: x procedure(XXX_function), pointer, intent(in) :: overestimator real(default), intent(in) :: scale call msg_bug ("generate_on_hypersphere: not implemented") end subroutine generate_on_hypersphere @ %def generate_on_hypersphere @ <>= interface pure function XXX_function (x) import real(default) :: XXX_function real(default), dimension(:), intent(in) :: x end function XXX_function end interface interface pure function sudakov_p (x) import real(default) :: sudakov_p real(default), intent(in) :: x end function sudakov_p end interface @ \subsection{Unit tests} (Currently unused.) <>= public :: shower_algorithms_test <>= subroutine shower_algorithms_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine shower_algorithms_test @ %def shower_algorithms_test @ \subsubsection{Splitting functions} <>= call test (shower_algorithms_1, "shower_algorithms_1", & "veto technique", & u, results) <>= subroutine shower_algorithms_1 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: shower_algorithms_1" write (u, "(A)") "* Purpose: check veto technique" write (u, "(A)") write (u, "(A)") "* Splitting functions:" write (u, "(A)") !call assert (u, vanishes (p_qqg_pol (z, +1, -1, +1))) !call assert (u, nearly_equal ( & !p_qqg_pol (z, +1, +1, -1) + p_qqg_pol (z, +1, +1, +1), !p_qqg (z)) write (u, "(A)") write (u, "(A)") "* Test output end: shower_algorithms_1" end subroutine shower_algorithms_1 @ %def shower_algorithms_1 Index: trunk/src/beams/beams.nw =================================================================== --- trunk/src/beams/beams.nw (revision 8234) +++ trunk/src/beams/beams.nw (revision 8235) @@ -1,25221 +1,25220 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: beams and beam structure %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Beams} \includemodulegraph{beams} These modules implement beam configuration and beam structure, the latter in abstract terms. \begin{description} \item[beam\_structures] The [[beam_structure_t]] type is a messenger type that communicates the user settings to the \whizard\ core. \item[beams] Beam configuration. \item[sf\_aux] Tools for handling structure functions and splitting \item[sf\_mappings] Mapping functions, useful for structure function implementation \item[sf\_base] The abstract structure-function interaction and structure-function chain types. \end{description} These are the implementation modules, the concrete counterparts of [[sf_base]]: \begin{description} \item[sf\_isr] ISR structure function (photon radiation inclusive and resummed in collinear and IR regions). \item[sf\_epa] Effective Photon Approximation. \item[sf\_ewa] Effective $W$ (and $Z$) approximation. \item[sf\_escan] Energy spectrum that emulates a uniform energy scan. \item[sf\_gaussian] Gaussian beam spread \item[sf\_beam\_events] Beam-event generator that reads its input from an external file. \item[sf\_circe1] CIRCE1 beam spectra for electrons and photons. \item[sf\_circe2] CIRCE2 beam spectra for electrons and photons. \item[hoppet\_interface] Support for $b$-quark matching, addon to PDF modules. \item[sf\_pdf\_builtin] Direct support for selected hadron PDFs. \item[sf\_lhapdf] LHAPDF library support. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Beam structure} This module stores the beam structure definition as it is declared in the SINDARIN script. The structure definition is not analyzed, just recorded for later use. We do not capture any numerical parameters, just names of particles and structure functions. <<[[beam_structures.f90]]>>= <> module beam_structures <> <> use io_units use format_defs, only: FMT_19 use diagnostics use lorentz use polarizations <> <> <> <> contains <> end module beam_structures @ %def beam_structures @ \subsection{Beam structure elements} An entry in a beam-structure record consists of a string that denotes a type of structure function. <>= type :: beam_structure_entry_t logical :: is_valid = .false. type(string_t) :: name contains <> end type beam_structure_entry_t @ %def beam_structure_entry_t @ Output. <>= procedure :: to_string => beam_structure_entry_to_string <>= function beam_structure_entry_to_string (object) result (string) class(beam_structure_entry_t), intent(in) :: object type(string_t) :: string if (object%is_valid) then string = object%name else string = "none" end if end function beam_structure_entry_to_string @ %def beam_structure_entry_to_string @ A record in the beam-structure sequence denotes either a structure-function entry, a pair of such entries, or a pair spectrum. <>= type :: beam_structure_record_t type(beam_structure_entry_t), dimension(:), allocatable :: entry end type beam_structure_record_t @ %def beam_structure_record_t @ \subsection{Beam structure type} The beam-structure object contains the beam particle(s) as simple strings. The sequence of records indicates the structure functions by name. No numerical parameters are stored. <>= public :: beam_structure_t <>= type :: beam_structure_t private integer :: n_beam = 0 type(string_t), dimension(:), allocatable :: prt type(beam_structure_record_t), dimension(:), allocatable :: record type(smatrix_t), dimension(:), allocatable :: smatrix real(default), dimension(:), allocatable :: pol_f real(default), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: theta real(default), dimension(:), allocatable :: phi contains <> end type beam_structure_t @ %def beam_structure_t @ The finalizer deletes all contents explicitly, so we can continue with an empty beam record. (It is not needed for deallocation.) We have distinct finalizers for the independent parts of the beam structure. <>= procedure :: final_sf => beam_structure_final_sf <>= subroutine beam_structure_final_sf (object) class(beam_structure_t), intent(inout) :: object if (allocated (object%prt)) deallocate (object%prt) if (allocated (object%record)) deallocate (object%record) object%n_beam = 0 end subroutine beam_structure_final_sf @ %def beam_structure_final_sf @ Output. The actual information fits in a single line, therefore we can provide a [[to_string]] method. The [[show]] method also lists the current values of relevant global variables. <>= procedure :: write => beam_structure_write procedure :: to_string => beam_structure_to_string <>= subroutine beam_structure_write (object, unit) class(beam_structure_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A,A)") "Beam structure: ", char (object%to_string ()) if (allocated (object%smatrix)) then do i = 1, size (object%smatrix) write (u, "(3x,A,I0,A)") "polarization (beam ", i, "):" call object%smatrix(i)%write (u, indent=2) end do end if if (allocated (object%pol_f)) then write (u, "(3x,A,F10.7,:,',',F10.7)") "polarization degree =", & object%pol_f end if if (allocated (object%p)) then write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // & ")") "momentum =", object%p end if if (allocated (object%theta)) then write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // & ")") "angle th =", object%theta end if if (allocated (object%phi)) then write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // & ")") "angle ph =", object%phi end if end subroutine beam_structure_write function beam_structure_to_string (object, sf_only) result (string) class(beam_structure_t), intent(in) :: object logical, intent(in), optional :: sf_only type(string_t) :: string integer :: i, j logical :: with_beams with_beams = .true.; if (present (sf_only)) with_beams = .not. sf_only select case (object%n_beam) case (1) if (with_beams) then string = object%prt(1) else string = "" end if case (2) if (with_beams) then string = object%prt(1) // ", " // object%prt(2) else string = "" end if if (allocated (object%record)) then if (size (object%record) > 0) then if (with_beams) string = string // " => " do i = 1, size (object%record) if (i > 1) string = string // " => " do j = 1, size (object%record(i)%entry) if (j > 1) string = string // ", " string = string // object%record(i)%entry(j)%to_string () end do end do end if end if case default string = "[any particles]" end select end function beam_structure_to_string @ %def beam_structure_write beam_structure_to_string @ Initializer: dimension the beam structure record. Each array element denotes the number of entries for a record within the beam-structure sequence. The number of entries is either one or two, while the number of records is unlimited. <>= procedure :: init_sf => beam_structure_init_sf <>= subroutine beam_structure_init_sf (beam_structure, prt, dim_array) class(beam_structure_t), intent(inout) :: beam_structure type(string_t), dimension(:), intent(in) :: prt integer, dimension(:), intent(in), optional :: dim_array integer :: i call beam_structure%final_sf () beam_structure%n_beam = size (prt) allocate (beam_structure%prt (size (prt))) beam_structure%prt = prt if (present (dim_array)) then allocate (beam_structure%record (size (dim_array))) do i = 1, size (dim_array) allocate (beam_structure%record(i)%entry (dim_array(i))) end do else allocate (beam_structure%record (0)) end if end subroutine beam_structure_init_sf @ %def beam_structure_init_sf @ Set an entry, specified by record number and entry number. <>= procedure :: set_sf => beam_structure_set_sf <>= subroutine beam_structure_set_sf (beam_structure, i, j, name) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i, j type(string_t), intent(in) :: name associate (entry => beam_structure%record(i)%entry(j)) entry%name = name entry%is_valid = .true. end associate end subroutine beam_structure_set_sf @ %def beam_structure_set_sf @ Expand the beam-structure object. (i) For a pair spectrum, keep the entry. (ii) For a single-particle structure function written as a single entry, replace this by a record with two entries. (ii) For a record with two nontrivial entries, separate this into two records with one trivial entry each. To achieve this, we need a function that tells us whether an entry is a spectrum or a structure function. It returns 0 for a trivial entry, 1 for a single-particle structure function, and 2 for a two-particle spectrum. <>= abstract interface function strfun_mode_fun (name) result (n) import type(string_t), intent(in) :: name integer :: n end function strfun_mode_fun end interface @ %def is_spectrum_t @ Algorithm: (1) Mark entries as invalid where necessary. (2) Count the number of entries that we will need. (3) Expand and copy entries to a new record array. (4) Replace the old array by the new one. <>= procedure :: expand => beam_structure_expand <>= subroutine beam_structure_expand (beam_structure, strfun_mode) class(beam_structure_t), intent(inout) :: beam_structure procedure(strfun_mode_fun) :: strfun_mode type(beam_structure_record_t), dimension(:), allocatable :: new integer :: n_record, i, j if (.not. allocated (beam_structure%record)) return do i = 1, size (beam_structure%record) associate (entry => beam_structure%record(i)%entry) do j = 1, size (entry) select case (strfun_mode (entry(j)%name)) case (0); entry(j)%is_valid = .false. end select end do end associate end do n_record = 0 do i = 1, size (beam_structure%record) associate (entry => beam_structure%record(i)%entry) select case (size (entry)) case (1) if (entry(1)%is_valid) then select case (strfun_mode (entry(1)%name)) case (1); n_record = n_record + 2 case (2); n_record = n_record + 1 end select end if case (2) do j = 1, 2 if (entry(j)%is_valid) then select case (strfun_mode (entry(j)%name)) case (1); n_record = n_record + 1 case (2) call beam_structure%write () call msg_fatal ("Pair spectrum used as & &single-particle structure function") end select end if end do end select end associate end do allocate (new (n_record)) n_record = 0 do i = 1, size (beam_structure%record) associate (entry => beam_structure%record(i)%entry) select case (size (entry)) case (1) if (entry(1)%is_valid) then select case (strfun_mode (entry(1)%name)) case (1) n_record = n_record + 1 allocate (new(n_record)%entry (2)) new(n_record)%entry(1) = entry(1) n_record = n_record + 1 allocate (new(n_record)%entry (2)) new(n_record)%entry(2) = entry(1) case (2) n_record = n_record + 1 allocate (new(n_record)%entry (1)) new(n_record)%entry(1) = entry(1) end select end if case (2) do j = 1, 2 if (entry(j)%is_valid) then n_record = n_record + 1 allocate (new(n_record)%entry (2)) new(n_record)%entry(j) = entry(j) end if end do end select end associate end do call move_alloc (from = new, to = beam_structure%record) end subroutine beam_structure_expand @ %def beam_structure_expand @ \subsection{Polarization} To record polarization, we provide an allocatable array of [[smatrix]] objects, sparse matrices. The polarization structure is independent of the structure-function setup, they are combined only when an actual beam object is constructed. <>= procedure :: final_pol => beam_structure_final_pol procedure :: init_pol => beam_structure_init_pol <>= subroutine beam_structure_final_pol (beam_structure) class(beam_structure_t), intent(inout) :: beam_structure if (allocated (beam_structure%smatrix)) deallocate (beam_structure%smatrix) if (allocated (beam_structure%pol_f)) deallocate (beam_structure%pol_f) end subroutine beam_structure_final_pol subroutine beam_structure_init_pol (beam_structure, n) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: n if (allocated (beam_structure%smatrix)) deallocate (beam_structure%smatrix) allocate (beam_structure%smatrix (n)) if (.not. allocated (beam_structure%pol_f)) & allocate (beam_structure%pol_f (n), source = 1._default) end subroutine beam_structure_init_pol @ %def beam_structure_final_pol @ %def beam_structure_init_pol @ Check if polarized beams are used. <>= procedure :: has_polarized_beams => beam_structure_has_polarized_beams <>= elemental function beam_structure_has_polarized_beams (beam_structure) result (pol) logical :: pol class(beam_structure_t), intent(in) :: beam_structure if (allocated (beam_structure%pol_f)) then pol = any (beam_structure%pol_f /= 0) else pol = .false. end if end function beam_structure_has_polarized_beams @ %def beam_structure_has_polarized_beams @ Directly copy the spin density matrices. <>= procedure :: set_smatrix => beam_structure_set_smatrix <>= subroutine beam_structure_set_smatrix (beam_structure, i, smatrix) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i type(smatrix_t), intent(in) :: smatrix beam_structure%smatrix(i) = smatrix end subroutine beam_structure_set_smatrix @ %def beam_structure_set_smatrix @ Initialize one of the spin density matrices manually. <>= procedure :: init_smatrix => beam_structure_init_smatrix <>= subroutine beam_structure_init_smatrix (beam_structure, i, n_entry) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i integer, intent(in) :: n_entry call beam_structure%smatrix(i)%init (2, n_entry) end subroutine beam_structure_init_smatrix @ %def beam_structure_init_smatrix @ Set a polarization entry. <>= procedure :: set_sentry => beam_structure_set_sentry <>= subroutine beam_structure_set_sentry & (beam_structure, i, i_entry, index, value) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i integer, intent(in) :: i_entry integer, dimension(:), intent(in) :: index complex(default), intent(in) :: value call beam_structure%smatrix(i)%set_entry (i_entry, index, value) end subroutine beam_structure_set_sentry @ %def beam_structure_set_sentry @ Set the array of polarization fractions. <>= procedure :: set_pol_f => beam_structure_set_pol_f <>= subroutine beam_structure_set_pol_f (beam_structure, f) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: f if (allocated (beam_structure%pol_f)) deallocate (beam_structure%pol_f) allocate (beam_structure%pol_f (size (f)), source = f) end subroutine beam_structure_set_pol_f @ %def beam_structure_set_pol_f @ \subsection{Beam momenta} By default, beam momenta are deduced from the [[sqrts]] value or from the mass of the decaying particle, assuming a c.m.\ setup. Here we set them explicitly. <>= procedure :: final_mom => beam_structure_final_mom <>= subroutine beam_structure_final_mom (beam_structure) class(beam_structure_t), intent(inout) :: beam_structure if (allocated (beam_structure%p)) deallocate (beam_structure%p) if (allocated (beam_structure%theta)) deallocate (beam_structure%theta) if (allocated (beam_structure%phi)) deallocate (beam_structure%phi) end subroutine beam_structure_final_mom @ %def beam_structure_final_mom <>= procedure :: set_momentum => beam_structure_set_momentum procedure :: set_theta => beam_structure_set_theta procedure :: set_phi => beam_structure_set_phi <>= subroutine beam_structure_set_momentum (beam_structure, p) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: p if (allocated (beam_structure%p)) deallocate (beam_structure%p) allocate (beam_structure%p (size (p)), source = p) end subroutine beam_structure_set_momentum subroutine beam_structure_set_theta (beam_structure, theta) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: theta if (allocated (beam_structure%theta)) deallocate (beam_structure%theta) allocate (beam_structure%theta (size (theta)), source = theta) end subroutine beam_structure_set_theta subroutine beam_structure_set_phi (beam_structure, phi) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: phi if (allocated (beam_structure%phi)) deallocate (beam_structure%phi) allocate (beam_structure%phi (size (phi)), source = phi) end subroutine beam_structure_set_phi @ %def beam_structure_set_momentum @ %def beam_structure_set_theta @ %def beam_structure_set_phi @ \subsection{Get contents} Look at the incoming particles. We may also have the case that beam particles are not specified, but polarization. <>= procedure :: is_set => beam_structure_is_set procedure :: get_n_beam => beam_structure_get_n_beam procedure :: get_prt => beam_structure_get_prt <>= function beam_structure_is_set (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag flag = beam_structure%n_beam > 0 .or. beam_structure%asymmetric () end function beam_structure_is_set function beam_structure_get_n_beam (beam_structure) result (n) class(beam_structure_t), intent(in) :: beam_structure integer :: n n = beam_structure%n_beam end function beam_structure_get_n_beam function beam_structure_get_prt (beam_structure) result (prt) class(beam_structure_t), intent(in) :: beam_structure type(string_t), dimension(:), allocatable :: prt allocate (prt (size (beam_structure%prt))) prt = beam_structure%prt end function beam_structure_get_prt @ %def beam_structure_is_set @ %def beam_structure_get_n_beam @ %def beam_structure_get_prt @ Return the number of records. <>= procedure :: get_n_record => beam_structure_get_n_record <>= function beam_structure_get_n_record (beam_structure) result (n) class(beam_structure_t), intent(in) :: beam_structure integer :: n if (allocated (beam_structure%record)) then n = size (beam_structure%record) else n = 0 end if end function beam_structure_get_n_record @ %def beam_structure_get_n_record @ Return an array consisting of the beam indices affected by the valid entries within a record. After expansion, there should be exactly one valid entry per record. <>= procedure :: get_i_entry => beam_structure_get_i_entry <>= function beam_structure_get_i_entry (beam_structure, i) result (i_entry) class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: i integer, dimension(:), allocatable :: i_entry associate (record => beam_structure%record(i)) select case (size (record%entry)) case (1) if (record%entry(1)%is_valid) then allocate (i_entry (2), source = [1, 2]) else allocate (i_entry (0)) end if case (2) if (all (record%entry%is_valid)) then allocate (i_entry (2), source = [1, 2]) else if (record%entry(1)%is_valid) then allocate (i_entry (1), source = [1]) else if (record%entry(2)%is_valid) then allocate (i_entry (1), source = [2]) else allocate (i_entry (0)) end if end select end associate end function beam_structure_get_i_entry @ %def beam_structure_get_i_entry @ Return the name of the first valid entry within a record. After expansion, there should be exactly one valid entry per record. <>= procedure :: get_name => beam_structure_get_name <>= function beam_structure_get_name (beam_structure, i) result (name) type(string_t) :: name class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: i associate (record => beam_structure%record(i)) if (record%entry(1)%is_valid) then name = record%entry(1)%name else if (size (record%entry) == 2) then name = record%entry(2)%name end if end associate end function beam_structure_get_name @ %def beam_structure_get_name @ <>= procedure :: has_pdf => beam_structure_has_pdf <>= function beam_structure_has_pdf (beam_structure) result (has_pdf) logical :: has_pdf class(beam_structure_t), intent(in) :: beam_structure integer :: i type(string_t) :: name has_pdf = .false. do i = 1, beam_structure%get_n_record () name = beam_structure%get_name (i) has_pdf = has_pdf .or. name == var_str ("pdf_builtin") .or. name == var_str ("lhapdf") end do end function beam_structure_has_pdf @ %def beam_structure_has_pdf @ Return true if the beam structure contains a particular structure function identifier (such as [[lhapdf]], [[isr]], etc.) <>= procedure :: contains => beam_structure_contains <>= function beam_structure_contains (beam_structure, name) result (flag) class(beam_structure_t), intent(in) :: beam_structure character(*), intent(in) :: name logical :: flag integer :: i, j flag = .false. if (allocated (beam_structure%record)) then do i = 1, size (beam_structure%record) do j = 1, size (beam_structure%record(i)%entry) flag = beam_structure%record(i)%entry(j)%name == name if (flag) return end do end do end if end function beam_structure_contains @ %def beam_structure_contains @ Return polarization data. <>= procedure :: polarized => beam_structure_polarized procedure :: get_smatrix => beam_structure_get_smatrix procedure :: get_pol_f => beam_structure_get_pol_f procedure :: asymmetric => beam_structure_asymmetric <>= function beam_structure_polarized (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag flag = allocated (beam_structure%smatrix) end function beam_structure_polarized function beam_structure_get_smatrix (beam_structure) result (smatrix) class(beam_structure_t), intent(in) :: beam_structure type(smatrix_t), dimension(:), allocatable :: smatrix allocate (smatrix (size (beam_structure%smatrix)), & source = beam_structure%smatrix) end function beam_structure_get_smatrix function beam_structure_get_pol_f (beam_structure) result (pol_f) class(beam_structure_t), intent(in) :: beam_structure real(default), dimension(:), allocatable :: pol_f allocate (pol_f (size (beam_structure%pol_f)), & source = beam_structure%pol_f) end function beam_structure_get_pol_f function beam_structure_asymmetric (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag flag = allocated (beam_structure%p) & .or. allocated (beam_structure%theta) & .or. allocated (beam_structure%phi) end function beam_structure_asymmetric @ %def beam_structure_polarized @ %def beam_structure_get_smatrix @ %def beam_structure_get_pol_f @ %def beam_structure_asymmetric @ Return the beam momenta (the space part, i.e., three-momenta). This is meaningful only if momenta and, optionally, angles have been set. <>= procedure :: get_momenta => beam_structure_get_momenta <>= function beam_structure_get_momenta (beam_structure) result (p) class(beam_structure_t), intent(in) :: beam_structure type(vector3_t), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: theta, phi integer :: n, i if (allocated (beam_structure%p)) then n = size (beam_structure%p) if (allocated (beam_structure%theta)) then if (size (beam_structure%theta) == n) then allocate (theta (n), source = beam_structure%theta) else call msg_fatal ("Beam structure: mismatch in momentum vs. & &angle theta specification") end if else allocate (theta (n), source = 0._default) end if if (allocated (beam_structure%phi)) then if (size (beam_structure%phi) == n) then allocate (phi (n), source = beam_structure%phi) else call msg_fatal ("Beam structure: mismatch in momentum vs. & &angle phi specification") end if else allocate (phi (n), source = 0._default) end if allocate (p (n)) do i = 1, n p(i) = beam_structure%p(i) * vector3_moving ([ & sin (theta(i)) * cos (phi(i)), & sin (theta(i)) * sin (phi(i)), & cos (theta(i))]) end do if (n == 2) p(2) = - p(2) else call msg_fatal ("Beam structure: angle theta/phi specified but & &momentum/a p undefined") end if end function beam_structure_get_momenta @ %def beam_structure_get_momenta @ Check for a complete beam structure. The [[applies]] flag tells if the beam structure should actually be used for a process with the given [[n_in]] number of incoming particles. It set if the beam structure matches the process as either decay or scattering. It is unset if beam structure references a scattering setup but the process is a decay. It is also unset if the beam structure itself is empty. If the beam structure cannot be used, terminate with fatal error. <>= procedure :: check_against_n_in => beam_structure_check_against_n_in <>= subroutine beam_structure_check_against_n_in (beam_structure, n_in, applies) class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: n_in logical, intent(out) :: applies if (beam_structure%is_set ()) then if (n_in == beam_structure%get_n_beam ()) then applies = .true. else if (beam_structure%get_n_beam () == 0) then call msg_fatal & ("Asymmetric beams: missing beam particle specification") applies = .false. else call msg_fatal & ("Mismatch of process and beam setup (scattering/decay)") applies = .false. end if else applies = .false. end if end subroutine beam_structure_check_against_n_in @ %def beam_structure_check_against_n_in @ \subsection{Unit Tests} Test module, followed by the corresponding implementation module. <<[[beam_structures_ut.f90]]>>= <> module beam_structures_ut use unit_tests use beam_structures_uti <> <> contains <> end module beam_structures_ut @ %def beam_structures_ut @ <<[[beam_structures_uti.f90]]>>= <> module beam_structures_uti <> <> use beam_structures <> <> contains <> <> end module beam_structures_uti @ %def beam_structures_ut @ API: driver for the unit tests below. <>= public :: beam_structures_test <>= subroutine beam_structures_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine beam_structures_test @ %def beam_structures_tests @ \subsubsection{Empty structure} <>= call test (beam_structures_1, "beam_structures_1", & "empty beam structure record", & u, results) <>= public :: beam_structures_1 <>= subroutine beam_structures_1 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure write (u, "(A)") "* Test output: beam_structures_1" write (u, "(A)") "* Purpose: display empty beam structure record" write (u, "(A)") call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_1" end subroutine beam_structures_1 @ %def beam_structures_1 @ \subsubsection{Nontrivial configurations} <>= call test (beam_structures_2, "beam_structures_2", & "beam structure records", & u, results) <>= public :: beam_structures_2 <>= subroutine beam_structures_2 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure integer, dimension(0) :: empty_array type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_2" write (u, "(A)") "* Purpose: setup beam structure records" write (u, "(A)") s = "s" call beam_structure%init_sf ([s], empty_array) call beam_structure%write (u) write (u, "(A)") call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%write (u) write (u, "(A)") call beam_structure%init_sf ([s, s], [2]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (1, 2, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%init_sf ([s, s], [2, 1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (1, 2, var_str ("b")) call beam_structure%set_sf (2, 1, var_str ("c")) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_2" end subroutine beam_structures_2 @ %def beam_structures_2 @ \subsubsection{Expansion} Provide a function that tells, for the dummy structure function names used here, whether they are considered a two-particle spectrum or a single-particle structure function: <>= function test_strfun_mode (name) result (n) type(string_t), intent(in) :: name integer :: n select case (char (name)) case ("a"); n = 2 case ("b"); n = 1 case default; n = 0 end select end function test_strfun_mode @ %def test_ist_pair_spectrum @ <>= call test (beam_structures_3, "beam_structures_3", & "beam structure expansion", & u, results) <>= public :: beam_structures_3 <>= subroutine beam_structures_3 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_3" write (u, "(A)") "* Purpose: expand beam structure records" write (u, "(A)") s = "s" write (u, "(A)") "* Pair spectrum (keep as-is)" write (u, "(A)") call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Structure function pair (expand)" write (u, "(A)") call beam_structure%init_sf ([s, s], [2]) call beam_structure%set_sf (1, 1, var_str ("b")) call beam_structure%set_sf (1, 2, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Structure function (separate and expand)" write (u, "(A)") call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Combination" write (u, "(A)") call beam_structure%init_sf ([s, s], [1, 1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (2, 1, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_3" end subroutine beam_structures_3 @ %def beam_structures_3 @ \subsubsection{Public methods} Check the methods that can be called to get the beam-structure contents. <>= call test (beam_structures_4, "beam_structures_4", & "beam structure contents", & u, results) <>= public :: beam_structures_4 <>= subroutine beam_structures_4 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure type(string_t) :: s type(string_t), dimension(2) :: prt integer :: i write (u, "(A)") "* Test output: beam_structures_4" write (u, "(A)") "* Purpose: check the API" write (u, "(A)") s = "s" write (u, "(A)") "* Structure-function combination" write (u, "(A)") call beam_structure%init_sf ([s, s], [1, 2, 2]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (2, 1, var_str ("b")) call beam_structure%set_sf (3, 2, var_str ("c")) call beam_structure%write (u) write (u, *) write (u, "(1x,A,I0)") "n_beam = ", beam_structure%get_n_beam () prt = beam_structure%get_prt () write (u, "(1x,A,2(1x,A))") "prt =", char (prt(1)), char (prt(2)) write (u, *) write (u, "(1x,A,I0)") "n_record = ", beam_structure%get_n_record () do i = 1, 3 write (u, "(A)") write (u, "(1x,A,I0,A,A)") "name(", i, ") = ", & char (beam_structure%get_name (i)) write (u, "(1x,A,I0,A,2(1x,I0))") "i_entry(", i, ") =", & beam_structure%get_i_entry (i) end do write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_4" end subroutine beam_structures_4 @ %def beam_structures_4 @ \subsubsection{Polarization} The polarization properties are independent from the structure-function setup. <>= call test (beam_structures_5, "beam_structures_5", & "polarization", & u, results) <>= public :: beam_structures_5 <>= subroutine beam_structures_5 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure integer, dimension(0) :: empty_array type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_5" write (u, "(A)") "* Purpose: setup polarization in beam structure records" write (u, "(A)") s = "s" call beam_structure%init_sf ([s], empty_array) call beam_structure%init_pol (1) call beam_structure%init_smatrix (1, 1) call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default)) call beam_structure%set_pol_f ([0.5_default]) call beam_structure%write (u) write (u, "(A)") call beam_structure%final_sf () call beam_structure%final_pol () call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 2) call beam_structure%set_sentry (1, 1, [-1,1], (0.5_default,-0.5_default)) call beam_structure%set_sentry (1, 2, [ 1,1], (1._default, 0._default)) call beam_structure%init_smatrix (2, 0) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_5" end subroutine beam_structures_5 @ %def beam_structures_5 @ \subsubsection{Momenta} The momenta are independent from the structure-function setup. <>= call test (beam_structures_6, "beam_structures_6", & "momenta", & u, results) <>= public :: beam_structures_6 <>= subroutine beam_structures_6 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure integer, dimension(0) :: empty_array type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_6" write (u, "(A)") "* Purpose: setup momenta in beam structure records" write (u, "(A)") s = "s" call beam_structure%init_sf ([s], empty_array) call beam_structure%set_momentum ([500._default]) call beam_structure%write (u) write (u, "(A)") call beam_structure%final_sf () call beam_structure%final_mom () call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_momentum ([500._default, 700._default]) call beam_structure%set_theta ([0._default, 0.1_default]) call beam_structure%set_phi ([0._default, 1.51_default]) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_6" end subroutine beam_structures_6 @ %def beam_structures_6 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Beams for collisions and decays} <<[[beams.f90]]>>= <> module beams <> <> use io_units use format_defs, only: FMT_19 use numeric_utils use diagnostics use md5 use lorentz use model_data use flavors use quantum_numbers use state_matrices use interactions use polarizations use beam_structures <> <> <> <> contains <> end module beams @ %def beams @ \subsection{Beam data} The beam data type contains beam data for one or two beams, depending on whether we are dealing with beam collisions or particle decay. In addition, it holds the c.m.\ energy [[sqrts]], the Lorentz transformation [[L]] that transforms the c.m.\ system into the lab system, and the pair of c.m.\ momenta. <>= public :: beam_data_t <>= type :: beam_data_t logical :: initialized = .false. integer :: n = 0 type(flavor_t), dimension(:), allocatable :: flv real(default), dimension(:), allocatable :: mass type(pmatrix_t), dimension(:), allocatable :: pmatrix logical :: lab_is_cm_frame = .true. type(vector4_t), dimension(:), allocatable :: p_cm type(vector4_t), dimension(:), allocatable :: p type(lorentz_transformation_t), allocatable :: L_cm_to_lab real(default) :: sqrts = 0 character(32) :: md5sum = "" contains <> end type beam_data_t @ %def beam_data_t @ Generic initializer. This is called by the specific initializers below. Initialize either for decay or for collision. <>= subroutine beam_data_init (beam_data, n) type(beam_data_t), intent(out) :: beam_data integer, intent(in) :: n beam_data%n = n allocate (beam_data%flv (n)) allocate (beam_data%mass (n)) allocate (beam_data%pmatrix (n)) allocate (beam_data%p_cm (n)) allocate (beam_data%p (n)) beam_data%initialized = .true. end subroutine beam_data_init @ %def beam_data_init @ Finalizer: needed for the polarization components of the beams. <>= procedure :: final => beam_data_final <>= subroutine beam_data_final (beam_data) class(beam_data_t), intent(inout) :: beam_data beam_data%initialized = .false. end subroutine beam_data_final @ %def beam_data_final @ The verbose (default) version is for debugging. The short version is for screen output in the UI. <>= procedure :: write => beam_data_write <>= subroutine beam_data_write (beam_data, unit, verbose, write_md5sum) class(beam_data_t), intent(in) :: beam_data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, write_md5sum integer :: prt_name_len logical :: verb, write_md5 integer :: u u = given_output_unit (unit); if (u < 0) return verb = .false.; if (present (verbose)) verb = verbose write_md5 = verb; if (present (write_md5sum)) write_md5 = write_md5sum if (.not. beam_data%initialized) then write (u, "(1x,A)") "Beam data: [undefined]" return end if prt_name_len = maxval (len (beam_data%flv%get_name ())) select case (beam_data%n) case (1) write (u, "(1x,A)") "Beam data (decay):" if (verb) then call write_prt (1) call beam_data%pmatrix(1)%write (u) write (u, *) "R.f. momentum:" call vector4_write (beam_data%p_cm(1), u) write (u, *) "Lab momentum:" call vector4_write (beam_data%p(1), u) else call write_prt (1) end if case (2) write (u, "(1x,A)") "Beam data (collision):" if (verb) then call write_prt (1) call beam_data%pmatrix(1)%write (u) call write_prt (2) call beam_data%pmatrix(2)%write (u) call write_sqrts write (u, *) "C.m. momenta:" call vector4_write (beam_data%p_cm(1), u) call vector4_write (beam_data%p_cm(2), u) write (u, *) "Lab momenta:" call vector4_write (beam_data%p(1), u) call vector4_write (beam_data%p(2), u) else call write_prt (1) call write_prt (2) call write_sqrts end if end select if (allocated (beam_data%L_cm_to_lab)) then if (verb) then call lorentz_transformation_write (beam_data%L_cm_to_lab, u) else write (u, "(1x,A)") "Beam structure: lab and c.m. frame differ" end if end if if (write_md5) then write (u, *) "MD5 sum: ", beam_data%md5sum end if contains subroutine write_sqrts character(80) :: sqrts_str write (sqrts_str, "(" // FMT_19 // ")") beam_data%sqrts write (u, "(3x,A)") "sqrts = " // trim (adjustl (sqrts_str)) // " GeV" end subroutine write_sqrts subroutine write_prt (i) integer, intent(in) :: i character(80) :: name_str, mass_str write (name_str, "(A)") char (beam_data%flv(i)%get_name ()) write (mass_str, "(ES13.7)") beam_data%mass(i) write (u, "(3x,A)", advance="no") & name_str(:prt_name_len) // " (mass = " & // trim (adjustl (mass_str)) // " GeV)" if (beam_data%pmatrix(i)%is_polarized ()) then write (u, "(2x,A)") "polarized" else write (u, *) end if end subroutine write_prt end subroutine beam_data_write @ %def beam_data_write @ Return initialization status: <>= procedure :: are_valid => beam_data_are_valid <>= function beam_data_are_valid (beam_data) result (flag) class(beam_data_t), intent(in) :: beam_data logical :: flag flag = beam_data%initialized end function beam_data_are_valid @ %def beam_data_are_valid @ Check whether beam data agree with the current values of relevant parameters. <>= procedure :: check_scattering => beam_data_check_scattering <>= subroutine beam_data_check_scattering (beam_data, sqrts) class(beam_data_t), intent(in) :: beam_data real(default), intent(in), optional :: sqrts if (beam_data_are_valid (beam_data)) then if (present (sqrts)) then if (.not. nearly_equal (sqrts, beam_data%sqrts)) then call msg_error ("Current setting of sqrts is inconsistent " & // "with beam setup (ignored).") end if end if else call msg_bug ("Beam setup: invalid beam data") end if end subroutine beam_data_check_scattering @ %def beam_data_check_scattering @ Return the number of beams (1 for decays, 2 for collisions). <>= procedure :: get_n_in => beam_data_get_n_in <>= function beam_data_get_n_in (beam_data) result (n_in) class(beam_data_t), intent(in) :: beam_data integer :: n_in n_in = beam_data%n end function beam_data_get_n_in @ %def beam_data_get_n_in @ Return the beam flavor <>= procedure :: get_flavor => beam_data_get_flavor <>= function beam_data_get_flavor (beam_data) result (flv) class(beam_data_t), intent(in) :: beam_data type(flavor_t), dimension(:), allocatable :: flv allocate (flv (beam_data%n)) flv = beam_data%flv end function beam_data_get_flavor @ %def beam_data_get_flavor @ Return the beam energies <>= procedure :: get_energy => beam_data_get_energy <>= function beam_data_get_energy (beam_data) result (e) class(beam_data_t), intent(in) :: beam_data real(default), dimension(:), allocatable :: e integer :: i allocate (e (beam_data%n)) if (beam_data%initialized) then do i = 1, beam_data%n e(i) = energy (beam_data%p(i)) end do else e = 0 end if end function beam_data_get_energy @ %def beam_data_get_energy @ Return the c.m.\ energy. <>= procedure :: get_sqrts => beam_data_get_sqrts <>= function beam_data_get_sqrts (beam_data) result (sqrts) class(beam_data_t), intent(in) :: beam_data real(default) :: sqrts sqrts = beam_data%sqrts end function beam_data_get_sqrts @ %def beam_data_get_sqrts @ Return true if the lab and c.m.\ frame are specified as identical. <>= procedure :: cm_frame => beam_data_cm_frame <>= function beam_data_cm_frame (beam_data) result (flag) class(beam_data_t), intent(in) :: beam_data logical :: flag flag = beam_data%lab_is_cm_frame end function beam_data_cm_frame @ %def beam_data_cm_frame @ Return the polarization in case it is just two degrees <>= procedure :: get_polarization => beam_data_get_polarization <>= function beam_data_get_polarization (beam_data) result (pol) class(beam_data_t), intent(in) :: beam_data real(default), dimension(2) :: pol if (beam_data%n /= 2) & call msg_fatal ("Beam data: can only treat scattering processes.") pol = beam_data%pmatrix%get_simple_pol () end function beam_data_get_polarization @ %def beam_data_get_polarization @ <>= procedure :: get_helicity_state_matrix => beam_data_get_helicity_state_matrix <>= function beam_data_get_helicity_state_matrix (beam_data) result (state_hel) type(state_matrix_t) :: state_hel class(beam_data_t), intent(in) :: beam_data type(polarization_t), dimension(:), allocatable :: pol integer :: i allocate (pol (beam_data%n)) do i = 1, beam_data%n call pol(i)%init_pmatrix (beam_data%pmatrix(i)) end do call combine_polarization_states (pol, state_hel) end function beam_data_get_helicity_state_matrix @ %def beam_data_get_helicity_state_matrix @ <>= procedure :: is_initialized => beam_data_is_initialized <>= function beam_data_is_initialized (beam_data) result (initialized) logical :: initialized class(beam_data_t), intent(in) :: beam_data initialized = any (beam_data%pmatrix%exists ()) end function beam_data_is_initialized @ %def beam_data_is_initialized @ Return a MD5 checksum for beam data. If no checksum is present (because beams have not been initialized), compute the checksum of the sqrts value. <>= procedure :: get_md5sum => beam_data_get_md5sum <>= function beam_data_get_md5sum (beam_data, sqrts) result (md5sum_beams) class(beam_data_t), intent(in) :: beam_data real(default), intent(in) :: sqrts character(32) :: md5sum_beams character(80) :: buffer if (beam_data%md5sum /= "") then md5sum_beams = beam_data%md5sum else write (buffer, *) sqrts md5sum_beams = md5sum (buffer) end if end function beam_data_get_md5sum @ %def beam_data_get_md5sum @ \subsection{Initializers: beam structure} Initialize the beam data object from a beam structure object, given energy and model. <>= procedure :: init_structure => beam_data_init_structure <>= subroutine beam_data_init_structure & (beam_data, structure, sqrts, model, decay_rest_frame) class(beam_data_t), intent(out) :: beam_data type(beam_structure_t), intent(in) :: structure integer :: n_beam real(default), intent(in) :: sqrts class(model_data_t), intent(in), target :: model logical, intent(in), optional :: decay_rest_frame type(flavor_t), dimension(:), allocatable :: flv n_beam = structure%get_n_beam () allocate (flv (n_beam)) call flv%init (structure%get_prt (), model) if (structure%asymmetric ()) then if (structure%polarized ()) then call beam_data%init_momenta (structure%get_momenta (), flv, & structure%get_smatrix (), structure%get_pol_f ()) else call beam_data%init_momenta (structure%get_momenta (), flv) end if else select case (n_beam) case (1) if (structure%polarized ()) then call beam_data%init_decay (flv, & structure%get_smatrix (), structure%get_pol_f (), & rest_frame = decay_rest_frame) else call beam_data%init_decay (flv, & rest_frame = decay_rest_frame) end if case (2) if (structure%polarized ()) then call beam_data%init_sqrts (sqrts, flv, & structure%get_smatrix (), structure%get_pol_f ()) else call beam_data%init_sqrts (sqrts, flv) end if case default call msg_bug ("Beam data: invalid beam structure object") end select end if end subroutine beam_data_init_structure @ %def beam_data_init_structure @ \subsection{Initializers: collisions} This is the simplest one: just the two flavors, c.m.\ energy, polarization. Color is inferred from flavor. Beam momenta and c.m.\ momenta coincide. <>= procedure :: init_sqrts => beam_data_init_sqrts <>= subroutine beam_data_init_sqrts (beam_data, sqrts, flv, smatrix, pol_f) class(beam_data_t), intent(out) :: beam_data real(default), intent(in) :: sqrts type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f real(default), dimension(size(flv)) :: E, p call beam_data_init (beam_data, size (flv)) beam_data%sqrts = sqrts beam_data%lab_is_cm_frame = .true. select case (beam_data%n) case (1) E = sqrts; p = 0 beam_data%p_cm = vector4_moving (E, p, 3) beam_data%p = beam_data%p_cm case (2) beam_data%p_cm = colliding_momenta (sqrts, flv%get_mass ()) beam_data%p = colliding_momenta (sqrts, flv%get_mass ()) end select call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f) end subroutine beam_data_init_sqrts @ %def beam_data_init_sqrts @ This version sets beam momenta directly, assuming that they are asymmetric, i.e., lab frame and c.m.\ frame do not coincide. Polarization info is deferred to a common initializer. The Lorentz transformation that we compute here is not actually used in the calculation; instead, it will be recomputed for each event in the subroutine [[phs_set_incoming_momenta]]. We compute it here for the nominal beam setup nevertheless, so we can print it and, in particular, include it in the MD5 sum. <>= procedure :: init_momenta => beam_data_init_momenta <>= subroutine beam_data_init_momenta (beam_data, p3, flv, smatrix, pol_f) class(beam_data_t), intent(out) :: beam_data type(vector3_t), dimension(:), intent(in) :: p3 type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f type(vector4_t) :: p0 type(vector4_t), dimension(:), allocatable :: p, p_cm_rot real(default), dimension(size(p3)) :: e real(default), dimension(size(flv)) :: m type(lorentz_transformation_t) :: L_boost, L_rot call beam_data_init (beam_data, size (flv)) m = flv%get_mass () e = sqrt (p3 ** 2 + m ** 2) allocate (p (beam_data%n)) p = vector4_moving (e, p3) p0 = sum (p) beam_data%p = p beam_data%lab_is_cm_frame = .false. beam_data%sqrts = p0 ** 1 L_boost = boost (p0, beam_data%sqrts) allocate (p_cm_rot (beam_data%n)) p_cm_rot = inverse (L_boost) * p allocate (beam_data%L_cm_to_lab) select case (beam_data%n) case (1) beam_data%L_cm_to_lab = L_boost beam_data%p_cm = vector4_at_rest (beam_data%sqrts) case (2) L_rot = rotation_to_2nd (3, space_part (p_cm_rot(1))) beam_data%L_cm_to_lab = L_boost * L_rot beam_data%p_cm = & colliding_momenta (beam_data%sqrts, flv%get_mass ()) end select call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f) end subroutine beam_data_init_momenta @ %def beam_data_init_momenta @ Final steps: If requested, rotate the beams in the lab frame, and set the beam-data components. <>= subroutine beam_data_finish_initialization (beam_data, flv, smatrix, pol_f) type(beam_data_t), intent(inout) :: beam_data type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f integer :: i do i = 1, beam_data%n beam_data%flv(i) = flv(i) beam_data%mass(i) = flv(i)%get_mass () if (present (smatrix)) then if (size (smatrix) /= beam_data%n) & call msg_fatal ("Beam data: & &polarization density array has wrong dimension") beam_data%pmatrix(i) = smatrix(i) if (present (pol_f)) then if (size (pol_f) /= size (smatrix)) & call msg_fatal ("Beam data: & &polarization fraction array has wrong dimension") call beam_data%pmatrix(i)%normalize (flv(i), pol_f(i)) else call beam_data%pmatrix(i)%normalize (flv(i), 1._default) end if else call beam_data%pmatrix(i)%init (2, 0) call beam_data%pmatrix(i)%normalize (flv(i), 0._default) end if end do call beam_data%compute_md5sum () end subroutine beam_data_finish_initialization @ %def beam_data_finish_initialization @ The MD5 sum is stored within the beam-data record, so it can be checked for integrity in subsequent runs. <>= procedure :: compute_md5sum => beam_data_compute_md5sum <>= subroutine beam_data_compute_md5sum (beam_data) class(beam_data_t), intent(inout) :: beam_data integer :: unit unit = free_unit () open (unit = unit, status = "scratch", action = "readwrite") call beam_data%write (unit, write_md5sum = .false., & verbose = .true.) rewind (unit) beam_data%md5sum = md5sum (unit) close (unit) end subroutine beam_data_compute_md5sum @ %def beam_data_compute_md5sum @ \subsection{Initializers: decays} This is the simplest one: decay in rest frame. We need just flavor and polarization. Color is inferred from flavor. Beam momentum and c.m.\ momentum coincide. <>= procedure :: init_decay => beam_data_init_decay <>= subroutine beam_data_init_decay (beam_data, flv, smatrix, pol_f, rest_frame) class(beam_data_t), intent(out) :: beam_data type(flavor_t), dimension(1), intent(in) :: flv type(smatrix_t), dimension(1), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f logical, intent(in), optional :: rest_frame real(default), dimension(1) :: m m = flv%get_mass () if (present (smatrix)) then call beam_data%init_sqrts (m(1), flv, smatrix, pol_f) else call beam_data%init_sqrts (m(1), flv, smatrix, pol_f) end if if (present (rest_frame)) beam_data%lab_is_cm_frame = rest_frame end subroutine beam_data_init_decay @ %def beam_data_init_decay @ \subsection{The beams type} Beam objects are interaction objects that contain the actual beam data including polarization and density matrix. For collisions, the beam object actually contains two beams. <>= public :: beam_t <>= type :: beam_t private type(interaction_t) :: int end type beam_t @ %def beam_t @ The constructor contains code that converts beam data into the (entangled) particle-pair quantum state. First, we set the number of particles and polarization mask. (The polarization mask is handed over to all later interactions, so if helicity is diagonal or absent, this fact is used when constructing the hard-interaction events.) Then, we construct the entangled state that combines helicity, flavor and color of the two particles (where flavor and color are unique, while several helicity states are possible). Then, we transfer this state together with the associated values from the spin density matrix into the [[interaction_t]] object. Calling the [[add_state]] method of the interaction object, we keep the entries of the helicity density matrix without adding them up. This ensures that for unpolarized states, we do not normalize but end up with an $1/N$ entry, where $N$ is the initial-state multiplicity. <>= public :: beam_init <>= subroutine beam_init (beam, beam_data) type(beam_t), intent(out) :: beam type(beam_data_t), intent(in), target :: beam_data logical, dimension(beam_data%n) :: polarized, diagonal type(quantum_numbers_mask_t), dimension(beam_data%n) :: mask, mask_d type(state_matrix_t), target :: state_hel, state_fc, state_tmp type(state_iterator_t) :: it_hel, it_tmp type(quantum_numbers_t), dimension(:), allocatable :: qn complex(default) :: value real(default), parameter :: tolerance = 100 * epsilon (1._default) polarized = beam_data%pmatrix%is_polarized () diagonal = beam_data%pmatrix%is_diagonal () mask = quantum_numbers_mask (.false., .false., & mask_h = .not. polarized, & mask_hd = diagonal) mask_d = quantum_numbers_mask (.false., .false., .false., & mask_hd = polarized .and. diagonal) call beam%int%basic_init & (0, 0, beam_data%n, mask = mask, store_values = .true.) state_hel = beam_data%get_helicity_state_matrix () allocate (qn (beam_data%n)) call qn%init (beam_data%flv, color_from_flavor (beam_data%flv, 1)) call state_fc%init () call state_fc%add_state (qn) call merge_state_matrices (state_hel, state_fc, state_tmp) call it_hel%init (state_hel) call it_tmp%init (state_tmp) do while (it_hel%is_valid ()) qn = it_tmp%get_quantum_numbers () value = it_hel%get_matrix_element () if (any (qn%are_redundant (mask_d))) then ! skip off-diagonal elements for diagonal polarization else if (abs (value) <= tolerance) then ! skip zero entries else call beam%int%add_state (qn, value = value) end if call it_hel%advance () call it_tmp%advance () end do call beam%int%freeze () call beam%int%set_momenta (beam_data%p, outgoing = .true.) call state_hel%final () call state_fc%final () call state_tmp%final () end subroutine beam_init @ %def beam_init @ Finalizer: <>= public :: beam_final <>= subroutine beam_final (beam) type(beam_t), intent(inout) :: beam call beam%int%final () end subroutine beam_final @ %def beam_final @ I/O: <>= public :: beam_write <>= subroutine beam_write (beam, unit, verbose, show_momentum_sum, show_mass, col_verbose) type(beam_t), intent(in) :: beam integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, show_momentum_sum, show_mass logical, intent(in), optional :: col_verbose integer :: u u = given_output_unit (unit); if (u < 0) return select case (beam%int%get_n_out ()) case (1); write (u, *) "Decaying particle:" case (2); write (u, *) "Colliding beams:" end select call beam%int%basic_write & (unit, verbose = verbose, show_momentum_sum = & show_momentum_sum, show_mass = show_mass, & col_verbose = col_verbose) end subroutine beam_write @ %def beam_write @ Defined assignment: deep copy <>= public :: assignment(=) <>= interface assignment(=) module procedure beam_assign end interface <>= subroutine beam_assign (beam_out, beam_in) type(beam_t), intent(out) :: beam_out type(beam_t), intent(in) :: beam_in beam_out%int = beam_in%int end subroutine beam_assign @ %def beam_assign @ \subsection{Inherited procedures} <>= public :: interaction_set_source_link <>= interface interaction_set_source_link module procedure interaction_set_source_link_beam end interface <>= subroutine interaction_set_source_link_beam (int, i, beam1, i1) type(interaction_t), intent(inout) :: int type(beam_t), intent(in), target :: beam1 integer, intent(in) :: i, i1 call int%set_source_link (i, beam1%int, i1) end subroutine interaction_set_source_link_beam @ %def interaction_set_source_link_beam @ \subsection{Accessing contents} Return the interaction component -- as a pointer, to avoid any copying. <>= public :: beam_get_int_ptr <>= function beam_get_int_ptr (beam) result (int) type(interaction_t), pointer :: int type(beam_t), intent(in), target :: beam int => beam%int end function beam_get_int_ptr @ %def beam_get_int_ptr @ Set beam momenta directly. (Used for cascade decays.) <>= public :: beam_set_momenta <>= subroutine beam_set_momenta (beam, p) type(beam_t), intent(inout) :: beam type(vector4_t), dimension(:), intent(in) :: p call beam%int%set_momenta (p) end subroutine beam_set_momenta @ %def beam_set_momenta @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[beams_ut.f90]]>>= <> module beams_ut use unit_tests use beams_uti <> <> contains <> end module beams_ut @ %def beams_ut @ <<[[beams_uti.f90]]>>= <> module beams_uti <> use lorentz use flavors use interactions, only: reset_interaction_counter use polarizations, only: smatrix_t use model_data use beam_structures use beams <> <> contains <> end module beams_uti @ %def beams_ut @ API: driver for the unit tests below. <>= public :: beams_test <>= subroutine beams_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine beams_test @ %def beams_test @ Test the basic beam setup. <>= call test (beam_1, "beam_1", & "check basic beam setup", & u, results) <>= public :: beam_1 <>= subroutine beam_1 (u) integer, intent(in) :: u type(beam_data_t), target :: beam_data type(beam_t) :: beam real(default) :: sqrts type(flavor_t), dimension(2) :: flv type(smatrix_t), dimension(2) :: smatrix real(default), dimension(2) :: pol_f type(model_data_t), target :: model write (u, "(A)") "* Test output: beam_1" write (u, "(A)") "* Purpose: test basic beam setup" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call reset_interaction_counter () call model%init_sm_test () write (u, "(A)") "* Unpolarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call beam_data%init_sqrts (sqrts, flv) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call beam_data%init_sqrts (sqrts, flv) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call beam_data%init_sqrts (sqrts, flv) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Polarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call smatrix(1)%init (2, 1) call smatrix(1)%set_entry (1, [1,1], (1._default, 0._default)) pol_f(1) = 0.5_default call smatrix(2)%init (2, 3) call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default)) call smatrix(2)%set_entry (2, [-1,-1], (1._default, 0._default)) call smatrix(2)%set_entry (3, [-1,1], (1._default, 0._default)) pol_f(2) = 1._default call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call smatrix(1)%init (2, 0) pol_f(1) = 0._default call smatrix(2)%init (2, 1) call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default)) pol_f(2) = 1._default call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call smatrix(1)%init (2, 0) pol_f(1) = 0._default call smatrix(2)%init (2, 1) call smatrix(2)%set_entry (1, [0,0], (1._default, 0._default)) pol_f(2) = 1._default call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call beam_data%init_decay (flv(1:1)) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Polarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call smatrix(1)%init (2, 1) call smatrix(1)%set_entry (1, [0,0], (1._default, 0._default)) pol_f(1) = 0.4_default call beam_data%init_decay (flv(1:1), smatrix(1:1), pol_f(1:1)) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call beam_final (beam) call beam_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: beam_1" end subroutine beam_1 @ %def beam_1 @ Test advanced beam setup. <>= call test (beam_2, "beam_2", & "beam initialization", & u, results) <>= public :: beam_2 <>= subroutine beam_2 (u) integer, intent(in) :: u type(beam_data_t), target :: beam_data type(beam_t) :: beam real(default) :: sqrts type(flavor_t), dimension(2) :: flv integer, dimension(0) :: no_records type(beam_structure_t) :: beam_structure type(model_data_t), target :: model write (u, "(A)") "* Test output: beam_2" write (u, "(A)") "* Purpose: transfer beam polarization using & &beam structure" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call model%init_sm_test () write (u, "(A)") "* Unpolarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Polarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 1) call beam_structure%set_sentry (1, 1, [1,1], (1._default, 0._default)) call beam_structure%init_smatrix (2, 3) call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default)) call beam_structure%set_sentry (2, 2, [-1,-1], (1._default, 0._default)) call beam_structure%set_sentry (2, 3, [-1,1], (1._default, 0._default)) call beam_structure%set_pol_f ([0.5_default, 1._default]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, *) call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () call beam_structure%final_pol () call beam_structure%final_sf () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 0) call beam_structure%init_smatrix (2, 1) call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default)) call beam_structure%set_pol_f ([0._default, 1._default]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 0) call beam_structure%init_smatrix (2, 1) call beam_structure%set_sentry (2, 1, [0,0], (1._default, 0._default)) call beam_structure%write (u) write (u, "(A)") call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call beam_structure%init_sf ([flv(1)%get_name ()], no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, "(A)") call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Polarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call beam_structure%init_sf ([flv(1)%get_name ()], no_records) call beam_structure%init_pol (1) call beam_structure%init_smatrix (1, 1) call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default)) call beam_structure%set_pol_f ([0.4_default]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call beam_final (beam) call beam_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: beam_2" end subroutine beam_2 @ %def beam_2 @ Test advanced beam setup, completely arbitrary momenta. <>= call test (beam_3, "beam_3", & "generic beam momenta", & u, results) <>= public :: beam_3 <>= subroutine beam_3 (u) integer, intent(in) :: u type(beam_data_t), target :: beam_data type(beam_t) :: beam type(flavor_t), dimension(2) :: flv integer, dimension(0) :: no_records type(model_data_t), target :: model type(beam_structure_t) :: beam_structure type(vector3_t), dimension(2) :: p3 type(vector4_t), dimension(2) :: p write (u, "(A)") "* Test output: beam_3" write (u, "(A)") "* Purpose: set up beams with generic momenta" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call reset_interaction_counter () call model%init_sm_test () write (u, "(A)") "* 1: Scattering process" write (u, "(A)") call flv%init ([2212,2212], model) p3(1) = vector3_moving ([5._default, 0._default, 10._default]) p3(2) = -vector3_moving ([1._default, 1._default, -10._default]) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%set_momentum (p3 ** 1) call beam_structure%set_theta (polar_angle (p3)) call beam_structure%set_phi (azimuthal_angle (p3)) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, 0._default, model) call pacify (beam_data%l_cm_to_lab, 1e-20_default) call beam_data%compute_md5sum () call beam_data%write (u, verbose = .true.) write (u, *) write (u, "(1x,A)") "Beam momenta reconstructed from LT:" p = beam_data%L_cm_to_lab * beam_data%p_cm call pacify (p, 1e-12_default) call vector4_write (p(1), u) call vector4_write (p(2), u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () call beam_structure%final_sf () call beam_structure%final_mom () write (u, "(A)") write (u, "(A)") "* 2: Decay" write (u, "(A)") call flv(1)%init (23, model) p3(1) = vector3_moving ([10._default, 5._default, 50._default]) call beam_structure%init_sf ([flv(1)%get_name ()], no_records) call beam_structure%set_momentum ([p3(1) ** 1]) call beam_structure%set_theta ([polar_angle (p3(1))]) call beam_structure%set_phi ([azimuthal_angle (p3(1))]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, 0._default, model) call beam_data%write (u, verbose = .true.) write (u, "(A)") write (u, "(1x,A)") "Beam momentum reconstructed from LT:" p(1) = beam_data%L_cm_to_lab * beam_data%p_cm(1) call pacify (p(1), 1e-12_default) call vector4_write (p(1), u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call beam_final (beam) call beam_data%final () call beam_structure%final_sf () call beam_structure%final_mom () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: beam_3" end subroutine beam_3 @ %def beam_3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Tools} This module contains auxiliary procedures that can be accessed by the structure function code. <<[[sf_aux.f90]]>>= <> module sf_aux <> use io_units use constants, only: twopi use numeric_utils use lorentz <> <> <> <> contains <> end module sf_aux @ %def sf_aux @ \subsection{Momentum splitting} Let us consider first an incoming parton with momentum $k$ and invariant mass squared $s=k^2$ that splits into two partons with momenta $q,p$ and invariant masses $t=q^2$ and $u=p^2$. (This is an abuse of the Mandelstam notation. $t$ is actually the momentum transfer, assuming that $p$ is radiated and $q$ initiates the hard process.) The energy is split among the partons such that if $E=k^0$, we have $q^0 = xE$ and $p^0=\bar x E$, where $\bar x\equiv 1-x$. We define the angle $\theta$ as the polar angle of $p$ w.r.t.\ the momentum axis of the incoming momentum $k$. Ignoring azimuthal angle, we can write the four-momenta in the basis $(E,p_T,p_L)$ as \begin{equation} k = \begin{pmatrix} E \\ 0 \\ p \end{pmatrix}, \qquad p = \begin{pmatrix} \bar x E \\ \bar x\bar p\sin\theta \\ \bar x\bar p\cos\theta \end{pmatrix}, \qquad q = \begin{pmatrix} x E \\ -\bar x\bar p\sin\theta \\ p - \bar x\bar p\cos\theta \end{pmatrix}, \end{equation} where the first two mass-shell conditions are \begin{equation} p^2 = E^2 - s, \qquad \bar p^2 = E^2 - \frac{u}{\bar x^2}. \end{equation} The second condition implies that, for positive $u$, $\bar x^2 > u/E^2$, or equivalently \begin{equation} x < 1 - \sqrt{u} / E. \end{equation} We are interested in the third mass-shell conditions: $s$ and $u$ are fixed, so we need $t$ as a function of $\cos\theta$: \begin{equation} t = -2\bar x \left(E^2 - p\bar p\cos\theta\right) + s + u. \end{equation} Solving for $\cos\theta$, we get \begin{equation} \cos\theta = \frac{2\bar x E^2 + t - s - u}{2\bar x p\bar p}. \end{equation} We can compute $\sin\theta$ numerically as $\sin^2\theta=1-\cos^2\theta$, but it is important to reexpress this in view of numerical stability. To this end, we first determine the bounds for $t$. The cosine must be between $-1$ and $1$, so the bounds are \begin{align} t_0 &= -2\bar x\left(E^2 + p\bar p\right) + s + u, \\ t_1 &= -2\bar x\left(E^2 - p\bar p\right) + s + u. \end{align} Computing $\sin^2\theta$ from $\cos\theta$ above, we observe that the numerator is a quadratic polynomial in $t$ which has the zeros $t_0$ and $t_1$, while the common denominator is given by $(2\bar x p\bar p)^2$. Hence, we can write \begin{equation} \sin^2\theta = -\frac{(t - t_0)(t - t_1)}{(2\bar x p\bar p)^2} \qquad\text{and}\qquad \cos\theta = \frac{(t-t_0) + (t-t_1)}{4\bar x p\bar p}, \end{equation} which is free of large cancellations near $t=t_0$ or $t=t_1$. If all is massless, i.e., $s=u=0$, this simplifies to \begin{align} t_0 &= -4\bar x E^2, & t_1 &= 0, \\ \sin^2\theta &= -\frac{t}{\bar x E^2} \left(1 + \frac{t}{4\bar x E^2}\right), & \cos\theta &= 1 + \frac{t}{2\bar x E^2}. \end{align} Here is the implementation. First, we define a container for the kinematical integration limits and some further data. Note: contents are public only for easy access in unit test. <>= public :: splitting_data_t <>= type :: splitting_data_t ! private logical :: collinear = .false. real(default) :: x0 = 0 real(default) :: x1 real(default) :: t0 real(default) :: t1 real(default) :: phi0 = 0 real(default) :: phi1 = twopi real(default) :: E, p, s, u, m2 real(default) :: x, xb, pb real(default) :: t = 0 real(default) :: phi = 0 contains <> end type splitting_data_t @ %def splitting_data_t @ I/O for debugging: <>= procedure :: write => splitting_data_write <>= subroutine splitting_data_write (d, unit) class(splitting_data_t), intent(in) :: d integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(A)") "Splitting data:" write (u, "(2x,A,L1)") "collinear = ", d%collinear 1 format (2x,A,1x,ES15.8) write (u, 1) "x0 =", d%x0 write (u, 1) "x =", d%x write (u, 1) "xb =", d%xb write (u, 1) "x1 =", d%x1 write (u, 1) "t0 =", d%t0 write (u, 1) "t =", d%t write (u, 1) "t1 =", d%t1 write (u, 1) "phi0 =", d%phi0 write (u, 1) "phi =", d%phi write (u, 1) "phi1 =", d%phi1 write (u, 1) "E =", d%E write (u, 1) "p =", d%p write (u, 1) "pb =", d%pb write (u, 1) "s =", d%s write (u, 1) "u =", d%u write (u, 1) "m2 =", d%m2 end subroutine splitting_data_write @ %def splitting_data_write @ \subsection{Constant data} This is the initializer for the data. The input consists of the incoming momentum, its invariant mass squared, and the invariant mass squared of the radiated particle. $m2$ is the \emph{physical} mass squared of the outgoing particle. The $t$ bounds depend on the chosen $x$ value and cannot be determined yet. <>= procedure :: init => splitting_data_init <>= subroutine splitting_data_init (d, k, mk2, mr2, mo2, collinear) class(splitting_data_t), intent(out) :: d type(vector4_t), intent(in) :: k real(default), intent(in) :: mk2, mr2, mo2 logical, intent(in), optional :: collinear if (present (collinear)) d%collinear = collinear d%E = energy (k) d%x1 = 1 - sqrt (max (mr2, 0._default)) / d%E d%p = sqrt (d%E**2 - mk2) d%s = mk2 d%u = mr2 d%m2 = mo2 end subroutine splitting_data_init @ %def splitting_data_init @ Retrieve the $x$ bounds, if needed for $x$ sampling. Generating an $x$ value is done by the caller, since this is the part that depends on the nature of the structure function. <>= procedure :: get_x_bounds => splitting_get_x_bounds <>= function splitting_get_x_bounds (d) result (x) class(splitting_data_t), intent(in) :: d real(default), dimension(2) :: x x = [ d%x0, d%x1 ] end function splitting_get_x_bounds @ %def splitting_get_x_bounds @ Now set the momentum fraction and compute $t_0$ and $t_1$. [The calculation of $t_1$ is subject to numerical problems. The exact formula is ($s=m_i^2$, $u=m_r^2$) \begin{equation} t_1 = -2\bar x E^2 + m_i^2 + m_r^2 + 2\bar x \sqrt{E^2-m_i^2}\,\sqrt{E^2 - m_r^2/\bar x^2}. \end{equation} The structure-function paradigm is useful only if $E\gg m_i,m_r$. In a Taylor expansion for large $E$, the leading term cancels. The expansion of the square roots (to subleading order) yields \begin{equation} t_1 = xm_i^2 - \frac{x}{\bar x}m_r^2. \end{equation} There are two cases of interest: $m_i=m_o$ and $m_r=0$, \begin{equation} t_1 = xm_o^2 \end{equation} and $m_i=m_r$ and $m_o=0$, \begin{equation} t_1 = -\frac{x^2}{\bar x}m_i^2. \end{equation} In both cases, $t_1\leq m_o^2$.] That said, it turns out that taking the $t_1$ evaluation at face value leads to less problems than the approximation. We express the angles in terms of $t-t_0$ and $t-t_1$. Numerical noise in $t_1$ can then be tolerated. <>= procedure :: set_t_bounds => splitting_set_t_bounds <>= elemental subroutine splitting_set_t_bounds (d, x, xb) class(splitting_data_t), intent(inout) :: d real(default), intent(in), optional :: x, xb real(default) :: tp, tm if (present (x)) d%x = x if (present (xb)) d%xb = xb if (vanishes (d%u)) then d%pb = d%E else if (.not. vanishes (d%xb)) then d%pb = sqrt (max (d%E**2 - d%u / d%xb**2, 0._default)) else d%pb = 0 end if end if tp = -2 * d%xb * d%E**2 + d%s + d%u tm = -2 * d%xb * d%p * d%pb d%t0 = tp + tm d%t1 = tp - tm d%t = d%t1 end subroutine splitting_set_t_bounds @ %def splitting_set_t_bounds @ \subsection{Sampling recoil} Compute a value for the momentum transfer $t$, using a random number $r$. We assume a logarithmic distribution for $t-m^2$, corresponding to the propagator $1/(t-m^2)$ with the physical mass $m$ for the outgoing particle. Optionally, we can narrow the kinematical bounds. If all three masses in the splitting vanish, the upper limit for $t$ is zero. In that case, the $t$ value is set to zero and the splitting will be collinear. <>= procedure :: sample_t => splitting_sample_t <>= subroutine splitting_sample_t (d, r, t0, t1) class(splitting_data_t), intent(inout) :: d real(default), intent(in) :: r real(default), intent(in), optional :: t0, t1 real(default) :: tt0, tt1, tt0m, tt1m if (d%collinear) then d%t = d%t1 else tt0 = d%t0; if (present (t0)) tt0 = max (t0, tt0) tt1 = d%t1; if (present (t1)) tt1 = min (t1, tt1) tt0m = tt0 - d%m2 tt1m = tt1 - d%m2 if (tt0m < 0 .and. tt1m < 0 .and. abs(tt0m) > & epsilon(tt0m) .and. abs(tt1m) > epsilon(tt0m)) then d%t = d%m2 + tt0m * exp (r * log (tt1m / tt0m)) else d%t = tt1 end if end if end subroutine splitting_sample_t @ %def splitting_sample_t @ The inverse operation: Given $t$, we recover the value of $r$ that would have produced this value. <>= procedure :: inverse_t => splitting_inverse_t <>= subroutine splitting_inverse_t (d, r, t0, t1) class(splitting_data_t), intent(in) :: d real(default), intent(out) :: r real(default), intent(in), optional :: t0, t1 real(default) :: tt0, tt1, tt0m, tt1m if (d%collinear) then r = 0 else tt0 = d%t0; if (present (t0)) tt0 = max (t0, tt0) tt1 = d%t1; if (present (t1)) tt1 = min (t1, tt1) tt0m = tt0 - d%m2 tt1m = tt1 - d%m2 if (tt0m < 0 .and. tt1m < 0) then r = log ((d%t - d%m2) / tt0m) / log (tt1m / tt0m) else r = 0 end if end if end subroutine splitting_inverse_t @ %def splitting_inverse_t @ This is trivial, but provided for convenience: <>= procedure :: sample_phi => splitting_sample_phi <>= subroutine splitting_sample_phi (d, r) class(splitting_data_t), intent(inout) :: d real(default), intent(in) :: r if (d%collinear) then d%phi = 0 else d%phi = (1-r) * d%phi0 + r * d%phi1 end if end subroutine splitting_sample_phi @ %def splitting_sample_phi @ Inverse: <>= procedure :: inverse_phi => splitting_inverse_phi <>= subroutine splitting_inverse_phi (d, r) class(splitting_data_t), intent(in) :: d real(default), intent(out) :: r if (d%collinear) then r = 0 else r = (d%phi - d%phi0) / (d%phi1 - d%phi0) end if end subroutine splitting_inverse_phi @ %def splitting_inverse_phi @ \subsection{Splitting} In this function, we actually perform the splitting. The incoming momentum $k$ is split into (if no recoil) $q_1=(1-x)k$ and $q_2=xk$. Apart from the splitting data, we need the incoming momentum $k$, the momentum transfer $t$, and the azimuthal angle $\phi$. The momentum fraction $x$ is already known here. Alternatively, we can split without recoil. The azimuthal angle is irrelevant, and the momentum transfer is always equal to the upper limit $t_1$, so the polar angle is zero. Obviously, if there are nonzero masses it is not possible to keep both energy-momentum conservation and at the same time all particles on shell. We choose for dropping the on-shell condition here. <>= procedure :: split_momentum => splitting_split_momentum <>= function splitting_split_momentum (d, k) result (q) class(splitting_data_t), intent(in) :: d type(vector4_t), dimension(2) :: q type(vector4_t), intent(in) :: k real(default) :: st2, ct2, st, ct, cp, sp type(lorentz_transformation_t) :: rot real(default) :: tt0, tt1, den type(vector3_t) :: kk, q1, q2 if (d%collinear) then if (vanishes (d%s) .and. vanishes(d%u)) then q(1) = d%xb * k q(2) = d%x * k else kk = space_part (k) q1 = d%xb * (d%pb / d%p) * kk q2 = kk - q1 q(1) = vector4_moving (d%xb * d%E, q1) q(2) = vector4_moving (d%x * d%E, q2) end if else den = 2 * d%xb * d%p * d%pb tt0 = max (d%t - d%t0, 0._default) tt1 = min (d%t - d%t1, 0._default) if (den**2 <= epsilon(den)) then st2 = 0 else st2 = - (tt0 * tt1) / den ** 2 end if if (st2 > 1) then st2 = 1 end if ct2 = 1 - st2 st = sqrt (max (st2, 0._default)) ct = sqrt (max (ct2, 0._default)) if ((d%t - d%t0 + d%t - d%t1) < 0) then ct = - ct end if sp = sin (d%phi) cp = cos (d%phi) rot = rotation_to_2nd (3, space_part (k)) q1 = vector3_moving (d%xb * d%pb * [st * cp, st * sp, ct]) q2 = vector3_moving (d%p, 3) - q1 q(1) = rot * vector4_moving (d%xb * d%E, q1) q(2) = rot * vector4_moving (d%x * d%E, q2) end if end function splitting_split_momentum @ %def splitting_split_momentum @ Momenta generated by splitting will in general be off-shell. They are on-shell only if they are collinear and massless. This subroutine puts them on shell by brute force, violating either momentum or energy conservation. The direction of three-momentum is always retained. If the energy is below mass shell, we return a zero momentum. <>= integer, parameter, public :: KEEP_ENERGY = 0, KEEP_MOMENTUM = 1 @ %def KEEP_ENERGY KEEP_MOMENTUM <>= public :: on_shell <>= elemental subroutine on_shell (p, m2, keep) type(vector4_t), intent(inout) :: p real(default), intent(in) :: m2 integer, intent(in) :: keep real(default) :: E, E2, pn select case (keep) case (KEEP_ENERGY) E = energy (p) E2 = E ** 2 if (E2 >= m2) then pn = sqrt (E2 - m2) p = vector4_moving (E, pn * direction (space_part (p))) else p = vector4_null end if case (KEEP_MOMENTUM) E = sqrt (space_part (p) ** 2 + m2) p = vector4_moving (E, space_part (p)) end select end subroutine on_shell @ %def on_shell @ \subsection{Recovering the splitting} This is the inverse problem. We have on-shell momenta and want to deduce the splitting parameters $x$, $t$, and $\phi$. Update 2018-08-22: As a true inverse to [[splitting_split_momentum]], we now use not just a single momentum [[q2]] as before, but the momentum pair [[q1]], [[q2]] for recovering $x$ and $\bar x$ separately. If $x$ happens to be close to $1$, we would completely lose the tiny $\bar x$ value, otherwise, and thus get a meaningless result. <>= procedure :: recover => splitting_recover <>= subroutine splitting_recover (d, k, q, keep) class(splitting_data_t), intent(inout) :: d type(vector4_t), intent(in) :: k type(vector4_t), dimension(2), intent(in) :: q integer, intent(in) :: keep type(lorentz_transformation_t) :: rot type(vector4_t) :: k0 type(vector4_t), dimension(2) :: q0 real(default) :: p1, p2, p3, pt2, pp2, pl real(default) :: aux, den, norm real(default) :: st2, ct2, ct rot = inverse (rotation_to_2nd (3, space_part (k))) q0 = rot * q p1 = vector4_get_component (q0(2), 1) p2 = vector4_get_component (q0(2), 2) p3 = vector4_get_component (q0(2), 3) pt2 = p1 ** 2 + p2 ** 2 pp2 = p1 ** 2 + p2 ** 2 + p3 ** 2 pl = abs (p3) k0 = vector4_moving (d%E, d%p, 3) select case (keep) case (KEEP_ENERGY) d%x = energy (q0(2)) / d%E d%xb = energy (q0(1)) / d%E call d%set_t_bounds () if (.not. d%collinear) then aux = (d%xb * d%pb) ** 2 * pp2 - d%p ** 2 * pt2 den = d%p ** 2 - (d%xb * d%pb) ** 2 if (aux >= 0 .and. den > 0) then norm = (d%p * pl + sqrt (aux)) / den else norm = 1 end if end if case (KEEP_MOMENTUM) d%xb = sqrt (space_part (q0(1)) ** 2 + d%u) / d%E d%x = 1 - d%xb call d%set_t_bounds () norm = 1 end select if (d%collinear) then d%t = d%t1 d%phi = 0 else if ((d%xb * d%pb * norm)**2 < epsilon(d%xb)) then st2 = 1 else st2 = pt2 / (d%xb * d%pb * norm ) ** 2 end if if (st2 > 1) then st2 = 1 end if ct2 = 1 - st2 ct = sqrt (max (ct2, 0._default)) if (.not. vanishes (1 + ct)) then d%t = d%t1 - 2 * d%xb * d%p * d%pb * st2 / (1 + ct) else d%t = d%t0 end if if (.not. vanishes (p1) .or. .not. vanishes (p2)) then d%phi = atan2 (-p2, -p1) else d%phi = 0 end if end if end subroutine splitting_recover @ %def splitting_recover @ \subsection{Extract data} <>= procedure :: get_x => splitting_get_x procedure :: get_xb => splitting_get_xb <>= function splitting_get_x (sd) result (x) class(splitting_data_t), intent(in) :: sd real(default) :: x x = sd%x end function splitting_get_x function splitting_get_xb (sd) result (xb) class(splitting_data_t), intent(in) :: sd real(default) :: xb xb = sd%xb end function splitting_get_xb @ %def splitting_get_x @ %def splitting_get_xb @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_aux_ut.f90]]>>= <> module sf_aux_ut use unit_tests use sf_aux_uti <> <> contains <> end module sf_aux_ut @ %def sf_aux_ut @ <<[[sf_aux_uti.f90]]>>= <> module sf_aux_uti <> use lorentz use sf_aux <> <> contains <> end module sf_aux_uti @ %def sf_aux_ut @ API: driver for the unit tests below. <>= public :: sf_aux_test <>= subroutine sf_aux_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_aux_test @ %def sf_aux_test @ \subsubsection{Momentum splitting: massless radiation} Compute momentum splitting for generic kinematics. It turns out that for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and lower bounds (this can be directly seen from the logarithmic distribution in the function [[sample_t]] for $r \equiv x = 1 - x = 0.5$), we arrive at an exact number $t=-0.15$ for the given input values. <>= call test (sf_aux_1, "sf_aux_1", & "massless radiation", & u, results) <>= public :: sf_aux_1 <>= subroutine sf_aux_1 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q, q0 real(default) :: E, mk, mp, mq real(default) :: x, r1, r2, r1o, r2o real(default) :: k2, q0_2, q1_2, q2_2 write (u, "(A)") "* Test output: sf_aux_1" write (u, "(A)") "* Purpose: compute momentum splitting" write (u, "(A)") " (massless radiated particle)" write (u, "(A)") E = 1 mk = 0.3_default mp = 0 mq = mk k = vector4_moving (E, sqrt (E**2 - mk**2), 3) k2 = k ** 2; call pacify (k2, 1e-10_default) x = 0.6_default r1 = 0.5_default r2 = 0.125_default write (u, "(A)") "* (1) Non-collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%sample_t (r1) call sd%sample_phi (r2) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "Extract: x, 1-x" write (u, "(2(1x,F11.8))") sd%get_x (), sd%get_xb () write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, 1 - x) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_1" end subroutine sf_aux_1 @ %def sf_aux_1 @ \subsubsection{Momentum splitting: massless parton} Compute momentum splitting for generic kinematics. It turns out that for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and lower bounds, we arrive at an exact number $t=-0.36$ for the given input values. <>= call test (sf_aux_2, "sf_aux_2", & "massless parton", & u, results) <>= public :: sf_aux_2 <>= subroutine sf_aux_2 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q, q0 real(default) :: E, mk, mp, mq real(default) :: x, r1, r2, r1o, r2o real(default) :: k2, q02_2, q1_2, q2_2 write (u, "(A)") "* Test output: sf_aux_2" write (u, "(A)") "* Purpose: compute momentum splitting" write (u, "(A)") " (massless outgoing particle)" write (u, "(A)") E = 1 mk = 0.3_default mp = mk mq = 0 k = vector4_moving (E, sqrt (E**2 - mk**2), 3) k2 = k ** 2; call pacify (k2, 1e-10_default) x = 0.6_default r1 = 0.5_default r2 = 0.125_default write (u, "(A)") "* (1) Non-collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%sample_t (r1) call sd%sample_phi (r2) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, 1 - x) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_2" end subroutine sf_aux_2 @ %def sf_aux_2 @ \subsubsection{Momentum splitting: all massless} Compute momentum splitting for massless kinematics. In the non-collinear case, we need a lower cutoff for $|t|$, otherwise a logarithmic distribution is not possible. <>= call test (sf_aux_3, "sf_aux_3", & "massless parton", & u, results) <>= public :: sf_aux_3 <>= subroutine sf_aux_3 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q, q0 real(default) :: E, mk, mp, mq, qmin, qmax real(default) :: x, r1, r2, r1o, r2o real(default) :: k2, q02_2, q1_2, q2_2 write (u, "(A)") "* Test output: sf_aux_3" write (u, "(A)") "* Purpose: compute momentum splitting" write (u, "(A)") " (all massless, q cuts)" write (u, "(A)") E = 1 mk = 0 mp = 0 mq = 0 qmin = 1e-2_default qmax = 1e0_default k = vector4_moving (E, sqrt (E**2 - mk**2), 3) k2 = k ** 2; call pacify (k2, 1e-10_default) x = 0.6_default r1 = 0.5_default r2 = 0.125_default write (u, "(A)") "* (1) Non-collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%sample_t (r1, t1 = - qmin ** 2, t0 = - qmax **2) call sd%sample_phi (r2) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o, t1 = - qmin ** 2, t0 = - qmax **2) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o, t1 = - qmin ** 2, t0 = - qmax **2) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, 1 - x) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_3" end subroutine sf_aux_3 @ %def sf_aux_3 @ \subsubsection{Endpoint stability} Compute momentum splitting for collinear kinematics close to both endpoints. In particular, check both directions $x\to$ momenta and momenta $\to x$. For purely massless collinear splitting, the [[KEEP_XXX]] flag is irrelevant. We choose [[KEEP_ENERGY]] here. <>= call test (sf_aux_4, "sf_aux_4", & "endpoint numerics", & u, results) <>= public :: sf_aux_4 <>= subroutine sf_aux_4 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E, mk, mp, mq, qmin, qmax real(default) :: x, xb write (u, "(A)") "* Test output: sf_aux_4" write (u, "(A)") "* Purpose: compute massless collinear splitting near endpoint" E = 1 mk = 0 mp = 0 mq = 0 qmin = 1e-2_default qmax = 1e0_default k = vector4_moving (E, sqrt (E**2 - mk**2), 3) x = 0.1_default xb = 1 - x write (u, "(A)") write (u, "(A)") "* (1) Collinear setup, moderate kinematics" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%write (u) q = sd%split_momentum (k) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momenta" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%recover (k, q, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") xb, sd%xb write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Close to x=0" write (u, "(A)") x = 1e-9_default xb = 1 - x call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%write (u) q = sd%split_momentum (k) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momenta" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%recover (k, q, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") xb, sd%xb write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (3) Close to x=1" write (u, "(A)") xb = 1e-9_default x = 1 - xb call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%write (u) q = sd%split_momentum (k) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momenta" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%recover (k, q, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") xb, sd%xb write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_4" end subroutine sf_aux_4 @ %def sf_aux_4 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Mappings for structure functions} In this module, we provide a wrapper for useful mappings of the unit (hyper-)square that we can apply to a set of structure functions. In some cases it is useful, or even mandatory, to map the MC input parameters nontrivially onto a set of structure functions for the two beams. In all cases considered here, instead of $x_1,x_2,\ldots$ as parameters for the beams, we generate one parameter that is equal, or related to, the product $x_1x_2\cdots$ (so it directly corresponds to $\sqrt{s}$). The other parameters describe the distribution of energy (loss) between beams and radiations. <<[[sf_mappings.f90]]>>= <> module sf_mappings <> use kinds, only: double use io_units use constants, only: pi, zero, one use numeric_utils use diagnostics <> <> <> <> <> contains <> end module sf_mappings @ %def sf_mappings @ \subsection{Base type} First, we define an abstract base type for the mapping. In all cases we need to store the indices of the parameters on which the mapping applies. Additional parameters can be stored in the extensions of this type. <>= public :: sf_mapping_t <>= type, abstract :: sf_mapping_t integer, dimension(:), allocatable :: i contains <> end type sf_mapping_t @ %def sf_mapping_t @ The output routine is deferred: <>= procedure (sf_mapping_write), deferred :: write <>= abstract interface subroutine sf_mapping_write (object, unit) import class(sf_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_mapping_write end interface @ %def sf_mapping_write @ Initializer for the base type. The array of parameter indices is allocated but initialized to zero. <>= procedure :: base_init => sf_mapping_base_init <>= subroutine sf_mapping_base_init (mapping, n_par) class(sf_mapping_t), intent(out) :: mapping integer, intent(in) :: n_par allocate (mapping%i (n_par)) mapping%i = 0 end subroutine sf_mapping_base_init @ %def sf_mapping_base_init @ Set an index value. <>= procedure :: set_index => sf_mapping_set_index <>= subroutine sf_mapping_set_index (mapping, j, i) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i end subroutine sf_mapping_set_index @ %def sf_mapping_set_index @ Retrieve an index value. <>= procedure :: get_index => sf_mapping_get_index <>= function sf_mapping_get_index (mapping, j) result (i) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: j integer :: i i = mapping%i(j) end function sf_mapping_get_index @ %def sf_mapping_get_index @ Return the dimensionality, i.e., the number of parameters. <>= procedure :: get_n_dim => sf_mapping_get_n_dim <>= function sf_mapping_get_n_dim (mapping) result (n) class(sf_mapping_t), intent(in) :: mapping integer :: n n = size (mapping%i) end function sf_mapping_get_n_dim @ %def sf_mapping_get_n_dim @ Computation: the values [[p]] are the input parameters, the values [[r]] are the output parameters. The values [[rb]] are defined as $\bar r = 1 - r$, but provided explicitly. They allow us to avoid numerical problems near $r=1$. The extra parameter [[x_free]] indicates that the total energy has already been renormalized by this factor. We have to take such a factor into account in a resonance or on-shell mapping. The Jacobian is [[f]]. We modify only the two parameters indicated by the indices [[i]]. <>= procedure (sf_mapping_compute), deferred :: compute <>= abstract interface subroutine sf_mapping_compute (mapping, r, rb, f, p, pb, x_free) import class(sf_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_mapping_compute end interface @ %def sf_mapping_compute @ The inverse mapping. Use [[r]] and/or [[rb]] to reconstruct [[p]] and also compute [[f]]. <>= procedure (sf_mapping_inverse), deferred :: inverse <>= abstract interface subroutine sf_mapping_inverse (mapping, r, rb, f, p, pb, x_free) import class(sf_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_mapping_inverse end interface @ %def sf_mapping_inverse @ \subsection{Methods for self-tests} This is a shorthand for: inject parameters, compute the mapping, display results, compute the inverse, display again. We provide an output format for the parameters and, optionally, a different output format for the Jacobians. <>= procedure :: check => sf_mapping_check <>= subroutine sf_mapping_check (mapping, u, p_in, pb_in, fmt_p, fmt_f) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: u real(default), dimension(:), intent(in) :: p_in, pb_in character(*), intent(in) :: fmt_p character(*), intent(in), optional :: fmt_f real(default), dimension(size(p_in)) :: p, pb, r, rb real(default) :: f, tolerance tolerance = 1.5E-17 p = p_in pb= pb_in call mapping%compute (r, rb, f, p, pb) call pacify (p, tolerance) call pacify (pb, tolerance) call pacify (r, tolerance) call pacify (rb, tolerance) write (u, "(3x,A,9(1x," // fmt_p // "))") "p =", p write (u, "(3x,A,9(1x," // fmt_p // "))") "pb=", pb write (u, "(3x,A,9(1x," // fmt_p // "))") "r =", r write (u, "(3x,A,9(1x," // fmt_p // "))") "rb=", rb if (present (fmt_f)) then write (u, "(3x,A,9(1x," // fmt_f // "))") "f =", f else write (u, "(3x,A,9(1x," // fmt_p // "))") "f =", f end if write (u, *) call mapping%inverse (r, rb, f, p, pb) call pacify (p, tolerance) call pacify (pb, tolerance) call pacify (r, tolerance) call pacify (rb, tolerance) write (u, "(3x,A,9(1x," // fmt_p // "))") "p =", p write (u, "(3x,A,9(1x," // fmt_p // "))") "pb=", pb write (u, "(3x,A,9(1x," // fmt_p // "))") "r =", r write (u, "(3x,A,9(1x," // fmt_p // "))") "rb=", rb if (present (fmt_f)) then write (u, "(3x,A,9(1x," // fmt_f // "))") "f =", f else write (u, "(3x,A,9(1x," // fmt_p // "))") "f =", f end if write (u, *) write (u, "(3x,A,9(1x," // fmt_p // "))") "*r=", product (r) end subroutine sf_mapping_check @ %def sf_mapping_check @ This is a consistency check for the self-tests: the integral over the unit square should be unity. We estimate this by a simple binning and adding up the values; this should be sufficient for a self-test. The argument is the requested number of sampling points. We take the square root for binning in both dimensions, so the precise number might be different. <>= procedure :: integral => sf_mapping_integral <>= function sf_mapping_integral (mapping, n_calls) result (integral) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: n_calls real(default) :: integral integer :: n_dim, n_bin, k real(default), dimension(:), allocatable :: p, pb, r, rb integer, dimension(:), allocatable :: ii real(default) :: dx, f, s n_dim = mapping%get_n_dim () allocate (p (n_dim)) allocate (pb(n_dim)) allocate (r (n_dim)) allocate (rb(n_dim)) allocate (ii(n_dim)) n_bin = nint (real (n_calls, default) ** (1._default / n_dim)) dx = 1._default / n_bin s = 0 ii = 1 SAMPLE: do do k = 1, n_dim p(k) = ii(k) * dx - dx/2 pb(k) = (n_bin - ii(k)) * dx + dx/2 end do call mapping%compute (r, rb, f, p, pb) s = s + f INCR: do k = 1, n_dim ii(k) = ii(k) + 1 if (ii(k) <= n_bin) then exit INCR else if (k < n_dim) then ii(k) = 1 else exit SAMPLE end if end do INCR end do SAMPLE integral = s / real (n_bin, default) ** n_dim end function sf_mapping_integral @ %def sf_mapping_integral @ \subsection{Implementation: standard mapping} This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. <>= public :: sf_s_mapping_t <>= type, extends (sf_mapping_t) :: sf_s_mapping_t logical :: power_set = .false. real(default) :: power = 1 contains <> end type sf_s_mapping_t @ %def sf_s_mapping_t @ Output. <>= procedure :: write => sf_s_mapping_write <>= subroutine sf_s_mapping_write (object, unit) class(sf_s_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A)") ": standard (", object%power, ")" end subroutine sf_s_mapping_write @ %def sf_s_mapping_write @ Initialize: index pair and power parameter. <>= procedure :: init => sf_s_mapping_init <>= subroutine sf_s_mapping_init (mapping, power) class(sf_s_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: power call mapping%base_init (2) if (present (power)) then mapping%power_set = .true. mapping%power = power end if end subroutine sf_s_mapping_init @ %def sf_s_mapping_init @ Apply mapping. <>= procedure :: compute => sf_s_mapping_compute <>= subroutine sf_s_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_s_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2 integer :: j if (mapping%power_set) then call map_unit_square (r2, f, p(mapping%i), mapping%power) else call map_unit_square (r2, f, p(mapping%i)) end if r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_s_mapping_compute @ %def sf_s_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_s_mapping_inverse <>= subroutine sf_s_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_s_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: p2 integer :: j if (mapping%power_set) then call map_unit_square_inverse (r(mapping%i), f, p2, mapping%power) else call map_unit_square_inverse (r(mapping%i), f, p2) end if p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_s_mapping_inverse @ %def sf_s_mapping_inverse @ \subsection{Implementation: resonance pair mapping} This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio, then it maps $p_1$ to itself according to a Breit-Wigner shape, i.e., a flat prior distribution in $p_1$ results in a Breit-Wigner distribution. Mass and width of the BW are rescaled by the energy, thus dimensionless fractions. <>= public :: sf_res_mapping_t <>= type, extends (sf_mapping_t) :: sf_res_mapping_t real(default) :: m = 0 real(default) :: w = 0 contains <> end type sf_res_mapping_t @ %def sf_res_mapping_t @ Output. <>= procedure :: write => sf_res_mapping_write <>= subroutine sf_res_mapping_write (object, unit) class(sf_res_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,', ',F7.5,A)") ": resonance (", object%m, object%w, ")" end subroutine sf_res_mapping_write @ %def sf_res_mapping_write @ Initialize: index pair and dimensionless mass and width parameters. <>= procedure :: init => sf_res_mapping_init <>= subroutine sf_res_mapping_init (mapping, m, w) class(sf_res_mapping_t), intent(out) :: mapping real(default), intent(in) :: m, w call mapping%base_init (2) mapping%m = m mapping%w = w end subroutine sf_res_mapping_init @ %def sf_res_mapping_init @ Apply mapping. <>= procedure :: compute => sf_res_mapping_compute <>= subroutine sf_res_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, p2 real(default) :: fbw, f2, p1m integer :: j p2 = p(mapping%i) call map_breit_wigner & (p1m, fbw, p2(1), mapping%m, mapping%w, x_free) call map_unit_square (r2, f2, [p1m, p2(2)]) f = fbw * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_res_mapping_compute @ %def sf_res_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_res_mapping_inverse <>= subroutine sf_res_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: p2 real(default) :: fbw, f2, p1m call map_unit_square_inverse (r(mapping%i), f2, p2) call map_breit_wigner_inverse & (p2(1), fbw, p1m, mapping%m, mapping%w, x_free) p = r pb= rb p (mapping%i(1)) = p1m pb(mapping%i(1)) = 1 - p1m p (mapping%i(2)) = p2(2) pb(mapping%i(2)) = 1 - p2(2) f = fbw * f2 end subroutine sf_res_mapping_inverse @ %def sf_res_mapping_inverse @ \subsection{Implementation: resonance single mapping} While simpler, this is needed for structure-function setups only in exceptional cases. This maps the unit interval ($r_1$) to itself according to a Breit-Wigner shape, i.e., a flat prior distribution in $r_1$ results in a Breit-Wigner distribution. Mass and width of the BW are rescaled by the energy, thus dimensionless fractions. <>= public :: sf_res_mapping_single_t <>= type, extends (sf_mapping_t) :: sf_res_mapping_single_t real(default) :: m = 0 real(default) :: w = 0 contains <> end type sf_res_mapping_single_t @ %def sf_res_mapping_single_t @ Output. <>= procedure :: write => sf_res_mapping_single_write <>= subroutine sf_res_mapping_single_write (object, unit) class(sf_res_mapping_single_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,', ',F7.5,A)") ": resonance (", object%m, object%w, ")" end subroutine sf_res_mapping_single_write @ %def sf_res_mapping_single_write @ Initialize: single index (!) and dimensionless mass and width parameters. <>= procedure :: init => sf_res_mapping_single_init <>= subroutine sf_res_mapping_single_init (mapping, m, w) class(sf_res_mapping_single_t), intent(out) :: mapping real(default), intent(in) :: m, w call mapping%base_init (1) mapping%m = m mapping%w = w end subroutine sf_res_mapping_single_init @ %def sf_res_mapping_single_init @ Apply mapping. <>= procedure :: compute => sf_res_mapping_single_compute <>= subroutine sf_res_mapping_single_compute (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: r2, p2 real(default) :: fbw integer :: j p2 = p(mapping%i) call map_breit_wigner & (r2(1), fbw, p2(1), mapping%m, mapping%w, x_free) f = fbw r = p rb= pb r (mapping%i(1)) = r2(1) rb(mapping%i(1)) = 1 - r2(1) end subroutine sf_res_mapping_single_compute @ %def sf_res_mapping_single_compute @ Apply inverse. <>= procedure :: inverse => sf_res_mapping_single_inverse <>= subroutine sf_res_mapping_single_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: p2 real(default) :: fbw call map_breit_wigner_inverse & (r(mapping%i(1)), fbw, p2(1), mapping%m, mapping%w, x_free) p = r pb= rb p (mapping%i(1)) = p2(1) pb(mapping%i(1)) = 1 - p2(1) f = fbw end subroutine sf_res_mapping_single_inverse @ %def sf_res_mapping_single_inverse @ \subsection{Implementation: on-shell mapping} This is a degenerate version of the unit-square mapping where the product $r_1r_2$ is constant. This product is given by the rescaled squared mass. We introduce an artificial first parameter $p_1$ to keep the counting, but nothing depends on it. The second parameter is the same $p_2$ as for the standard unit-square mapping for $\alpha=1$, it parameterizes the ratio of $r_1$ and $r_2$. <>= public :: sf_os_mapping_t <>= type, extends (sf_mapping_t) :: sf_os_mapping_t real(default) :: m = 0 real(default) :: lm2 = 0 contains <> end type sf_os_mapping_t @ %def sf_os_mapping_t @ Output. <>= procedure :: write => sf_os_mapping_write <>= subroutine sf_os_mapping_write (object, unit) class(sf_os_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A)") ": on-shell (", object%m, ")" end subroutine sf_os_mapping_write @ %def sf_os_mapping_write @ Initialize: index pair and dimensionless mass parameter. <>= procedure :: init => sf_os_mapping_init <>= subroutine sf_os_mapping_init (mapping, m) class(sf_os_mapping_t), intent(out) :: mapping real(default), intent(in) :: m call mapping%base_init (2) mapping%m = m mapping%lm2 = abs (2 * log (mapping%m)) end subroutine sf_os_mapping_init @ %def sf_os_mapping_init @ Apply mapping. The [[x_free]] parameter rescales the total energy, which must be accounted for in the enclosed mapping. <>= procedure :: compute => sf_os_mapping_compute <>= subroutine sf_os_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, p2 integer :: j p2 = p(mapping%i) call map_on_shell (r2, f, p2, mapping%lm2, x_free) r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_os_mapping_compute @ %def sf_os_mapping_compute @ Apply inverse. The irrelevant parameter $p_1$ is always set zero. <>= procedure :: inverse => sf_os_mapping_inverse <>= subroutine sf_os_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: p2, r2 r2 = r(mapping%i) call map_on_shell_inverse (r2, f, p2, mapping%lm2, x_free) p = r pb= rb p (mapping%i(1)) = p2(1) pb(mapping%i(1)) = 1 - p2(1) p (mapping%i(2)) = p2(2) pb(mapping%i(2)) = 1 - p2(2) end subroutine sf_os_mapping_inverse @ %def sf_os_mapping_inverse @ \subsection{Implementation: on-shell single mapping} This is a degenerate version of the unit-interval mapping where the result $r$ is constant. The value is given by the rescaled squared mass. The input parameter $p_1$ is actually ignored, nothing depends on it. <>= public :: sf_os_mapping_single_t <>= type, extends (sf_mapping_t) :: sf_os_mapping_single_t real(default) :: m = 0 real(default) :: lm2 = 0 contains <> end type sf_os_mapping_single_t @ %def sf_os_mapping_single_t @ Output. <>= procedure :: write => sf_os_mapping_single_write <>= subroutine sf_os_mapping_single_write (object, unit) class(sf_os_mapping_single_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A)") ": on-shell (", object%m, ")" end subroutine sf_os_mapping_single_write @ %def sf_os_mapping_single_write @ Initialize: index pair and dimensionless mass parameter. <>= procedure :: init => sf_os_mapping_single_init <>= subroutine sf_os_mapping_single_init (mapping, m) class(sf_os_mapping_single_t), intent(out) :: mapping real(default), intent(in) :: m call mapping%base_init (1) mapping%m = m mapping%lm2 = abs (2 * log (mapping%m)) end subroutine sf_os_mapping_single_init @ %def sf_os_mapping_single_init @ Apply mapping. The [[x_free]] parameter rescales the total energy, which must be accounted for in the enclosed mapping. <>= procedure :: compute => sf_os_mapping_single_compute <>= subroutine sf_os_mapping_single_compute (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: r2, p2 integer :: j p2 = p(mapping%i) call map_on_shell_single (r2, f, p2, mapping%lm2, x_free) r = p rb= pb r (mapping%i(1)) = r2(1) rb(mapping%i(1)) = 1 - r2(1) end subroutine sf_os_mapping_single_compute @ %def sf_os_mapping_single_compute @ Apply inverse. The irrelevant parameter $p_1$ is always set zero. <>= procedure :: inverse => sf_os_mapping_single_inverse <>= subroutine sf_os_mapping_single_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: p2, r2 r2 = r(mapping%i) call map_on_shell_single_inverse (r2, f, p2, mapping%lm2, x_free) p = r pb= rb p (mapping%i(1)) = p2(1) pb(mapping%i(1)) = 1 - p2(1) end subroutine sf_os_mapping_single_inverse @ %def sf_os_mapping_single_inverse @ \subsection{Implementation: endpoint mapping} This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that any power-like singularity is caught. This is useful for beamstrahlung spectra. In addition, we allow for a delta-function singularity in $r_1$ and/or $r_2$. The singularity is smeared to an interval of width $\epsilon$. If nonzero, we distinguish the kinematical momentum fractions $r_i$ from effective values $x_i$, which should go into the structure-function evaluation. A bin of width $\epsilon$ in $r$ is mapped to $x=1$ exactly, while the interval $(0,1-\epsilon)$ is mapped to $(0,1)$ in $x$. The Jacobian reflects this distinction, and the logical [[in_peak]] allows for an unambiguous distinction. The delta-peak fraction is used only for the integration self-test. <>= public :: sf_ep_mapping_t <>= type, extends (sf_mapping_t) :: sf_ep_mapping_t real(default) :: a = 1 contains <> end type sf_ep_mapping_t @ %def sf_ep_mapping_t @ Output. <>= procedure :: write => sf_ep_mapping_write <>= subroutine sf_ep_mapping_write (object, unit) class(sf_ep_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,ES12.5,A)") ": endpoint (a =", object%a, ")" end subroutine sf_ep_mapping_write @ %def sf_ep_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ep_mapping_init <>= subroutine sf_ep_mapping_init (mapping, a) class(sf_ep_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a call mapping%base_init (2) if (present (a)) mapping%a = a end subroutine sf_ep_mapping_init @ %def sf_ep_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ep_mapping_compute <>= subroutine sf_ep_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ep_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, r2 real(default) :: f1, f2 integer :: j call map_endpoint_1 (px(1), f1, p(mapping%i(1)), mapping%a) call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a) call map_unit_square (r2, f, px) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_ep_mapping_compute @ %def sf_ep_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ep_mapping_inverse <>= subroutine sf_ep_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ep_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, px, p2 real(default) :: f1, f2 integer :: j do j = 1, 2 r2(j) = r(mapping%i(j)) end do call map_unit_square_inverse (r2, f, px) call map_endpoint_inverse_1 (px(1), f1, p2(1), mapping%a) call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a) f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_ep_mapping_inverse @ %def sf_ep_mapping_inverse @ \subsection{Implementation: endpoint mapping with resonance} Like the endpoint mapping for $p_2$, but replace the endpoint mapping by a Breit-Wigner mapping for $p_1$. This covers resonance production in the presence of beamstrahlung. If the flag [[resonance]] is unset, we skip the resonance mapping, so the parameter $p_1$ remains equal to $r_1r_2$, as in the standard s-channel mapping. <>= public :: sf_epr_mapping_t <>= type, extends (sf_mapping_t) :: sf_epr_mapping_t real(default) :: a = 1 real(default) :: m = 0 real(default) :: w = 0 logical :: resonance = .true. contains <> end type sf_epr_mapping_t @ %def sf_epr_mapping_t @ Output. <>= procedure :: write => sf_epr_mapping_write <>= subroutine sf_epr_mapping_write (object, unit) class(sf_epr_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if if (object%resonance) then write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)") ": ep/res (a = ", object%a, & " | ", object%m, object%w, ")" else write (u, "(A,F7.5,A)") ": ep/nores (a = ", object%a, ")" end if end subroutine sf_epr_mapping_write @ %def sf_epr_mapping_write @ Initialize: if mass and width are not given, we initialize a non-resonant version of the mapping. <>= procedure :: init => sf_epr_mapping_init <>= subroutine sf_epr_mapping_init (mapping, a, m, w) class(sf_epr_mapping_t), intent(out) :: mapping real(default), intent(in) :: a real(default), intent(in), optional :: m, w call mapping%base_init (2) mapping%a = a if (present (m) .and. present (w)) then mapping%m = m mapping%w = w else mapping%resonance = .false. end if end subroutine sf_epr_mapping_init @ %def sf_epr_mapping_init @ Apply mapping. <>= procedure :: compute => sf_epr_mapping_compute <>= subroutine sf_epr_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_epr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, r2 real(default) :: f1, f2 integer :: j if (mapping%resonance) then call map_breit_wigner & (px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free) else px(1) = p(mapping%i(1)) f1 = 1 end if call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a) call map_unit_square (r2, f, px) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_epr_mapping_compute @ %def sf_epr_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_epr_mapping_inverse <>= subroutine sf_epr_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_epr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, p2 real(default) :: f1, f2 integer :: j call map_unit_square_inverse (r(mapping%i), f, px) if (mapping%resonance) then call map_breit_wigner_inverse & (px(1), f1, p2(1), mapping%m, mapping%w, x_free) else p2(1) = px(1) f1 = 1 end if call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a) f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_epr_mapping_inverse @ %def sf_epr_mapping_inverse @ \subsection{Implementation: endpoint mapping for on-shell particle} Analogous to the resonance mapping, but the $p_1$ input is ignored altogether. This covers on-shell particle production in the presence of beamstrahlung. <>= public :: sf_epo_mapping_t <>= type, extends (sf_mapping_t) :: sf_epo_mapping_t real(default) :: a = 1 real(default) :: m = 0 real(default) :: lm2 = 0 contains <> end type sf_epo_mapping_t @ %def sf_epo_mapping_t @ Output. <>= procedure :: write => sf_epo_mapping_write <>= subroutine sf_epo_mapping_write (object, unit) class(sf_epo_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A)") ": ep/on-shell (a = ", object%a, & " | ", object%m, ")" end subroutine sf_epo_mapping_write @ %def sf_epo_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_epo_mapping_init <>= subroutine sf_epo_mapping_init (mapping, a, m) class(sf_epo_mapping_t), intent(out) :: mapping real(default), intent(in) :: a, m call mapping%base_init (2) mapping%a = a mapping%m = m mapping%lm2 = abs (2 * log (mapping%m)) end subroutine sf_epo_mapping_init @ %def sf_epo_mapping_init @ Apply mapping. <>= procedure :: compute => sf_epo_mapping_compute <>= subroutine sf_epo_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_epo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, r2 real(default) :: f2 integer :: j px(1) = 0 call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a) call map_on_shell (r2, f, px, mapping%lm2) f = f * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_epo_mapping_compute @ %def sf_epo_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_epo_mapping_inverse <>= subroutine sf_epo_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_epo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, p2 real(default) :: f2 integer :: j call map_on_shell_inverse (r(mapping%i), f, px, mapping%lm2) p2(1) = 0 call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a) f = f * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_epo_mapping_inverse @ %def sf_epo_mapping_inverse @ \subsection{Implementation: ISR endpoint mapping} Similar to the endpoint mapping above: This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is flattened. This would be easy in one dimension, but becomes nontrivial in two dimensions. <>= public :: sf_ip_mapping_t <>= type, extends (sf_mapping_t) :: sf_ip_mapping_t real(default) :: eps = 0 contains <> end type sf_ip_mapping_t @ %def sf_ip_mapping_t @ Output. <>= procedure :: write => sf_ip_mapping_write <>= subroutine sf_ip_mapping_write (object, unit) class(sf_ip_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,ES12.5,A)") ": isr (eps =", object%eps, ")" end subroutine sf_ip_mapping_write @ %def sf_ip_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ip_mapping_init <>= subroutine sf_ip_mapping_init (mapping, eps) class(sf_ip_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps call mapping%base_init (2) if (present (eps)) mapping%eps = eps if (mapping%eps <= 0) & call msg_fatal ("ISR mapping: regulator epsilon must not be zero") end subroutine sf_ip_mapping_init @ %def sf_ip_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ip_mapping_compute <>= subroutine sf_ip_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ip_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, pxb, r2, r2b real(default) :: f1, f2, xb, y, yb integer :: j call map_power_1 (xb, f1, pb(mapping%i(1)), 2 * mapping%eps) call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps) px(1) = 1 - xb pxb(1) = xb px(2) = y pxb(2) = yb call map_unit_square_prec (r2, r2b, f, px, pxb) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2 (j) rb(mapping%i(j)) = r2b(j) end do end subroutine sf_ip_mapping_compute @ %def sf_ip_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ip_mapping_inverse <>= subroutine sf_ip_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ip_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b real(default) :: f1, f2, xb, y, yb integer :: j do j = 1, 2 r2 (j) = r (mapping%i(j)) r2b(j) = rb(mapping%i(j)) end do call map_unit_square_inverse_prec (r2, r2b, f, px, pxb) xb = pxb(1) if (px(1) > 0) then y = px(2) yb = pxb(2) else y = 0.5_default yb = 0.5_default end if call map_power_inverse_1 (xb, f1, p2b(1), 2 * mapping%eps) call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps) p2 = 1 - p2b f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = p2b(j) end do end subroutine sf_ip_mapping_inverse @ %def sf_ip_mapping_inverse @ \subsection{Implementation: ISR endpoint mapping, resonant} Similar to the endpoint mapping above: This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is flattened. This would be easy in one dimension, but becomes nontrivial in two dimensions. The resonance can be turned off by the flag [[resonance]]. <>= public :: sf_ipr_mapping_t <>= type, extends (sf_mapping_t) :: sf_ipr_mapping_t real(default) :: eps = 0 real(default) :: m = 0 real(default) :: w = 0 logical :: resonance = .true. contains <> end type sf_ipr_mapping_t @ %def sf_ipr_mapping_t @ Output. <>= procedure :: write => sf_ipr_mapping_write <>= subroutine sf_ipr_mapping_write (object, unit) class(sf_ipr_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if if (object%resonance) then write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)") ": isr/res (eps = ", & object%eps, " | ", object%m, object%w, ")" else write (u, "(A,F7.5,A)") ": isr/res (eps = ", object%eps, ")" end if end subroutine sf_ipr_mapping_write @ %def sf_ipr_mapping_write @ Initialize: <>= procedure :: init => sf_ipr_mapping_init <>= subroutine sf_ipr_mapping_init (mapping, eps, m, w) class(sf_ipr_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps, m, w call mapping%base_init (2) if (present (eps)) mapping%eps = eps if (mapping%eps <= 0) & call msg_fatal ("ISR mapping: regulator epsilon must not be zero") if (present (m) .and. present (w)) then mapping%m = m mapping%w = w else mapping%resonance = .false. end if end subroutine sf_ipr_mapping_init @ %def sf_ipr_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ipr_mapping_compute <>= subroutine sf_ipr_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ipr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, pxb, r2, r2b real(default) :: f1, f2, y, yb integer :: j if (mapping%resonance) then call map_breit_wigner & (px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free) else px(1) = p(mapping%i(1)) f1 = 1 end if call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps) pxb(1) = 1 - px(1) px(2) = y pxb(2) = yb call map_unit_square_prec (r2, r2b, f, px, pxb) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2 (j) rb(mapping%i(j)) = r2b(j) end do end subroutine sf_ipr_mapping_compute @ %def sf_ipr_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ipr_mapping_inverse <>= subroutine sf_ipr_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ipr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b real(default) :: f1, f2, y, yb integer :: j do j = 1, 2 r2 (j) = r (mapping%i(j)) r2b(j) = rb(mapping%i(j)) end do call map_unit_square_inverse_prec (r2, r2b, f, px, pxb) if (px(1) > 0) then y = px(2) yb = pxb(2) else y = 0.5_default yb = 0.5_default end if if (mapping%resonance) then call map_breit_wigner_inverse & (px(1), f1, p2(1), mapping%m, mapping%w, x_free) else p2(1) = px(1) f1 = 1 end if call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps) p2b(1) = 1 - p2(1) p2 (2) = 1 - p2b(2) f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = p2b(j) end do end subroutine sf_ipr_mapping_inverse @ %def sf_ipr_mapping_inverse @ \subsection{Implementation: ISR on-shell mapping} Similar to the endpoint mapping above: This maps the unit square ($r_1,r_2$) such that $p_1$ is ignored while the product $r_1r_2$ is constant. $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is flattened. This would be easy in one dimension, but becomes nontrivial in two dimensions. <>= public :: sf_ipo_mapping_t <>= type, extends (sf_mapping_t) :: sf_ipo_mapping_t real(default) :: eps = 0 real(default) :: m = 0 contains <> end type sf_ipo_mapping_t @ %def sf_ipo_mapping_t @ Output. <>= procedure :: write => sf_ipo_mapping_write <>= subroutine sf_ipo_mapping_write (object, unit) class(sf_ipo_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A)") ": isr/os (eps = ", object%eps, & " | ", object%m, ")" end subroutine sf_ipo_mapping_write @ %def sf_ipo_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ipo_mapping_init <>= subroutine sf_ipo_mapping_init (mapping, eps, m) class(sf_ipo_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps, m call mapping%base_init (2) if (present (eps)) mapping%eps = eps if (mapping%eps <= 0) & call msg_fatal ("ISR mapping: regulator epsilon must not be zero") mapping%m = m end subroutine sf_ipo_mapping_init @ %def sf_ipo_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ipo_mapping_compute <>= subroutine sf_ipo_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ipo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, pxb, r2, r2b real(default) :: f1, f2, y, yb integer :: j call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps) px(1) = mapping%m ** 2 if (present (x_free)) px(1) = px(1) / x_free pxb(1) = 1 - px(1) px(2) = y pxb(2) = yb call map_unit_square_prec (r2, r2b, f1, px, pxb) f = f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2 (j) rb(mapping%i(j)) = r2b(j) end do end subroutine sf_ipo_mapping_compute @ %def sf_ipo_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ipo_mapping_inverse <>= subroutine sf_ipo_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ipo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b real(default) :: f1, f2, y, yb integer :: j do j = 1, 2 r2 (j) = r (mapping%i(j)) r2b(j) = rb(mapping%i(j)) end do call map_unit_square_inverse_prec (r2, r2b, f1, px, pxb) y = px(2) yb = pxb(2) call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps) p2(1) = 0 p2b(1)= 1 p2(2) = 1 - p2b(2) f = f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = p2b(j) end do end subroutine sf_ipo_mapping_inverse @ %def sf_ipo_mapping_inverse @ \subsection{Implementation: Endpoint + ISR power mapping} This is a combination of endpoint (i.e., beamstrahlung) and ISR power mapping. The first two parameters apply to the beamstrahlung spectrum, the last two to the ISR function for the first and second beam, respectively. <>= public :: sf_ei_mapping_t <>= type, extends (sf_mapping_t) :: sf_ei_mapping_t type(sf_ep_mapping_t) :: ep type(sf_ip_mapping_t) :: ip contains <> end type sf_ei_mapping_t @ %def sf_ei_mapping_t @ Output. <>= procedure :: write => sf_ei_mapping_write <>= subroutine sf_ei_mapping_write (object, unit) class(sf_ei_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,3(',',I0),')')", advance="no") object%i end if write (u, "(A,ES12.5,A,ES12.5,A)") ": ep/isr (a =", object%ep%a, & ", eps =", object%ip%eps, ")" end subroutine sf_ei_mapping_write @ %def sf_ei_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ei_mapping_init <>= subroutine sf_ei_mapping_init (mapping, a, eps) class(sf_ei_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a, eps call mapping%base_init (4) call mapping%ep%init (a) call mapping%ip%init (eps) end subroutine sf_ei_mapping_init @ %def sf_ei_mapping_init @ Set an index value. We should communicate the appropriate indices to the enclosed sub-mappings, therefore override the method. <>= procedure :: set_index => sf_ei_mapping_set_index <>= subroutine sf_ei_mapping_set_index (mapping, j, i) class(sf_ei_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i select case (j) case (1:2); call mapping%ep%set_index (j, i) case (3:4); call mapping%ip%set_index (j-2, i) end select end subroutine sf_ei_mapping_set_index @ %def sf_mapping_set_index @ Apply mapping. Now, the beamstrahlung and ISR mappings are independent of each other. The parameter subsets that are actually used should not overlap. The Jacobians are multiplied. <>= procedure :: compute => sf_ei_mapping_compute <>= subroutine sf_ei_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ei_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: q, qb real(default) :: f1, f2 call mapping%ep%compute (q, qb, f1, p, pb, x_free) call mapping%ip%compute (r, rb, f2, q, qb, x_free) f = f1 * f2 end subroutine sf_ei_mapping_compute @ %def sf_ei_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ei_mapping_inverse <>= subroutine sf_ei_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ei_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: q, qb real(default) :: f1, f2 call mapping%ip%inverse (r, rb, f2, q, qb, x_free) call mapping%ep%inverse (q, qb, f1, p, pb, x_free) f = f1 * f2 end subroutine sf_ei_mapping_inverse @ %def sf_ei_mapping_inverse @ \subsection{Implementation: Endpoint + ISR + resonance} This is a combination of endpoint (i.e., beamstrahlung) and ISR power mapping, adapted for an s-channel resonance. The first two internal parameters apply to the beamstrahlung spectrum, the last two to the ISR function for the first and second beam, respectively. The first and third parameters are the result of an overall resonance mapping, so on the outside, the first parameter is the total momentum fraction, the third one describes the distribution between beamstrahlung and ISR. <>= public :: sf_eir_mapping_t <>= type, extends (sf_mapping_t) :: sf_eir_mapping_t type(sf_res_mapping_t) :: res type(sf_epr_mapping_t) :: ep type(sf_ipr_mapping_t) :: ip contains <> end type sf_eir_mapping_t @ %def sf_eir_mapping_t @ Output. <>= procedure :: write => sf_eir_mapping_write <>= subroutine sf_eir_mapping_write (object, unit) class(sf_eir_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,3(',',I0),')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A,F7.5,', ',F7.5,A)") & ": ep/isr/res (a =", object%ep%a, & ", eps =", object%ip%eps, " | ", object%res%m, object%res%w, ")" end subroutine sf_eir_mapping_write @ %def sf_eir_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_eir_mapping_init <>= subroutine sf_eir_mapping_init (mapping, a, eps, m, w) class(sf_eir_mapping_t), intent(out) :: mapping real(default), intent(in) :: a, eps, m, w call mapping%base_init (4) call mapping%res%init (m, w) call mapping%ep%init (a) call mapping%ip%init (eps) end subroutine sf_eir_mapping_init @ %def sf_eir_mapping_init @ Set an index value. We should communicate the appropriate indices to the enclosed sub-mappings, therefore override the method. <>= procedure :: set_index => sf_eir_mapping_set_index <>= subroutine sf_eir_mapping_set_index (mapping, j, i) class(sf_eir_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i select case (j) case (1); call mapping%res%set_index (1, i) case (3); call mapping%res%set_index (2, i) end select select case (j) case (1:2); call mapping%ep%set_index (j, i) case (3:4); call mapping%ip%set_index (j-2, i) end select end subroutine sf_eir_mapping_set_index @ %def sf_mapping_set_index @ Apply mapping. Now, the beamstrahlung and ISR mappings are independent of each other. The parameter subsets that are actually used should not overlap. The Jacobians are multiplied. <>= procedure :: compute => sf_eir_mapping_compute <>= subroutine sf_eir_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_eir_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%res%compute (px, pxb, f0, p, pb, x_free) call mapping%ep%compute (q, qb, f1, px, pxb, x_free) call mapping%ip%compute (r, rb, f2, q, qb, x_free) f = f0 * f1 * f2 end subroutine sf_eir_mapping_compute @ %def sf_eir_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_eir_mapping_inverse <>= subroutine sf_eir_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_eir_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%ip%inverse (r, rb, f2, q, qb, x_free) call mapping%ep%inverse (q, qb, f1, px, pxb, x_free) call mapping%res%inverse (px, pxb, f0, p, pb, x_free) f = f0 * f1 * f2 end subroutine sf_eir_mapping_inverse @ %def sf_eir_mapping_inverse @ \subsection{Implementation: Endpoint + ISR power mapping, on-shell} This is a combination of endpoint (i.e., beamstrahlung) and ISR power mapping. The first two parameters apply to the beamstrahlung spectrum, the last two to the ISR function for the first and second beam, respectively. On top of that, we map the first and third parameter such that the product is constant. From the outside, the first parameter is irrelevant while the third parameter describes the distribution of energy (loss) among beamstrahlung and ISR. <>= public :: sf_eio_mapping_t <>= type, extends (sf_mapping_t) :: sf_eio_mapping_t type(sf_os_mapping_t) :: os type(sf_epr_mapping_t) :: ep type(sf_ipr_mapping_t) :: ip contains <> end type sf_eio_mapping_t @ %def sf_eio_mapping_t @ Output. <>= procedure :: write => sf_eio_mapping_write <>= subroutine sf_eio_mapping_write (object, unit) class(sf_eio_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,3(',',I0),')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A,F7.5,A)") ": ep/isr/os (a =", object%ep%a, & ", eps =", object%ip%eps, " | ", object%os%m, ")" end subroutine sf_eio_mapping_write @ %def sf_eio_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_eio_mapping_init <>= subroutine sf_eio_mapping_init (mapping, a, eps, m) class(sf_eio_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a, eps, m call mapping%base_init (4) call mapping%os%init (m) call mapping%ep%init (a) call mapping%ip%init (eps) end subroutine sf_eio_mapping_init @ %def sf_eio_mapping_init @ Set an index value. We should communicate the appropriate indices to the enclosed sub-mappings, therefore override the method. <>= procedure :: set_index => sf_eio_mapping_set_index <>= subroutine sf_eio_mapping_set_index (mapping, j, i) class(sf_eio_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i select case (j) case (1); call mapping%os%set_index (1, i) case (3); call mapping%os%set_index (2, i) end select select case (j) case (1:2); call mapping%ep%set_index (j, i) case (3:4); call mapping%ip%set_index (j-2, i) end select end subroutine sf_eio_mapping_set_index @ %def sf_mapping_set_index @ Apply mapping. Now, the beamstrahlung and ISR mappings are independent of each other. The parameter subsets that are actually used should not overlap. The Jacobians are multiplied. <>= procedure :: compute => sf_eio_mapping_compute <>= subroutine sf_eio_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_eio_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%os%compute (px, pxb, f0, p, pb, x_free) call mapping%ep%compute (q, qb, f1, px, pxb, x_free) call mapping%ip%compute (r, rb, f2, q, qb, x_free) f = f0 * f1 * f2 end subroutine sf_eio_mapping_compute @ %def sf_eio_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_eio_mapping_inverse <>= subroutine sf_eio_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_eio_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%ip%inverse (r, rb, f2, q, qb, x_free) call mapping%ep%inverse (q, qb, f1, px, pxb, x_free) call mapping%os%inverse (px, pxb, f0, p, pb, x_free) f = f0 * f1 * f2 end subroutine sf_eio_mapping_inverse @ %def sf_eio_mapping_inverse @ \subsection{Basic formulas} \subsubsection{Standard mapping of the unit square} This mapping of the unit square is appropriate in particular for structure functions which are concentrated at the lower end. Instead of a rectangular grid, one set of grid lines corresponds to constant parton c.m. energy. The other set is chosen such that the jacobian is only mildly singular ($\ln x$ which is zero at $x=1$), corresponding to an initial concentration of sampling points at the maximum energy. If [[power]] is greater than one (the default), points are also concentrated at the lower end. The formula is ([[power]]=$\alpha$): \begin{align} r_1 &= (p_1 ^ {p_2})^\alpha \\ r_2 &= (p_1 ^ {1 - p_2})^\alpha\\ f &= \alpha^2 p_1 ^ {\alpha - 1} |\log p_1| \end{align} and for the default case $\alpha=1$: \begin{align} r_1 &= p_1 ^ {p_2} \\ r_2 &= p_1 ^ {1 - p_2} \\ f &= |\log p_1| \end{align} <>= subroutine map_unit_square (r, factor, p, power) real(default), dimension(2), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), intent(in), optional :: power real(default) :: xx, yy factor = 1 xx = p(1) yy = p(2) if (present(power)) then if (p(1) > 0 .and. power > 1) then xx = p(1)**power factor = factor * power * xx / p(1) end if end if if (.not. vanishes (xx)) then r(1) = xx ** yy r(2) = xx / r(1) factor = factor * abs (log (xx)) else r = 0 end if end subroutine map_unit_square @ %def map_unit_square @ This is the inverse mapping. <>= subroutine map_unit_square_inverse (r, factor, p, power) real(kind=default), dimension(2), intent(in) :: r real(kind=default), intent(out) :: factor real(kind=default), dimension(2), intent(out) :: p real(kind=default), intent(in), optional :: power real(kind=default) :: lg, xx, yy factor = 1 xx = r(1) * r(2) if (.not. vanishes (xx)) then lg = log (xx) if (.not. vanishes (lg)) then yy = log (r(1)) / lg else yy = 0 end if p(2) = yy factor = factor * abs (lg) if (present(power)) then p(1) = xx**(1._default/power) factor = factor * power * xx / p(1) else p(1) = xx end if else p = 0 end if end subroutine map_unit_square_inverse @ %def map_unit_square_inverse @ \subsubsection{Precise mapping of the unit square} A more precise version (with unit power parameter). This version should be numerically stable near $x=1$ and $y=0,1$. The formulas are again \begin{equation} r_1 = p_1^{p_2}, \qquad r_2 = p_1^{\bar p_2}, \qquad f = - \log p_1 \end{equation} but we compute both $r_i$ and $\bar r_i$ simultaneously and make direct use of both $p_i$ and $\bar p_i$ as appropriate. <>= subroutine map_unit_square_prec (r, rb, factor, p, pb) real(default), dimension(2), intent(out) :: r real(default), dimension(2), intent(out) :: rb real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), dimension(2), intent(in) :: pb if (p(1) > 0.5_default) then call compute_prec_xy_1 (r(1), rb(1), p(1), pb(1), p (2)) call compute_prec_xy_1 (r(2), rb(2), p(1), pb(1), pb(2)) factor = - log_prec (p(1), pb(1)) else if (.not. vanishes (p(1))) then call compute_prec_xy_0 (r(1), rb(1), p(1), pb(1), p (2)) call compute_prec_xy_0 (r(2), rb(2), p(1), pb(1), pb(2)) factor = - log_prec (p(1), pb(1)) else r = 0 rb = 1 factor = 0 end if end subroutine map_unit_square_prec @ %def map_unit_square_prec @ This is the inverse mapping. <>= subroutine map_unit_square_inverse_prec (r, rb, factor, p, pb) real(default), dimension(2), intent(in) :: r real(default), dimension(2), intent(in) :: rb real(default), intent(out) :: factor real(default), dimension(2), intent(out) :: p real(default), dimension(2), intent(out) :: pb call inverse_prec_x (r, rb, p(1), pb(1)) if (all (r > 0)) then if (rb(1) < rb(2)) then call inverse_prec_y (r, rb, p(2), pb(2)) else call inverse_prec_y ([r(2),r(1)], [rb(2),rb(1)], pb(2), p(2)) end if factor = - log_prec (p(1), pb(1)) else p(1) = 0 pb(1) = 1 p(2) = 0.5_default pb(2) = 0.5_default factor = 0 end if end subroutine map_unit_square_inverse_prec @ %def map_unit_square_prec_inverse @ This is an auxiliary function: evaluate the expression $\bar z = 1 - x^y$ in a numerically stable way. Instabilities occur for $y=0$ and $x=1$. The idea is to replace the bracket by the first terms of its Taylor expansion around $x=1$ (read $\bar x\equiv 1 -x$) \begin{equation} 1 - x^y = y\bar x\left(1 + \frac12(1-y)\bar x + \frac16(2-y)(1-y)\bar x^2\right) \end{equation} whenever this is the better approximation. Actually, the relative numerical error of the exact formula is about $\eta/(y\bar x)$ where $\eta$ is given by [[epsilon(KIND)]] in Fortran. The relative error of the approximation is better than the last included term divided by $(y\bar x)$. The first subroutine computes $z$ and $\bar z$ near $x=1$ where $\log x$ should be expanded, the second one near $x=0$ where $\log x$ can be kept. <>= subroutine compute_prec_xy_1 (z, zb, x, xb, y) real(default), intent(out) :: z, zb real(default), intent(in) :: x, xb, y real(default) :: a1, a2, a3 a1 = y * xb a2 = a1 * (1 - y) * xb / 2 a3 = a2 * (2 - y) * xb / 3 if (abs (a3) < epsilon (a3)) then zb = a1 + a2 + a3 z = 1 - zb else z = x ** y zb = 1 - z end if end subroutine compute_prec_xy_1 subroutine compute_prec_xy_0 (z, zb, x, xb, y) real(default), intent(out) :: z, zb real(default), intent(in) :: x, xb, y real(default) :: a1, a2, a3, lx lx = -log (x) a1 = y * lx a2 = a1 * y * lx / 2 a3 = a2 * y * lx / 3 if (abs (a3) < epsilon (a3)) then zb = a1 + a2 + a3 z = 1 - zb else z = x ** y zb = 1 - z end if end subroutine compute_prec_xy_0 @ %def compute_prec_xy_1 @ %def compute_prec_xy_0 @ For the inverse calculation, we evaluate $x=r_1r_2$ in a stable way. Since it is just a polynomial, the expansion near $x=1$ is analytically exact, and we don't need to choose based on precision. <>= subroutine inverse_prec_x (r, rb, x, xb) real(default), dimension(2), intent(in) :: r, rb real(default), intent(out) :: x, xb real(default) :: a0, a1 a0 = rb(1) + rb(2) a1 = rb(1) * rb(2) if (a0 > 0.5_default) then xb = a0 - a1 x = 1 - xb else x = r(1) * r(2) xb = 1 - x end if end subroutine inverse_prec_x @ %def inverse_prec_x @ The inverse calculation for the relative momentum fraction \begin{equation} y = \frac{1}{1 + \frac{\log{r_2}}{\log{r_1}}} \end{equation} is slightly more complicated. We should take the precise form of the logarithm, so we are safe near $r_i=1$. A series expansion is required if $r_1\ll r_2$, since then $y$ becomes small. (We assume $r_1>= subroutine inverse_prec_y (r, rb, y, yb) real(default), dimension(2), intent(in) :: r, rb real(default), intent(out) :: y, yb real(default) :: log1, log2, a1, a2, a3 log1 = log_prec (r(1), rb(1)) log2 = log_prec (r(2), rb(2)) if (abs (log2**3) < epsilon (one)) then if (abs(log1) < epsilon (one)) then y = zero else y = one / (one + log2 / log1) end if if (abs(log2) < epsilon (one)) then yb = zero else yb = one / (one + log1 / log2) end if return end if a1 = - rb(1) / log2 a2 = - rb(1) ** 2 * (one / log2**2 + one / (2 * log2)) a3 = - rb(1) ** 3 * (one / log2**3 + one / log2**2 + one/(3 * log2)) if (abs (a3) < epsilon (a3)) then y = a1 + a2 + a3 yb = one - y else y = one / (one + log2 / log1) yb = one / (one + log1 / log2) end if end subroutine inverse_prec_y @ %def inverse_prec_y @ \subsubsection{Mapping for on-shell s-channel} The limiting case, if the product $r_1r_2$ is fixed for on-shell production. The parameter $p_1$ is ignored. In the inverse mapping, it is returned zero. The parameter [[x_free]], if present, rescales the total energy. If it is less than one, the rescaled mass parameter $m^2$ should be increased accordingly. Public for access in unit test. <>= public :: map_on_shell public :: map_on_shell_inverse <>= subroutine map_on_shell (r, factor, p, lm2, x_free) real(default), dimension(2), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) r(1) = exp (- p(2) * lx) r(2) = exp (- (1 - p(2)) * lx) factor = lx end subroutine map_on_shell subroutine map_on_shell_inverse (r, factor, p, lm2, x_free) real(default), dimension(2), intent(in) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(out) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) p(1) = 0 p(2) = abs (log (r(1))) / lx factor = lx end subroutine map_on_shell_inverse @ %def map_on_shell @ %def map_on_shell_inverse @ \subsubsection{Mapping for on-shell s-channel, single parameter} This is a pseudo-mapping which applies if there is actually just one parameter [[p]]. The output parameter [[r]] is fixed for on-shell production. The lone parameter $p_1$ is ignored. In the inverse mapping, it is returned zero. The parameter [[x_free]], if present, rescales the total energy. If it is less than one, the rescaled mass parameter $m^2$ should be increased accordingly. Public for access in unit test. <>= public :: map_on_shell_single public :: map_on_shell_single_inverse <>= subroutine map_on_shell_single (r, factor, p, lm2, x_free) real(default), dimension(1), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(1), intent(in) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) r(1) = exp (- lx) factor = 1 end subroutine map_on_shell_single subroutine map_on_shell_single_inverse (r, factor, p, lm2, x_free) real(default), dimension(1), intent(in) :: r real(default), intent(out) :: factor real(default), dimension(1), intent(out) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) p(1) = 0 factor = 1 end subroutine map_on_shell_single_inverse @ %def map_on_shell_single @ %def map_on_shell_single_inverse @ \subsubsection{Mapping for a Breit-Wigner resonance} This is the standard Breit-Wigner mapping. We apply it to a single variable, independently of or in addition to a unit-square mapping. We assume here that the limits for the variable are 0 and 1, and that the mass $m$ and width $w$ are rescaled appropriately, so they are dimensionless and usually between 0 and 1. If [[x_free]] is set, it rescales the total energy and thus mass and width, since these are defined with respect to the total energy. <>= subroutine map_breit_wigner (r, factor, p, m, w, x_free) real(default), intent(out) :: r real(default), intent(out) :: factor real(default), intent(in) :: p real(default), intent(in) :: m real(default), intent(in) :: w real(default), intent(in), optional :: x_free real(default) :: m2, mw, a1, a2, a3, z, tmp m2 = m ** 2 mw = m * w if (present (x_free)) then m2 = m2 / x_free mw = mw / x_free end if a1 = atan (- m2 / mw) a2 = atan ((1 - m2) / mw) a3 = (a2 - a1) * mw z = (1-p) * a1 + p * a2 if (-pi/2 < z .and. z < pi/2) then tmp = tan (z) r = max (m2 + mw * tmp, 0._default) factor = a3 * (1 + tmp ** 2) else r = 0 factor = 0 end if end subroutine map_breit_wigner subroutine map_breit_wigner_inverse (r, factor, p, m, w, x_free) real(default), intent(in) :: r real(default), intent(out) :: factor real(default), intent(out) :: p real(default), intent(in) :: m real(default), intent(in) :: w real(default) :: m2, mw, a1, a2, a3, tmp real(default), intent(in), optional :: x_free m2 = m ** 2 mw = m * w if (present (x_free)) then m2 = m2 / x_free mw = mw / x_free end if a1 = atan (- m2 / mw) a2 = atan ((1 - m2) / mw) a3 = (a2 - a1) * mw tmp = (r - m2) / mw p = (atan (tmp) - a1) / (a2 - a1) factor = a3 * (1 + tmp ** 2) end subroutine map_breit_wigner_inverse @ %def map_breit_wigner @ %def map_breit_wigner_inverse @ \subsubsection{Mapping with endpoint enhancement} This is a mapping which is close to the unit mapping, except that at the endpoint(s), the output values are exponentially enhanced. \begin{equation} y = \tanh (a \tan (\frac{\pi}{2}x)) \end{equation} We have two variants: one covers endpoints at $0$ and $1$ symmetrically, while the other one (which essentially maps one-half of the range), covers only the endpoint at $1$. <>= subroutine map_endpoint_1 (x3, factor, x1, a) real(default), intent(out) :: x3, factor real(default), intent(in) :: x1 real(default), intent(in) :: a real(default) :: x2 if (abs (x1) < 1) then x2 = tan (x1 * pi / 2) x3 = tanh (a * x2) factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2) else x3 = x1 factor = 0 end if end subroutine map_endpoint_1 subroutine map_endpoint_inverse_1 (x3, factor, x1, a) real(default), intent(in) :: x3 real(default), intent(out) :: x1, factor real(default), intent(in) :: a real(default) :: x2 if (abs (x3) < 1) then x2 = atanh (x3) / a x1 = 2 / pi * atan (x2) factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2) else x1 = x3 factor = 0 end if end subroutine map_endpoint_inverse_1 subroutine map_endpoint_01 (x4, factor, x0, a) real(default), intent(out) :: x4, factor real(default), intent(in) :: x0 real(default), intent(in) :: a real(default) :: x1, x3 x1 = 2 * x0 - 1 call map_endpoint_1 (x3, factor, x1, a) x4 = (x3 + 1) / 2 end subroutine map_endpoint_01 subroutine map_endpoint_inverse_01 (x4, factor, x0, a) real(default), intent(in) :: x4 real(default), intent(out) :: x0, factor real(default), intent(in) :: a real(default) :: x1, x3 x3 = 2 * x4 - 1 call map_endpoint_inverse_1 (x3, factor, x1, a) x0 = (x1 + 1) / 2 end subroutine map_endpoint_inverse_01 @ %def map_endpoint_1 @ %def map_endpoint_inverse_1 @ %def map_endpoint_01 @ %def map_endpoint_inverse_01 @ \subsubsection{Mapping with endpoint enhancement (ISR)} This is another endpoint mapping. It is designed to flatten the ISR singularity which is of power type at $x=1$, i.e., if \begin{equation} \sigma = \int_0^1 dx\,f(x)\,G(x) = \int_0^1 dx\,\epsilon(1-x)^{-1+\epsilon} G(x), \end{equation} we replace this by \begin{equation} r = x^\epsilon \quad\Longrightarrow\quad \sigma = \int_0^1 dr\,G(1- (1-r)^{1/\epsilon}). \end{equation} We expect that $\epsilon$ is small. The actual mapping is $r\to x$ (so $x$ emerges closer to $1$). The Jacobian that we return is thus $1/f(x)$. We compute the mapping in terms of $\bar x\equiv 1 - x$, so we can achieve the required precision. Because some compilers show quite wild numeric fluctuations, we internally convert numeric types to explicit [[double]] precision. <>= public :: map_power_1 public :: map_power_inverse_1 <>= subroutine map_power_1 (xb, factor, rb, eps) real(default), intent(out) :: xb, factor real(default), intent(in) :: rb real(double) :: rb_db, factor_db, eps_db, xb_db real(default), intent(in) :: eps rb_db = real (rb, kind=double) eps_db = real (eps, kind=double) xb_db = rb_db ** (1 / eps_db) if (rb_db > 0) then factor_db = xb_db / rb_db / eps_db factor = real (factor_db, kind=default) else factor = 0 end if xb = real (xb_db, kind=default) end subroutine map_power_1 subroutine map_power_inverse_1 (xb, factor, rb, eps) real(default), intent(in) :: xb real(default), intent(out) :: rb, factor real(double) :: xb_db, factor_db, eps_db, rb_db real(default), intent(in) :: eps xb_db = real (xb, kind=double) eps_db = real (eps, kind=double) rb_db = xb_db ** eps_db if (xb_db > 0) then factor_db = xb_db / rb_db / eps_db factor = real (factor_db, kind=default) else factor = 0 end if rb = real (rb_db, kind=default) end subroutine map_power_inverse_1 @ %def map_power_1 @ %def map_power_inverse_1 @ Here we apply a power mapping to both endpoints. We divide the interval in two equal halves and apply the power mapping for the nearest endpoint, either $0$ or $1$. <>= subroutine map_power_01 (y, yb, factor, r, eps) real(default), intent(out) :: y, yb, factor real(default), intent(in) :: r real(default), intent(in) :: eps real(default) :: u, ub, zp, zm u = 2 * r - 1 if (u > 0) then ub = 2 * (1 - r) call map_power_1 (zm, factor, ub, eps) zp = 2 - zm else if (u < 0) then ub = 2 * r call map_power_1 (zp, factor, ub, eps) zm = 2 - zp else factor = 1 / eps zp = 1 zm = 1 end if y = zp / 2 yb = zm / 2 end subroutine map_power_01 subroutine map_power_inverse_01 (y, yb, factor, r, eps) real(default), intent(in) :: y, yb real(default), intent(out) :: r, factor real(default), intent(in) :: eps real(default) :: ub, zp, zm zp = 2 * y zm = 2 * yb if (zm < zp) then call map_power_inverse_1 (zm, factor, ub, eps) r = 1 - ub / 2 else if (zp < zm) then call map_power_inverse_1 (zp, factor, ub, eps) r = ub / 2 else factor = 1 / eps ub = 1 r = ub / 2 end if end subroutine map_power_inverse_01 @ %def map_power_01 @ %def map_power_inverse_01 @ \subsubsection{Structure-function channels} A structure-function chain parameterization (channel) may contain a mapping that applies to multiple structure functions. This is described by an extension of the [[sf_mapping_t]] type. In addition, it may contain mappings that apply to (other) individual structure functions. The details of these mappings are implementation-specific. The [[sf_channel_t]] type combines this information. It contains an array of map codes, one for each structure-function entry. The code values are: \begin{description} \item[none] MC input parameters $r$ directly become energy fractions $x$ \item[single] default mapping for a single structure-function entry \item[multi/s] map $r\to x$ such that one MC input parameter is $\hat s/s$ \item[multi/resonance] as before, adapted to s-channel resonance \item[multi/on-shell] as before, adapted to an on-shell particle in the s channel \item[multi/endpoint] like multi/s, but enhance the region near $r_i=1$ \item[multi/endpoint/res] endpoint mapping with resonance \item[multi/endpoint/os] endpoint mapping for on-shell \item[multi/power/os] like multi/endpoint, regulating a power singularity \end{description} <>= integer, parameter :: SFMAP_NONE = 0 integer, parameter :: SFMAP_SINGLE = 1 integer, parameter :: SFMAP_MULTI_S = 2 integer, parameter :: SFMAP_MULTI_RES = 3 integer, parameter :: SFMAP_MULTI_ONS = 4 integer, parameter :: SFMAP_MULTI_EP = 5 integer, parameter :: SFMAP_MULTI_EPR = 6 integer, parameter :: SFMAP_MULTI_EPO = 7 integer, parameter :: SFMAP_MULTI_IP = 8 integer, parameter :: SFMAP_MULTI_IPR = 9 integer, parameter :: SFMAP_MULTI_IPO = 10 integer, parameter :: SFMAP_MULTI_EI = 11 integer, parameter :: SFMAP_MULTI_SRS = 13 integer, parameter :: SFMAP_MULTI_SON = 14 @ %def SFMAP_NONE SFMAP_SINGLE @ %def SFMAP_MULTI_S SFMAP_MULTI_RES SFMAP_MULTI_ONS @ %def SFMAP_MULTI_EP SFMAP_MULTI_EPR SFMAP_MULTI_EPO @ %def SFMAP_MULTI_IP SFMAP_MULTI_IPR SFMAP_MULTI_IPO @ %def SFMAP_MULTI_EI @ %def SFMAP_MULTI_SRS SFMAP_MULTI_SON @ Then, it contains an allocatable entry for the multi mapping. This entry holds the MC-parameter indices on which the mapping applies (there may be more than one MC parameter per structure-function entry) and any parameters associated with the mapping. There can be only one multi-mapping per channel. <>= public :: sf_channel_t <>= type :: sf_channel_t integer, dimension(:), allocatable :: map_code class(sf_mapping_t), allocatable :: multi_mapping contains <> end type sf_channel_t @ %def sf_channel_t @ The output format prints a single character for each structure-function entry and, if applicable, an account of the mapping parameters. <>= procedure :: write => sf_channel_write <>= subroutine sf_channel_write (object, unit) class(sf_channel_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) if (allocated (object%map_code)) then do i = 1, size (object%map_code) select case (object%map_code (i)) case (SFMAP_NONE) write (u, "(1x,A)", advance="no") "-" case (SFMAP_SINGLE) write (u, "(1x,A)", advance="no") "+" case (SFMAP_MULTI_S) write (u, "(1x,A)", advance="no") "s" case (SFMAP_MULTI_RES, SFMAP_MULTI_SRS) write (u, "(1x,A)", advance="no") "r" case (SFMAP_MULTI_ONS, SFMAP_MULTI_SON) write (u, "(1x,A)", advance="no") "o" case (SFMAP_MULTI_EP) write (u, "(1x,A)", advance="no") "e" case (SFMAP_MULTI_EPR) write (u, "(1x,A)", advance="no") "p" case (SFMAP_MULTI_EPO) write (u, "(1x,A)", advance="no") "q" case (SFMAP_MULTI_IP) write (u, "(1x,A)", advance="no") "i" case (SFMAP_MULTI_IPR) write (u, "(1x,A)", advance="no") "i" case (SFMAP_MULTI_IPO) write (u, "(1x,A)", advance="no") "i" case (SFMAP_MULTI_EI) write (u, "(1x,A)", advance="no") "i" case default write (u, "(1x,A)", advance="no") "?" end select end do else write (u, "(1x,A)", advance="no") "-" end if if (allocated (object%multi_mapping)) then write (u, "(1x,'/')", advance="no") call object%multi_mapping%write (u) else write (u, *) end if end subroutine sf_channel_write @ %def sf_channel_write @ Initializer for a single [[sf_channel]] object. <>= procedure :: init => sf_channel_init <>= subroutine sf_channel_init (channel, n_strfun) class(sf_channel_t), intent(out) :: channel integer, intent(in) :: n_strfun allocate (channel%map_code (n_strfun)) channel%map_code = SFMAP_NONE end subroutine sf_channel_init @ %def sf_channel_init @ Assignment. This merely copies intrinsic assignment, but apparently the latter is bugged in gfortran 4.6.3, causing memory corruption. <>= generic :: assignment (=) => sf_channel_assign procedure :: sf_channel_assign <>= subroutine sf_channel_assign (copy, original) class(sf_channel_t), intent(out) :: copy type(sf_channel_t), intent(in) :: original allocate (copy%map_code (size (original%map_code))) copy%map_code = original%map_code if (allocated (original%multi_mapping)) then allocate (copy%multi_mapping, source = original%multi_mapping) end if end subroutine sf_channel_assign @ %def sf_channel_assign @ This initializer allocates an array of channels with common number of structure-function entries, therefore it is not a type-bound procedure. <>= public :: allocate_sf_channels <>= subroutine allocate_sf_channels (channel, n_channel, n_strfun) type(sf_channel_t), dimension(:), intent(out), allocatable :: channel integer, intent(in) :: n_channel integer, intent(in) :: n_strfun integer :: c allocate (channel (n_channel)) do c = 1, n_channel call channel(c)%init (n_strfun) end do end subroutine allocate_sf_channels @ %def allocate_sf_channels @ This marks a given subset of indices as single-mapping. <>= procedure :: activate_mapping => sf_channel_activate_mapping <>= subroutine sf_channel_activate_mapping (channel, i_sf) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf channel%map_code(i_sf) = SFMAP_SINGLE end subroutine sf_channel_activate_mapping @ %def sf_channel_activate_mapping @ This sets an s-channel multichannel mapping. The parameter indices are not yet set. <>= procedure :: set_s_mapping => sf_channel_set_s_mapping <>= subroutine sf_channel_set_s_mapping (channel, i_sf, power) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: power channel%map_code(i_sf) = SFMAP_MULTI_S allocate (sf_s_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_s_mapping_t) call mapping%init (power) end select end subroutine sf_channel_set_s_mapping @ %def sf_channel_set_s_mapping @ This sets an s-channel resonance multichannel mapping. <>= procedure :: set_res_mapping => sf_channel_set_res_mapping <>= subroutine sf_channel_set_res_mapping (channel, i_sf, m, w, single) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: m, w logical, intent(in) :: single if (single) then channel%map_code(i_sf) = SFMAP_MULTI_SRS allocate (sf_res_mapping_single_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_res_mapping_single_t) call mapping%init (m, w) end select else channel%map_code(i_sf) = SFMAP_MULTI_RES allocate (sf_res_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_res_mapping_t) call mapping%init (m, w) end select end if end subroutine sf_channel_set_res_mapping @ %def sf_channel_set_res_mapping @ This sets an s-channel on-shell multichannel mapping. The length of the [[i_sf]] array must be 2. (The first parameter actually becomes an irrelevant dummy.) <>= procedure :: set_os_mapping => sf_channel_set_os_mapping <>= subroutine sf_channel_set_os_mapping (channel, i_sf, m, single) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: m logical, intent(in) :: single if (single) then channel%map_code(i_sf) = SFMAP_MULTI_SON allocate (sf_os_mapping_single_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_os_mapping_single_t) call mapping%init (m) end select else channel%map_code(i_sf) = SFMAP_MULTI_ONS allocate (sf_os_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_os_mapping_t) call mapping%init (m) end select end if end subroutine sf_channel_set_os_mapping @ %def sf_channel_set_os_mapping @ This sets an s-channel endpoint mapping. The parameter $a$ is the slope parameter (default 1); increasing it moves the endpoint region (at $x=1$ to lower values in the input parameter. region even more. <>= procedure :: set_ep_mapping => sf_channel_set_ep_mapping <>= subroutine sf_channel_set_ep_mapping (channel, i_sf, a) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a channel%map_code(i_sf) = SFMAP_MULTI_EP allocate (sf_ep_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ep_mapping_t) call mapping%init (a = a) end select end subroutine sf_channel_set_ep_mapping @ %def sf_channel_set_ep_mapping @ This sets a resonant endpoint mapping. <>= procedure :: set_epr_mapping => sf_channel_set_epr_mapping <>= subroutine sf_channel_set_epr_mapping (channel, i_sf, a, m, w) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: a, m, w channel%map_code(i_sf) = SFMAP_MULTI_EPR allocate (sf_epr_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_epr_mapping_t) call mapping%init (a, m, w) end select end subroutine sf_channel_set_epr_mapping @ %def sf_channel_set_epr_mapping @ This sets an on-shell endpoint mapping. <>= procedure :: set_epo_mapping => sf_channel_set_epo_mapping <>= subroutine sf_channel_set_epo_mapping (channel, i_sf, a, m) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: a, m channel%map_code(i_sf) = SFMAP_MULTI_EPO allocate (sf_epo_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_epo_mapping_t) call mapping%init (a, m) end select end subroutine sf_channel_set_epo_mapping @ %def sf_channel_set_epo_mapping @ This sets an s-channel power mapping, regulating a singularity of type $(1-x)^{-1+\epsilon}$. The parameter $\epsilon$ depends on the structure function. <>= procedure :: set_ip_mapping => sf_channel_set_ip_mapping <>= subroutine sf_channel_set_ip_mapping (channel, i_sf, eps) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: eps channel%map_code(i_sf) = SFMAP_MULTI_IP allocate (sf_ip_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ip_mapping_t) call mapping%init (eps) end select end subroutine sf_channel_set_ip_mapping @ %def sf_channel_set_ip_mapping @ This sets an s-channel resonant power mapping, regulating a singularity of type $(1-x)^{-1+\epsilon}$ in the presence of an s-channel resonance. The parameter $\epsilon$ depends on the structure function. <>= procedure :: set_ipr_mapping => sf_channel_set_ipr_mapping <>= subroutine sf_channel_set_ipr_mapping (channel, i_sf, eps, m, w) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: eps, m, w channel%map_code(i_sf) = SFMAP_MULTI_IPR allocate (sf_ipr_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ipr_mapping_t) call mapping%init (eps, m, w) end select end subroutine sf_channel_set_ipr_mapping @ %def sf_channel_set_ipr_mapping @ This sets an on-shell power mapping, regulating a singularity of type $(1-x)^{-1+\epsilon}$ for the production of a single on-shell particle.. The parameter $\epsilon$ depends on the structure function. <>= procedure :: set_ipo_mapping => sf_channel_set_ipo_mapping <>= subroutine sf_channel_set_ipo_mapping (channel, i_sf, eps, m) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: eps, m channel%map_code(i_sf) = SFMAP_MULTI_IPO allocate (sf_ipo_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ipo_mapping_t) call mapping%init (eps, m) end select end subroutine sf_channel_set_ipo_mapping @ %def sf_channel_set_ipo_mapping @ This sets a combined endpoint/ISR mapping. <>= procedure :: set_ei_mapping => sf_channel_set_ei_mapping <>= subroutine sf_channel_set_ei_mapping (channel, i_sf, a, eps) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a, eps channel%map_code(i_sf) = SFMAP_MULTI_EI allocate (sf_ei_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ei_mapping_t) call mapping%init (a, eps) end select end subroutine sf_channel_set_ei_mapping @ %def sf_channel_set_ei_mapping @ This sets a combined endpoint/ISR mapping with resonance. <>= procedure :: set_eir_mapping => sf_channel_set_eir_mapping <>= subroutine sf_channel_set_eir_mapping (channel, i_sf, a, eps, m, w) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a, eps, m, w channel%map_code(i_sf) = SFMAP_MULTI_EI allocate (sf_eir_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_eir_mapping_t) call mapping%init (a, eps, m, w) end select end subroutine sf_channel_set_eir_mapping @ %def sf_channel_set_eir_mapping @ This sets a combined endpoint/ISR mapping, on-shell. <>= procedure :: set_eio_mapping => sf_channel_set_eio_mapping <>= subroutine sf_channel_set_eio_mapping (channel, i_sf, a, eps, m) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a, eps, m channel%map_code(i_sf) = SFMAP_MULTI_EI allocate (sf_eio_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_eio_mapping_t) call mapping%init (a, eps, m) end select end subroutine sf_channel_set_eio_mapping @ %def sf_channel_set_eio_mapping @ Return true if the mapping code at position [[i_sf]] is [[SFMAP_SINGLE]]. <>= procedure :: is_single_mapping => sf_channel_is_single_mapping <>= function sf_channel_is_single_mapping (channel, i_sf) result (flag) class(sf_channel_t), intent(in) :: channel integer, intent(in) :: i_sf logical :: flag flag = channel%map_code(i_sf) == SFMAP_SINGLE end function sf_channel_is_single_mapping @ %def sf_channel_is_single_mapping @ Return true if the mapping code at position [[i_sf]] is any of the [[SFMAP_MULTI]] mappings. <>= procedure :: is_multi_mapping => sf_channel_is_multi_mapping <>= function sf_channel_is_multi_mapping (channel, i_sf) result (flag) class(sf_channel_t), intent(in) :: channel integer, intent(in) :: i_sf logical :: flag select case (channel%map_code(i_sf)) case (SFMAP_NONE, SFMAP_SINGLE) flag = .false. case default flag = .true. end select end function sf_channel_is_multi_mapping @ %def sf_channel_is_multi_mapping @ Return the number of parameters that the multi-mapping requires. The mapping object must be allocated. <>= procedure :: get_multi_mapping_n_par => sf_channel_get_multi_mapping_n_par <>= function sf_channel_get_multi_mapping_n_par (channel) result (n_par) class(sf_channel_t), intent(in) :: channel integer :: n_par if (allocated (channel%multi_mapping)) then n_par = channel%multi_mapping%get_n_dim () else n_par = 0 end if end function sf_channel_get_multi_mapping_n_par @ %def sf_channel_is_multi_mapping @ Return true if there is any nontrivial mapping in any of the channels. Note: we provide an explicit public function. gfortran 4.6.3 has problems with the alternative implementation as a type-bound procedure for an array base object. <>= public :: any_sf_channel_has_mapping <>= function any_sf_channel_has_mapping (channel) result (flag) type(sf_channel_t), dimension(:), intent(in) :: channel logical :: flag integer :: c flag = .false. do c = 1, size (channel) flag = flag .or. any (channel(c)%map_code /= SFMAP_NONE) end do end function any_sf_channel_has_mapping @ %def any_sf_channel_has_mapping @ Set a parameter index for an active multi mapping. We assume that the index array is allocated properly. <>= procedure :: set_par_index => sf_channel_set_par_index <>= subroutine sf_channel_set_par_index (channel, j, i_par) class(sf_channel_t), intent(inout) :: channel integer, intent(in) :: j integer, intent(in) :: i_par associate (mapping => channel%multi_mapping) if (j >= 1 .and. j <= mapping%get_n_dim ()) then if (mapping%get_index (j) == 0) then call channel%multi_mapping%set_index (j, i_par) else call msg_bug ("Structure-function setup: mapping index set twice") end if else call msg_bug ("Structure-function setup: mapping index out of range") end if end associate end subroutine sf_channel_set_par_index @ %def sf_channel_set_par_index @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_mappings_ut.f90]]>>= <> module sf_mappings_ut use unit_tests use sf_mappings_uti <> <> contains <> end module sf_mappings_ut @ %def sf_mappings_ut @ <<[[sf_mappings_uti.f90]]>>= <> module sf_mappings_uti <> use format_defs, only: FMT_11, FMT_12, FMT_13, FMT_14, FMT_15, FMT_16 use sf_mappings <> <> contains <> end module sf_mappings_uti @ %def sf_mappings_ut @ API: driver for the unit tests below. <>= public :: sf_mappings_test <>= subroutine sf_mappings_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_mappings_test @ %def sf_mappings_test @ \subsubsection{Check standard mapping} Probe the standard mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_1, "sf_mappings_1", & "standard pair mapping", & u, results) <>= public :: sf_mappings_1 <>= subroutine sf_mappings_1 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_1" write (u, "(A)") "* Purpose: probe standard mapping" write (u, "(A)") allocate (sf_s_mapping_t :: mapping) select type (mapping) type is (sf_s_mapping_t) call mapping%init () call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.1):" p = [0.1_default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) allocate (sf_s_mapping_t :: mapping) select type (mapping) type is (sf_s_mapping_t) call mapping%init (power=2._default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select write (u, *) call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.1):" p = [0.1_default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_1" end subroutine sf_mappings_1 @ %def sf_mappings_1 @ \subsubsection{Channel entries} Construct channel entries and print them. <>= call test (sf_mappings_2, "sf_mappings_2", & "structure-function mapping channels", & u, results) <>= public :: sf_mappings_2 <>= subroutine sf_mappings_2 (u) integer, intent(in) :: u type(sf_channel_t), dimension(:), allocatable :: channel integer :: c write (u, "(A)") "* Test output: sf_mappings_2" write (u, "(A)") "* Purpose: construct and display & &mapping-channel objects" write (u, "(A)") call allocate_sf_channels (channel, n_channel = 8, n_strfun = 2) call channel(2)%activate_mapping ([1]) call channel(3)%set_s_mapping ([1,2]) call channel(4)%set_s_mapping ([1,2], power=2._default) call channel(5)%set_res_mapping ([1,2], m = 0.5_default, w = 0.1_default, single = .false.) call channel(6)%set_os_mapping ([1,2], m = 0.5_default, single = .false.) call channel(7)%set_res_mapping ([1], m = 0.5_default, w = 0.1_default, single = .true.) call channel(8)%set_os_mapping ([1], m = 0.5_default, single = .true.) call channel(3)%set_par_index (1, 1) call channel(3)%set_par_index (2, 4) call channel(4)%set_par_index (1, 1) call channel(4)%set_par_index (2, 4) call channel(5)%set_par_index (1, 1) call channel(5)%set_par_index (2, 3) call channel(6)%set_par_index (1, 1) call channel(6)%set_par_index (2, 2) call channel(7)%set_par_index (1, 1) call channel(8)%set_par_index (1, 1) do c = 1, size (channel) write (u, "(I0,':')", advance="no") c call channel(c)%write (u) end do write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_2" end subroutine sf_mappings_2 @ %def sf_mappings_2 @ \subsubsection{Check resonance mapping} Probe the resonance mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. The resonance mass is at $1/2$ the energy, the width is $1/10$. <>= call test (sf_mappings_3, "sf_mappings_3", & "resonant pair mapping", & u, results) <>= public :: sf_mappings_3 <>= subroutine sf_mappings_3 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_3" write (u, "(A)") "* Purpose: probe resonance pair mapping" write (u, "(A)") allocate (sf_res_mapping_t :: mapping) select type (mapping) type is (sf_res_mapping_t) call mapping%init (0.5_default, 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.1):" p = [0.1_default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_3" end subroutine sf_mappings_3 @ %def sf_mappings_3 @ \subsubsection{Check on-shell mapping} Probe the on-shell mapping of the unit square for different parameter values. Also calculates integrals. In this case, the Jacobian is constant and given by $|\log m^2|$, so this is also the value of the integral. The factor results from the variable change in the $\delta$ function $\delta (m^2 - x_1x_2)$ which multiplies the cross section for the case at hand. For the test, the (rescaled) resonance mass is set at $1/2$ the energy. <>= call test (sf_mappings_4, "sf_mappings_4", & "on-shell pair mapping", & u, results) <>= public :: sf_mappings_4 <>= subroutine sf_mappings_4 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_4" write (u, "(A)") "* Purpose: probe on-shell pair mapping" write (u, "(A)") allocate (sf_os_mapping_t :: mapping) select type (mapping) type is (sf_os_mapping_t) call mapping%init (0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0,0.1):" p = [0._default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0,1.0):" p = [0._default, 1.0_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_4" end subroutine sf_mappings_4 @ %def sf_mappings_4 @ \subsubsection{Check endpoint mapping} Probe the endpoint mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_5, "sf_mappings_5", & "endpoint pair mapping", & u, results) <>= public :: sf_mappings_5 <>= subroutine sf_mappings_5 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_5" write (u, "(A)") "* Purpose: probe endpoint pair mapping" write (u, "(A)") allocate (sf_ep_mapping_t :: mapping) select type (mapping) type is (sf_ep_mapping_t) call mapping%init () call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_5" end subroutine sf_mappings_5 @ %def sf_mappings_5 @ \subsubsection{Check endpoint resonant mapping} Probe the endpoint mapping with resonance. Also calculates integrals. <>= call test (sf_mappings_6, "sf_mappings_6", & "endpoint resonant mapping", & u, results) <>= public :: sf_mappings_6 <>= subroutine sf_mappings_6 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_6" write (u, "(A)") "* Purpose: probe endpoint resonant mapping" write (u, "(A)") allocate (sf_epr_mapping_t :: mapping) select type (mapping) type is (sf_epr_mapping_t) call mapping%init (a = 1._default, m = 0.5_default, w = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Same mapping without resonance:" write (u, "(A)") allocate (sf_epr_mapping_t :: mapping) select type (mapping) type is (sf_epr_mapping_t) call mapping%init (a = 1._default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_6" end subroutine sf_mappings_6 @ %def sf_mappings_6 @ \subsubsection{Check endpoint on-shell mapping} Probe the endpoint mapping with an on-shell particle. Also calculates integrals. <>= call test (sf_mappings_7, "sf_mappings_7", & "endpoint on-shell mapping", & u, results) <>= public :: sf_mappings_7 <>= subroutine sf_mappings_7 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_7" write (u, "(A)") "* Purpose: probe endpoint on-shell mapping" write (u, "(A)") allocate (sf_epo_mapping_t :: mapping) select type (mapping) type is (sf_epo_mapping_t) call mapping%init (a = 1._default, m = 0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_7" end subroutine sf_mappings_7 @ %def sf_mappings_7 @ \subsubsection{Check power mapping} Probe the power mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_8, "sf_mappings_8", & "power pair mapping", & u, results) <>= public :: sf_mappings_8 <>= subroutine sf_mappings_8 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p, pb write (u, "(A)") "* Test output: sf_mappings_8" write (u, "(A)") "* Purpose: probe power pair mapping" write (u, "(A)") allocate (sf_ip_mapping_t :: mapping) select type (mapping) type is (sf_ip_mapping_t) call mapping%init (eps = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] pb= [0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9,0.5):" p = [0.9_default, 0.5_default] pb= [0.1_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] pb= [0.3_default, 0.8_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.8):" p = [0.7_default, 0.8_default] pb= [0.3_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.99,0.02):" p = [0.99_default, 0.02_default] pb= [0.01_default, 0.98_default] call mapping%check (u, p, pb, FMT_14, FMT_12) write (u, *) write (u, "(A)") "Probe at (0.99,0.98):" p = [0.99_default, 0.98_default] pb= [0.01_default, 0.02_default] call mapping%check (u, p, pb, FMT_14, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_8" end subroutine sf_mappings_8 @ %def sf_mappings_8 @ \subsubsection{Check resonant power mapping} Probe the power mapping of the unit square, adapted for an s-channel resonance, for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_9, "sf_mappings_9", & "power resonance mapping", & u, results) <>= public :: sf_mappings_9 <>= subroutine sf_mappings_9 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p, pb write (u, "(A)") "* Test output: sf_mappings_9" write (u, "(A)") "* Purpose: probe power resonant pair mapping" write (u, "(A)") allocate (sf_ipr_mapping_t :: mapping) select type (mapping) type is (sf_ipr_mapping_t) call mapping%init (eps = 0.1_default, m = 0.5_default, w = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] pb= [0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9,0.5):" p = [0.9_default, 0.5_default] pb= [0.1_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] pb= [0.3_default, 0.8_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.8):" p = [0.7_default, 0.8_default] pb= [0.3_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9999,0.02):" p = [0.9999_default, 0.02_default] pb= [0.0001_default, 0.98_default] call mapping%check (u, p, pb, FMT_11, FMT_12) write (u, *) write (u, "(A)") "Probe at (0.9999,0.98):" p = [0.9999_default, 0.98_default] pb= [0.0001_default, 0.02_default] call mapping%check (u, p, pb, FMT_11, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Same mapping without resonance:" write (u, "(A)") allocate (sf_ipr_mapping_t :: mapping) select type (mapping) type is (sf_ipr_mapping_t) call mapping%init (eps = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] pb= [0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9,0.5):" p = [0.9_default, 0.5_default] pb= [0.1_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] pb= [0.3_default, 0.8_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.8):" p = [0.7_default, 0.8_default] pb= [0.3_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_9" end subroutine sf_mappings_9 @ %def sf_mappings_9 @ \subsubsection{Check on-shell power mapping} Probe the power mapping of the unit square, adapted for single-particle production, for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_10, "sf_mappings_10", & "power on-shell mapping", & u, results) <>= public :: sf_mappings_10 <>= subroutine sf_mappings_10 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p, pb write (u, "(A)") "* Test output: sf_mappings_10" write (u, "(A)") "* Purpose: probe power on-shell mapping" write (u, "(A)") allocate (sf_ipo_mapping_t :: mapping) select type (mapping) type is (sf_ipo_mapping_t) call mapping%init (eps = 0.1_default, m = 0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0,0.02):" p = [0._default, 0.02_default] pb= [1._default, 0.98_default] call mapping%check (u, p, pb, FMT_15, FMT_12) write (u, *) write (u, "(A)") "Probe at (0,0.98):" p = [0._default, 0.98_default] pb= [1._default, 0.02_default] call mapping%check (u, p, pb, FMT_15, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_10" end subroutine sf_mappings_10 @ %def sf_mappings_10 @ \subsubsection{Check combined endpoint-power mapping} Probe the mapping for the beamstrahlung/ISR combination. <>= call test (sf_mappings_11, "sf_mappings_11", & "endpoint/power combined mapping", & u, results) <>= public :: sf_mappings_11 <>= subroutine sf_mappings_11 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(4) :: p, pb write (u, "(A)") "* Test output: sf_mappings_11" write (u, "(A)") "* Purpose: probe power pair mapping" write (u, "(A)") allocate (sf_ei_mapping_t :: mapping) select type (mapping) type is (sf_ei_mapping_t) call mapping%init (eps = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) call mapping%set_index (3, 3) call mapping%set_index (4, 4) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):" p = [0.5_default, 0.5_default, 0.5_default, 0.5_default] pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):" p = [0.7_default, 0.2_default, 0.4_default, 0.8_default] pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):" p = [0.9_default, 0.06_default, 0.95_default, 0.1_default] pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default] call mapping%check (u, p, pb, FMT_13, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_11" end subroutine sf_mappings_11 @ %def sf_mappings_11 @ \subsubsection{Check resonant endpoint-power mapping} Probe the mapping for the beamstrahlung/ISR combination. <>= call test (sf_mappings_12, "sf_mappings_12", & "endpoint/power resonant combined mapping", & u, results) <>= public :: sf_mappings_12 <>= subroutine sf_mappings_12 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(4) :: p, pb write (u, "(A)") "* Test output: sf_mappings_12" write (u, "(A)") "* Purpose: probe resonant combined mapping" write (u, "(A)") allocate (sf_eir_mapping_t :: mapping) select type (mapping) type is (sf_eir_mapping_t) call mapping%init (a = 1._default, & eps = 0.1_default, m = 0.5_default, w = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) call mapping%set_index (3, 3) call mapping%set_index (4, 4) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):" p = [0.5_default, 0.5_default, 0.5_default, 0.5_default] pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):" p = [0.7_default, 0.2_default, 0.4_default, 0.8_default] pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):" p = [0.9_default, 0.06_default, 0.95_default, 0.1_default] pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default] call mapping%check (u, p, pb, FMT_15, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_12" end subroutine sf_mappings_12 @ %def sf_mappings_12 @ \subsubsection{Check on-shell endpoint-power mapping} Probe the mapping for the beamstrahlung/ISR combination. <>= call test (sf_mappings_13, "sf_mappings_13", & "endpoint/power on-shell combined mapping", & u, results) <>= public :: sf_mappings_13 <>= subroutine sf_mappings_13 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(4) :: p, pb write (u, "(A)") "* Test output: sf_mappings_13" write (u, "(A)") "* Purpose: probe on-shell combined mapping" write (u, "(A)") allocate (sf_eio_mapping_t :: mapping) select type (mapping) type is (sf_eio_mapping_t) call mapping%init (a = 1._default, eps = 0.1_default, m = 0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) call mapping%set_index (3, 3) call mapping%set_index (4, 4) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):" p = [0.5_default, 0.5_default, 0.5_default, 0.5_default] pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):" p = [0.7_default, 0.2_default, 0.4_default, 0.8_default] pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):" p = [0.9_default, 0.06_default, 0.95_default, 0.1_default] pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default] call mapping%check (u, p, pb, FMT_14, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_13" end subroutine sf_mappings_13 @ %def sf_mappings_13 @ \subsubsection{Check rescaling} Check the rescaling factor in on-shell basic mapping. <>= call test (sf_mappings_14, "sf_mappings_14", & "rescaled on-shell mapping", & u, results) <>= public :: sf_mappings_14 <>= subroutine sf_mappings_14 (u) integer, intent(in) :: u real(default), dimension(2) :: p2, r2 real(default), dimension(1) :: p1, r1 real(default) :: f, x_free, m2 write (u, "(A)") "* Test output: sf_mappings_14" write (u, "(A)") "* Purpose: probe rescaling in os mapping" write (u, "(A)") x_free = 0.9_default m2 = 0.5_default write (u, "(A)") "* Two parameters" write (u, "(A)") p2 = [0.1_default, 0.2_default] call map_on_shell (r2, f, p2, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p2 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r2 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r2) write (u, *) call map_on_shell_inverse (r2, f, p2, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p2 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r2 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r2) write (u, "(A)") write (u, "(A)") "* One parameter" write (u, "(A)") p1 = [0.1_default] call map_on_shell_single (r1, f, p1, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p1 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r1 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r1) write (u, *) call map_on_shell_single_inverse (r1, f, p1, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p1 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r1 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r1) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_14" end subroutine sf_mappings_14 @ %def sf_mappings_14 @ \subsubsection{Check single parameter resonance mapping} Probe the resonance mapping of the unit interval for different parameter values. Also calculates integrals. The resonance mass is at $1/2$ the energy, the width is $1/10$. <>= call test (sf_mappings_15, "sf_mappings_15", & "resonant single mapping", & u, results) <>= public :: sf_mappings_15 <>= subroutine sf_mappings_15 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(1) :: p write (u, "(A)") "* Test output: sf_mappings_15" write (u, "(A)") "* Purpose: probe resonance single mapping" write (u, "(A)") allocate (sf_res_mapping_single_t :: mapping) select type (mapping) type is (sf_res_mapping_single_t) call mapping%init (0.5_default, 0.1_default) call mapping%set_index (1, 1) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0):" p = [0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5):" p = [0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1):" p = [0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_15" end subroutine sf_mappings_15 @ %def sf_mappings_15 @ \subsubsection{Check single parameter on-shell mapping} Probe the on-shell (pseudo) mapping of the unit interval for different parameter values. Also calculates integrals. The resonance mass is at $1/2$ the energy. <>= call test (sf_mappings_16, "sf_mappings_16", & "on-shell single mapping", & u, results) <>= public :: sf_mappings_16 <>= subroutine sf_mappings_16 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(1) :: p write (u, "(A)") "* Test output: sf_mappings_16" write (u, "(A)") "* Purpose: probe on-shell single mapping" write (u, "(A)") allocate (sf_os_mapping_single_t :: mapping) select type (mapping) type is (sf_os_mapping_single_t) call mapping%init (0.5_default) call mapping%set_index (1, 1) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0):" p = [0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5):" p = [0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_16" end subroutine sf_mappings_16 @ %def sf_mappings_16 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Structure function base} <<[[sf_base.f90]]>>= <> module sf_base <> <> use io_units use format_utils, only: write_separator use format_defs, only: FMT_17, FMT_19 use physics_defs, only: n_beam_structure_int use diagnostics use lorentz use quantum_numbers use interactions use evaluators use pdg_arrays use beams use sf_aux use sf_mappings <> <> <> <> <> contains <> end module sf_base @ %def sf_base @ \subsection{Abstract rescale data-type} NLO calculations involve treatment of initial state parton radiation. The radiation of a parton rescale the energy fraction which enters the hard process. We allow for different rescale settings by extending the abstract [[sf_rescale_t]] data type. <>= public :: sf_rescale_t <>= type, abstract :: sf_rescale_t integer :: i_restricted_beam = -1 integer :: i_beam = 0 logical :: gluon = .false. contains <> end type sf_rescale_t @ %def sf_rescale_t @ <>= procedure (sf_rescale_apply), deferred :: apply <>= abstract interface subroutine sf_rescale_apply (func, x) import class(sf_rescale_t), intent(in) :: func real(default), intent(inout) :: x end subroutine sf_rescale_apply end interface @ %def rescale_apply @ <>= procedure :: set_i_beam => sf_rescale_set_i_beam <>= subroutine sf_rescale_set_i_beam (func, i_beam) class(sf_rescale_t), intent(inout) :: func integer, intent(in) :: i_beam func%i_beam = i_beam end subroutine sf_rescale_set_i_beam @ %def rescale_set_i_beam @ Restrict rescaling to beam with index [[i_beam]]. <>= procedure :: restrict_to_beam => sf_rescale_restrict_to_beam <>= subroutine sf_rescale_restrict_to_beam (func, i_beam) class(sf_rescale_t), intent(inout) :: func integer, intent(in) :: i_beam if (func%i_restricted_beam > 0) & call msg_bug ("[sf_rescale_restrict_to_beam] restricted beam already set.") func%i_restricted_beam = i_beam end subroutine sf_rescale_restrict_to_beam @ %def sf_rescale_set_rescaled_beam @ Test on restricted beam momentum rescaling or no restriction. <>= procedure :: is_restricted => sf_rescale_is_restricted <>= logical function sf_rescale_is_restricted (func, i_beam) result (yorn) class(sf_rescale_t), intent(in) :: func integer, intent(in) :: i_beam yorn = (func%i_restricted_beam > 0) yorn = yorn .and. (func%i_restricted_beam /= i_beam) end function sf_rescale_is_restricted @ %def sf_rescale_is_restricted @ In case, gluon splits into quark/anti-quark, the DGLAP formulas become degenerate over flavours. We add subtraction with gluonic pdfs only which are convoluted with all quark/anti-quark flavours - hence PDF singlet. <>= procedure :: set_gluons => sf_rescale_set_gluons procedure :: has_gluons => sf_rescale_has_gluons <>= subroutine sf_rescale_set_gluons (func, yorn) class(sf_rescale_t), intent(inout) :: func logical, intent(in) :: yorn func%gluon = yorn end subroutine sf_rescale_set_gluons logical function sf_rescale_has_gluons (func) result (yorn) class(sf_rescale_t), intent(in) :: func yorn = func%gluon end function sf_rescale_has_gluons @ %def sf_rescale_set_gluons rescale_has_gluons @ \subsection{Abstract structure-function data type} This type should hold all configuration data for a specific type of structure function. The base object is empty; the implementations will fill it. <>= public :: sf_data_t <>= type, abstract :: sf_data_t contains <> end type sf_data_t @ %def sf_data_t @ Output. <>= procedure (sf_data_write), deferred :: write <>= abstract interface subroutine sf_data_write (data, unit, verbose) import class(sf_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine sf_data_write end interface @ %def sf_data_write @ Return true if this structure function is in generator mode. In that case, all parameters are free, otherwise bound. (We do not support mixed cases.) Default is: no generator. <>= procedure :: is_generator => sf_data_is_generator <>= function sf_data_is_generator (data) result (flag) class(sf_data_t), intent(in) :: data logical :: flag flag = .false. end function sf_data_is_generator @ %def sf_data_is_generator @ Return the number of input parameters that determine the structure function. <>= procedure (sf_data_get_int), deferred :: get_n_par <>= abstract interface function sf_data_get_int (data) result (n) import class(sf_data_t), intent(in) :: data integer :: n end function sf_data_get_int end interface @ %def sf_data_get_int @ Return the outgoing particle PDG codes for the current setup. The codes can be an array of particles, for each beam. <>= procedure (sf_data_get_pdg_out), deferred :: get_pdg_out <>= abstract interface subroutine sf_data_get_pdg_out (data, pdg_out) import class(sf_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out end subroutine sf_data_get_pdg_out end interface @ %def sf_data_get_pdg_out @ Allocate a matching structure function interaction object and properly initialize it. <>= procedure (sf_data_allocate_sf_int), deferred :: allocate_sf_int <>= abstract interface subroutine sf_data_allocate_sf_int (data, sf_int) import class(sf_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int end subroutine sf_data_allocate_sf_int end interface @ %def sf_data_allocate_sf_int @ Return the PDF set index, if applicable. We implement a default method which returns zero. The PDF (builtin and LHA) implementations will override this. <>= procedure :: get_pdf_set => sf_data_get_pdf_set <>= elemental function sf_data_get_pdf_set (data) result (pdf_set) class(sf_data_t), intent(in) :: data integer :: pdf_set pdf_set = 0 end function sf_data_get_pdf_set @ %def sf_data_get_pdf_set @ Return the spectrum file, if applicable. We implement a default method which returns zero. CIRCE1, CIRCE2 and the beam spectrum will override this. <>= procedure :: get_beam_file => sf_data_get_beam_file <>= function sf_data_get_beam_file (data) result (file) class(sf_data_t), intent(in) :: data type(string_t) :: file file = "" end function sf_data_get_beam_file @ %def sf_data_get_beam_file @ \subsection{Structure-function chain configuration} This is the data type that the [[process]] module uses for setting up its structure-function chain. For each structure function described by the beam data, there is an entry. The [[i]] array indicates the beam(s) to which this structure function applies, and the [[data]] object contains the actual configuration data. <>= public :: sf_config_t <>= type :: sf_config_t integer, dimension(:), allocatable :: i class(sf_data_t), allocatable :: data contains <> end type sf_config_t @ %def sf_config_t @ Output: <>= procedure :: write => sf_config_write <>= subroutine sf_config_write (object, unit) class(sf_config_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (allocated (object%i)) then write (u, "(1x,A,2(1x,I0))") "Structure-function configuration: & &beam(s)", object%i if (allocated (object%data)) call object%data%write (u) else write (u, "(1x,A)") "Structure-function configuration: [undefined]" end if end subroutine sf_config_write @ %def sf_config_write @ Initialize. <>= procedure :: init => sf_config_init <>= subroutine sf_config_init (sf_config, i_beam, sf_data) class(sf_config_t), intent(out) :: sf_config integer, dimension(:), intent(in) :: i_beam class(sf_data_t), intent(in) :: sf_data allocate (sf_config%i (size (i_beam)), source = i_beam) allocate (sf_config%data, source = sf_data) end subroutine sf_config_init @ %def sf_config_init @ Return the PDF set, if any. <>= procedure :: get_pdf_set => sf_config_get_pdf_set <>= elemental function sf_config_get_pdf_set (sf_config) result (pdf_set) class(sf_config_t), intent(in) :: sf_config integer :: pdf_set pdf_set = sf_config%data%get_pdf_set () end function sf_config_get_pdf_set @ %def sf_config_get_pdf_set @ Return the beam spectrum file, if any. <>= procedure :: get_beam_file => sf_config_get_beam_file <>= function sf_config_get_beam_file (sf_config) result (file) class(sf_config_t), intent(in) :: sf_config type(string_t) :: file file = sf_config%data%get_beam_file () end function sf_config_get_beam_file @ %def sf_config_get_beam_file @ \subsection{Structure-function instance} The [[sf_int_t]] data type contains an [[interaction_t]] object (it is an extension of this type) and a pointer to the [[sf_data_t]] configuration data. This interaction, or copies of it, is used to implement structure-function kinematics and dynamics in the context of process evaluation. The status code [[status]] tells whether the interaction is undefined, has defined kinematics (but matrix elements invalid), or is completely defined. There is also a status code for failure. The implementation is responsible for updating the status. The entries [[mi2]], [[mr2]], and [[mo2]] hold the squared invariant masses of the incoming, radiated, and outgoing particle, respectively. They are supposed to be set upon initialization, but could also be varied event by event. If the radiated or outgoing mass is nonzero, we may need to apply an on-shell projection. The projection mode is stored as [[on_shell_mode]]. The array [[beam_index]] is the list of beams on which this structure function applies ($1$, $2$, or both). The arrays [[incoming]], [[radiated]], and [[outgoing]] contain the indices of the respective particle sets within the interaction, for convenient lookup. The array [[par_index]] indicates the MC input parameters that this entry will use up in the structure-function chain. The first parameter (or the first two, for a spectrum) in this array determines the momentum fraction and is thus subject to global mappings. In the abstract base type, we do not implement the data pointer. This allows us to restrict its type in the implementations. <>= public :: sf_int_t <>= type, abstract, extends (interaction_t) :: sf_int_t integer :: status = SF_UNDEFINED real(default), dimension(:), allocatable :: mi2 real(default), dimension(:), allocatable :: mr2 real(default), dimension(:), allocatable :: mo2 integer :: on_shell_mode = KEEP_ENERGY logical :: qmin_defined = .false. logical :: qmax_defined = .false. real(default), dimension(:), allocatable :: qmin real(default), dimension(:), allocatable :: qmax integer, dimension(:), allocatable :: beam_index integer, dimension(:), allocatable :: incoming integer, dimension(:), allocatable :: radiated integer, dimension(:), allocatable :: outgoing integer, dimension(:), allocatable :: par_index integer, dimension(:), allocatable :: par_primary contains <> end type sf_int_t @ %def sf_int_t @ Status codes. The codes that refer to links, masks, and connections, apply to structure-function chains only. The status codes are public. <>= integer, parameter, public :: SF_UNDEFINED = 0 integer, parameter, public :: SF_INITIAL = 1 integer, parameter, public :: SF_DONE_LINKS = 2 integer, parameter, public :: SF_FAILED_MASK = 3 integer, parameter, public :: SF_DONE_MASK = 4 integer, parameter, public :: SF_FAILED_CONNECTIONS = 5 integer, parameter, public :: SF_DONE_CONNECTIONS = 6 integer, parameter, public :: SF_SEED_KINEMATICS = 10 integer, parameter, public :: SF_FAILED_KINEMATICS = 11 integer, parameter, public :: SF_DONE_KINEMATICS = 12 integer, parameter, public :: SF_FAILED_EVALUATION = 13 integer, parameter, public :: SF_EVALUATED = 20 @ %def SF_UNDEFINED SF_INITIAL @ %def SF_DONE_LINKS SF_DONE_MASK SF_DONE_CONNECTIONS @ %def SF_DONE_KINEMATICS SF_EVALUATED @ %def SF_FAILED_MASK SF_FAILED_CONNECTIONS @ %def SF_FAILED_KINEMATICS SF_FAILED_EVALUATION @ Write a string version of the status code: <>= subroutine write_sf_status (status, u) integer, intent(in) :: status integer, intent(in) :: u select case (status) case (SF_UNDEFINED) write (u, "(1x,'[',A,']')") "undefined" case (SF_INITIAL) write (u, "(1x,'[',A,']')") "initialized" case (SF_DONE_LINKS) write (u, "(1x,'[',A,']')") "links set" case (SF_FAILED_MASK) write (u, "(1x,'[',A,']')") "mask mismatch" case (SF_DONE_MASK) write (u, "(1x,'[',A,']')") "mask set" case (SF_FAILED_CONNECTIONS) write (u, "(1x,'[',A,']')") "connections failed" case (SF_DONE_CONNECTIONS) write (u, "(1x,'[',A,']')") "connections set" case (SF_SEED_KINEMATICS) write (u, "(1x,'[',A,']')") "incoming momenta set" case (SF_FAILED_KINEMATICS) write (u, "(1x,'[',A,']')") "kinematics failed" case (SF_DONE_KINEMATICS) write (u, "(1x,'[',A,']')") "kinematics set" case (SF_FAILED_EVALUATION) write (u, "(1x,'[',A,']')") "evaluation failed" case (SF_EVALUATED) write (u, "(1x,'[',A,']')") "evaluated" end select end subroutine write_sf_status @ %def write_sf_status @ This is the basic output routine. Display status and interaction. <>= procedure :: base_write => sf_int_base_write <>= subroutine sf_int_base_write (object, unit, testflag) class(sf_int_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "SF instance:" call write_sf_status (object%status, u) if (allocated (object%beam_index)) & write (u, "(3x,A,2(1x,I0))") "beam =", object%beam_index if (allocated (object%incoming)) & write (u, "(3x,A,2(1x,I0))") "incoming =", object%incoming if (allocated (object%radiated)) & write (u, "(3x,A,2(1x,I0))") "radiated =", object%radiated if (allocated (object%outgoing)) & write (u, "(3x,A,2(1x,I0))") "outgoing =", object%outgoing if (allocated (object%par_index)) & write (u, "(3x,A,2(1x,I0))") "parameter =", object%par_index if (object%qmin_defined) & write (u, "(3x,A,1x," // FMT_19 // ")") "q_min =", object%qmin if (object%qmax_defined) & write (u, "(3x,A,1x," // FMT_19 // ")") "q_max =", object%qmax call object%interaction_t%basic_write (u, testflag = testflag) end subroutine sf_int_base_write @ %def sf_int_base_write @ The type string identifies the structure function class, and possibly more details about the structure function. <>= procedure (sf_int_type_string), deferred :: type_string <>= abstract interface function sf_int_type_string (object) result (string) import class(sf_int_t), intent(in) :: object type(string_t) :: string end function sf_int_type_string end interface @ %def sf_int_type_string @ Output of the concrete object. We should not forget to call the output routine for the base type. <>= procedure (sf_int_write), deferred :: write <>= abstract interface subroutine sf_int_write (object, unit, testflag) import class(sf_int_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine sf_int_write end interface @ %def sf_int_write @ Basic initialization: set the invariant masses for the particles and initialize the interaction. The caller should then add states to the interaction and freeze it. The dimension of the mask should be equal to the sum of the dimensions of the mass-squared arrays, which determine incoming, radiated, and outgoing particles, respectively. Optionally, we can define minimum and maximum values for the momentum transfer to the outgoing particle(s). If all masses are zero, this is actually required for non-collinear splitting. <>= procedure :: base_init => sf_int_base_init <>= subroutine sf_int_base_init & (sf_int, mask, mi2, mr2, mo2, qmin, qmax, hel_lock) class(sf_int_t), intent(out) :: sf_int type (quantum_numbers_mask_t), dimension(:), intent(in) :: mask real(default), dimension(:), intent(in) :: mi2, mr2, mo2 real(default), dimension(:), intent(in), optional :: qmin, qmax integer, dimension(:), intent(in), optional :: hel_lock allocate (sf_int%mi2 (size (mi2))) sf_int%mi2 = mi2 allocate (sf_int%mr2 (size (mr2))) sf_int%mr2 = mr2 allocate (sf_int%mo2 (size (mo2))) sf_int%mo2 = mo2 if (present (qmin)) then sf_int%qmin_defined = .true. allocate (sf_int%qmin (size (qmin))) sf_int%qmin = qmin end if if (present (qmax)) then sf_int%qmax_defined = .true. allocate (sf_int%qmax (size (qmax))) sf_int%qmax = qmax end if call sf_int%interaction_t%basic_init & (size (mi2), 0, size (mr2) + size (mo2), & mask = mask, hel_lock = hel_lock, set_relations = .true.) end subroutine sf_int_base_init @ %def sf_int_base_init @ Set the indices of the incoming, radiated, and outgoing particles, respectively. <>= procedure :: set_incoming => sf_int_set_incoming procedure :: set_radiated => sf_int_set_radiated procedure :: set_outgoing => sf_int_set_outgoing <>= subroutine sf_int_set_incoming (sf_int, incoming) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: incoming allocate (sf_int%incoming (size (incoming))) sf_int%incoming = incoming end subroutine sf_int_set_incoming subroutine sf_int_set_radiated (sf_int, radiated) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: radiated allocate (sf_int%radiated (size (radiated))) sf_int%radiated = radiated end subroutine sf_int_set_radiated subroutine sf_int_set_outgoing (sf_int, outgoing) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: outgoing allocate (sf_int%outgoing (size (outgoing))) sf_int%outgoing = outgoing end subroutine sf_int_set_outgoing @ %def sf_int_set_incoming @ %def sf_int_set_radiated @ %def sf_int_set_outgoing @ Initialization. This proceeds via an abstract data object, which for the actual implementation should have the matching concrete type. Since all implementations have the same signature, we can prepare a deferred procedure. The data object will become the target of a corresponding pointer within the [[sf_int_t]] implementation. This should call the previous procedure. <>= procedure (sf_int_init), deferred :: init <>= abstract interface subroutine sf_int_init (sf_int, data) import class(sf_int_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data end subroutine sf_int_init end interface @ %def sf_int_init @ Complete initialization. This routine contains initializations that can only be performed after the interaction object got its final shape, i.e., redundant helicities have been eliminated by matching with beams and process. The default implementation does nothing. The [[target]] attribute is formally required since some overriding implementations use a temporary pointer (iterator) to the state-matrix component. It doesn't appear to make a real difference, though. <>= procedure :: setup_constants => sf_int_setup_constants <>= subroutine sf_int_setup_constants (sf_int) class(sf_int_t), intent(inout), target :: sf_int end subroutine sf_int_setup_constants @ %def sf_int_setup_constants @ Set beam indices, i.e., the beam(s) on which this structure function applies. <>= procedure :: set_beam_index => sf_int_set_beam_index <>= subroutine sf_int_set_beam_index (sf_int, beam_index) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: beam_index allocate (sf_int%beam_index (size (beam_index))) sf_int%beam_index = beam_index end subroutine sf_int_set_beam_index @ %def sf_int_set_beam_index @ Set parameter indices, indicating which MC input parameters are to be used for evaluating this structure function. <>= procedure :: set_par_index => sf_int_set_par_index <>= subroutine sf_int_set_par_index (sf_int, par_index) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: par_index allocate (sf_int%par_index (size (par_index))) sf_int%par_index = par_index end subroutine sf_int_set_par_index @ %def sf_int_set_par_index @ Initialize the structure-function kinematics, setting incoming momenta. We assume that array shapes match. Three versions. The first version relies on the momenta being linked to another interaction. The second version sets the momenta explicitly. In the third version, we first compute momenta for the specified energies and store those. <>= generic :: seed_kinematics => sf_int_receive_momenta generic :: seed_kinematics => sf_int_seed_momenta generic :: seed_kinematics => sf_int_seed_energies procedure :: sf_int_receive_momenta procedure :: sf_int_seed_momenta procedure :: sf_int_seed_energies <>= subroutine sf_int_receive_momenta (sf_int) class(sf_int_t), intent(inout) :: sf_int if (sf_int%status >= SF_INITIAL) then call sf_int%receive_momenta () sf_int%status = SF_SEED_KINEMATICS end if end subroutine sf_int_receive_momenta subroutine sf_int_seed_momenta (sf_int, k) class(sf_int_t), intent(inout) :: sf_int type(vector4_t), dimension(:), intent(in) :: k if (sf_int%status >= SF_INITIAL) then call sf_int%set_momenta (k, outgoing=.false.) sf_int%status = SF_SEED_KINEMATICS end if end subroutine sf_int_seed_momenta subroutine sf_int_seed_energies (sf_int, E) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: E type(vector4_t), dimension(:), allocatable :: k integer :: j if (sf_int%status >= SF_INITIAL) then allocate (k (size (E))) if (all (E**2 >= sf_int%mi2)) then do j = 1, size (E) k(j) = vector4_moving (E(j), & (3-2*j) * sqrt (E(j)**2 - sf_int%mi2(j)), 3) end do call sf_int%seed_kinematics (k) end if end if end subroutine sf_int_seed_energies @ %def sf_int_seed_momenta @ %def sf_int_seed_energies @ Tell if in generator mode. By default, this is false. To be overridden where appropriate; we may refer to the [[is_generator]] method of the [[data]] component in the concrete type. <>= procedure :: is_generator => sf_int_is_generator <>= function sf_int_is_generator (sf_int) result (flag) class(sf_int_t), intent(in) :: sf_int logical :: flag flag = .false. end function sf_int_is_generator @ %def sf_int_is_generator @ Generate free parameters [[r]]. Parameters are free if they do not correspond to integration parameters (i.e., are bound), but are generated by the structure function object itself. By default, all parameters are bound, and the output values of this procedure will be discarded. With free parameters, we have to override this procedure. The value [[x_free]] is the renormalization factor of the total energy that corresponds to the free parameters. If there are no free parameters, the procedure will not change its value, which starts as unity. Otherwise, the fraction is typically decreased, but may also be increased in some cases. <>= procedure :: generate_free => sf_int_generate_free <>= subroutine sf_int_generate_free (sf_int, r, rb, x_free) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free r = 0 rb= 1 end subroutine sf_int_generate_free @ %def sf_int_generate_free @ Complete the structure-function kinematics, derived from an input parameter (array) $r$ between 0 and 1. The interaction momenta are calculated, and we return $x$ (the momentum fraction), and $f$ (the Jacobian factor for the map $r\to x$), if [[map]] is set. If the [[map]] flag is unset, $r$ and $x$ values will coincide, and $f$ will become unity. If it is set, the structure-function implementation chooses a convenient mapping from $r$ to $x$ with Jacobian $f$. In the [[inverse_kinematics]] variant, we exchange the intent of [[x]] and [[r]]. The momenta are calculated only if the optional flag [[set_momenta]] is present and set. Internal parameters of [[sf_int]] are calculated only if the optional flag [[set_x]] is present and set. Update 2018-08-22: Throughout this algorithm, we now carry [[xb]]=$1-x$ together with [[x]] values, as we did for [[r]] before. This allows us to handle unstable endpoint numerics wherever necessary. The only place where the changes actually did matter was for inverse kinematics in the ISR setup, with a very soft photon, but it might be most sensible to apply the extension with [[xb]] everywhere. <>= procedure (sf_int_complete_kinematics), deferred :: complete_kinematics procedure (sf_int_inverse_kinematics), deferred :: inverse_kinematics <>= abstract interface subroutine sf_int_complete_kinematics (sf_int, x, xb, f, r, rb, map) import class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map end subroutine sf_int_complete_kinematics end interface abstract interface subroutine sf_int_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) import class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta end subroutine sf_int_inverse_kinematics end interface @ %def sf_int_complete_kinematics @ %def sf_int_inverse_kinematics @ Single splitting: compute momenta, given $x$ input parameters. We assume that the incoming momentum is set. The status code is set to [[SF_FAILED_KINEMATICS]] if the $x$ array does not correspond to a valid momentum configuration. Otherwise, it is updated to [[SF_DONE_KINEMATICS]]. We force the outgoing particle on-shell. The on-shell projection is determined by the [[on_shell_mode]]. The radiated particle should already be on shell. <>= procedure :: split_momentum => sf_int_split_momentum <>= subroutine sf_int_split_momentum (sf_int, x, xb) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb type(vector4_t) :: k type(vector4_t), dimension(2) :: q type(splitting_data_t) :: sd real(default) :: E1, E2 logical :: fail if (sf_int%status >= SF_SEED_KINEMATICS) then k = sf_int%get_momentum (1) call sd%init (k, & sf_int%mi2(1), sf_int%mr2(1), sf_int%mo2(1), & collinear = size (x) == 1) call sd%set_t_bounds (x(1), xb(1)) select case (size (x)) case (1) case (3) if (sf_int%qmax_defined) then if (sf_int%qmin_defined) then call sd%sample_t (x(2), & t0 = - sf_int%qmax(1) ** 2, t1 = - sf_int%qmin(1) ** 2) else call sd%sample_t (x(2), & t0 = - sf_int%qmax(1) ** 2) end if else if (sf_int%qmin_defined) then call sd%sample_t (x(2), t1 = - sf_int%qmin(1) ** 2) else call sd%sample_t (x(2)) end if end if call sd%sample_phi (x(3)) case default call msg_bug ("Structure function: impossible number of parameters") end select q = sd%split_momentum (k) call on_shell (q, [sf_int%mr2, sf_int%mo2], & sf_int%on_shell_mode) call sf_int%set_momenta (q, outgoing=.true.) E1 = energy (q(1)) E2 = energy (q(2)) fail = E1 < 0 .or. E2 < 0 & .or. E1 ** 2 < sf_int%mr2(1) & .or. E2 ** 2 < sf_int%mo2(1) if (fail) then sf_int%status = SF_FAILED_KINEMATICS else sf_int%status = SF_DONE_KINEMATICS end if end if end subroutine sf_int_split_momentum @ %def sf_test_split_momentum @ Pair splitting: two incoming momenta, two radiated, two outgoing. This is simple because we insist on all momenta being collinear. <>= procedure :: split_momenta => sf_int_split_momenta <>= subroutine sf_int_split_momenta (sf_int, x, xb) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb type(vector4_t), dimension(2) :: k type(vector4_t), dimension(4) :: q real(default), dimension(4) :: E logical :: fail if (sf_int%status >= SF_SEED_KINEMATICS) then select case (size (x)) case (2) case default call msg_bug ("Pair structure function: recoil requested & &but not implemented yet") end select k(1) = sf_int%get_momentum (1) k(2) = sf_int%get_momentum (2) q(1:2) = xb * k q(3:4) = x * k select case (size (sf_int%mr2)) case (2) call on_shell (q, & [sf_int%mr2(1), sf_int%mr2(2), & sf_int%mo2(1), sf_int%mo2(2)], & sf_int%on_shell_mode) call sf_int%set_momenta (q, outgoing=.true.) E = energy (q) fail = any (E < 0) & .or. any (E(1:2) ** 2 < sf_int%mr2) & .or. any (E(3:4) ** 2 < sf_int%mo2) case default; call msg_bug ("split momenta: incorrect use") end select if (fail) then sf_int%status = SF_FAILED_KINEMATICS else sf_int%status = SF_DONE_KINEMATICS end if end if end subroutine sf_int_split_momenta @ %def sf_int_split_momenta @ Pair spectrum: the reduced version of the previous splitting, without radiated momenta. <>= procedure :: reduce_momenta => sf_int_reduce_momenta <>= subroutine sf_int_reduce_momenta (sf_int, x) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q real(default), dimension(2) :: E logical :: fail if (sf_int%status >= SF_SEED_KINEMATICS) then select case (size (x)) case (2) case default call msg_bug ("Pair spectrum: recoil requested & &but not implemented yet") end select k(1) = sf_int%get_momentum (1) k(2) = sf_int%get_momentum (2) q = x * k call on_shell (q, & [sf_int%mo2(1), sf_int%mo2(2)], & sf_int%on_shell_mode) call sf_int%set_momenta (q, outgoing=.true.) E = energy (q) fail = any (E < 0) & .or. any (E ** 2 < sf_int%mo2) if (fail) then sf_int%status = SF_FAILED_KINEMATICS else sf_int%status = SF_DONE_KINEMATICS end if end if end subroutine sf_int_reduce_momenta @ %def sf_int_reduce_momenta @ The inverse procedure: we compute the [[x]] array from the momentum configuration. In an overriding TBP, we may also set internal data that depend on this, for convenience. NOTE: Here and above, the single-particle case is treated in detail, allowing for non-collinearity and non-vanishing masses and nontrivial momentum-transfer bounds. For the pair case, we currently implement only collinear splitting and assume massless particles. This should be improved. Update 2017-08-22: recover also [[xb]], using the updated [[recover]] method of the splitting-data object. Th <>= procedure :: recover_x => sf_int_recover_x procedure :: base_recover_x => sf_int_recover_x <>= subroutine sf_int_recover_x (sf_int, x, xb, x_free) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free type(vector4_t), dimension(:), allocatable :: k type(vector4_t), dimension(:), allocatable :: q type(splitting_data_t) :: sd if (sf_int%status >= SF_SEED_KINEMATICS) then allocate (k (sf_int%interaction_t%get_n_in ())) allocate (q (sf_int%interaction_t%get_n_out ())) k = sf_int%get_momenta (outgoing=.false.) q = sf_int%get_momenta (outgoing=.true.) select case (size (k)) case (1) call sd%init (k(1), & sf_int%mi2(1), sf_int%mr2(1), sf_int%mo2(1), & collinear = size (x) == 1) call sd%recover (k(1), q, sf_int%on_shell_mode) x(1) = sd%get_x () xb(1) = sd%get_xb () select case (size (x)) case (1) case (3) if (sf_int%qmax_defined) then if (sf_int%qmin_defined) then call sd%inverse_t (x(2), & t0 = - sf_int%qmax(1) ** 2, t1 = - sf_int%qmin(1) ** 2) else call sd%inverse_t (x(2), & t0 = - sf_int%qmax(1) ** 2) end if else if (sf_int%qmin_defined) then call sd%inverse_t (x(2), t1 = - sf_int%qmin(1) ** 2) else call sd%inverse_t (x(2)) end if end if call sd%inverse_phi (x(3)) xb(2:3) = 1 - x(2:3) case default call msg_bug ("Structure function: impossible number & &of parameters") end select case (2) select case (size (x)) case (2) case default call msg_bug ("Pair structure function: recoil requested & &but not implemented yet") end select select case (sf_int%on_shell_mode) case (KEEP_ENERGY) select case (size (q)) case (4) x = energy (q(3:4)) / energy (k) xb= energy (q(1:2)) / energy (k) case (2) x = energy (q) / energy (k) xb= 1 - x end select case (KEEP_MOMENTUM) select case (size (q)) case (4) x = longitudinal_part (q(3:4)) / longitudinal_part (k) xb= longitudinal_part (q(1:2)) / longitudinal_part (k) case (2) x = longitudinal_part (q) / longitudinal_part (k) xb= 1 - x end select end select end select end if end subroutine sf_int_recover_x @ %def sf_int_recover_x @ Apply the structure function, i.e., evaluate the interaction. For the calculation, we may use the stored momenta, any further information stored inside the [[sf_int]] implementation during kinematics setup, and the given energy scale. It may happen that for the given kinematics the value is not defined. This should be indicated by the status code. <>= procedure (sf_int_apply), deferred :: apply <>= abstract interface subroutine sf_int_apply (sf_int, scale, rescale, i_sub, fill_sub) import class(sf_int_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub logical, intent(in), optional :: fill_sub end subroutine sf_int_apply end interface @ %def sf_int_apply @ \subsection{Accessing the structure function} Return metadata. Once [[interaction_t]] is rewritten in OO, some of this will be inherited. The number of outgoing is equal to the number of incoming particles. The radiated particles are the difference. <>= procedure :: get_n_in => sf_int_get_n_in procedure :: get_n_rad => sf_int_get_n_rad procedure :: get_n_out => sf_int_get_n_out <>= pure function sf_int_get_n_in (object) result (n_in) class(sf_int_t), intent(in) :: object integer :: n_in n_in = object%interaction_t%get_n_in () end function sf_int_get_n_in pure function sf_int_get_n_rad (object) result (n_rad) class(sf_int_t), intent(in) :: object integer :: n_rad n_rad = object%interaction_t%get_n_out () & - object%interaction_t%get_n_in () end function sf_int_get_n_rad pure function sf_int_get_n_out (object) result (n_out) class(sf_int_t), intent(in) :: object integer :: n_out n_out = object%interaction_t%get_n_in () end function sf_int_get_n_out @ %def sf_int_get_n_in @ %def sf_int_get_n_rad @ %def sf_int_get_n_out @ Number of matrix element entries in the interaction: <>= procedure :: get_n_states => sf_int_get_n_states <>= function sf_int_get_n_states (sf_int) result (n_states) class(sf_int_t), intent(in) :: sf_int integer :: n_states n_states = sf_int%get_n_matrix_elements () end function sf_int_get_n_states @ %def sf_int_get_n_states @ Return a specific state as a quantum-number array. <>= procedure :: get_state => sf_int_get_state <>= function sf_int_get_state (sf_int, i) result (qn) class(sf_int_t), intent(in) :: sf_int type(quantum_numbers_t), dimension(:), allocatable :: qn integer, intent(in) :: i allocate (qn (sf_int%get_n_tot ())) qn = sf_int%get_quantum_numbers (i) end function sf_int_get_state @ %def sf_int_get_state @ Return the matrix-element values for all states. We can assume that the matrix elements are real, so we take the real part. <>= procedure :: get_values => sf_int_get_values <>= subroutine sf_int_get_values (sf_int, value) class(sf_int_t), intent(in) :: sf_int real(default), dimension(:), intent(out) :: value integer :: i if (sf_int%status >= SF_EVALUATED) then do i = 1, size (value) value(i) = real (sf_int%get_matrix_element (i)) end do else value = 0 end if end subroutine sf_int_get_values @ %def sf_int_get_values @ \subsection{Direct calculations} Compute a structure function value (array) directly, given an array of $x$ values and a scale. If the energy is also given, we initialize the kinematics for that energy, otherwise take it from a previous run. We assume that the [[E]] array has dimension [[n_in]], and the [[x]] array has [[n_par]]. Note: the output x values ([[xx]] and [[xxb]]) are unused in this use case. <>= procedure :: compute_values => sf_int_compute_values <>= subroutine sf_int_compute_values (sf_int, value, x, xb, scale, E) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: value real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(in) :: scale real(default), dimension(:), intent(in), optional :: E real(default), dimension(size (x)) :: xx, xxb real(default) :: f if (present (E)) call sf_int%seed_kinematics (E) if (sf_int%status >= SF_SEED_KINEMATICS) then call sf_int%complete_kinematics (xx, xxb, f, x, xb, map=.false.) call sf_int%apply (scale) call sf_int%get_values (value) value = value * f else value = 0 end if end subroutine sf_int_compute_values @ %def sf_int_compute_values @ Compute just a single value for one of the states, i.e., throw the others away. <>= procedure :: compute_value => sf_int_compute_value <>= subroutine sf_int_compute_value & (sf_int, i_state, value, x, xb, scale, E) class(sf_int_t), intent(inout) :: sf_int integer, intent(in) :: i_state real(default), intent(out) :: value real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(in) :: scale real(default), dimension(:), intent(in), optional :: E real(default), dimension(:), allocatable :: value_array if (sf_int%status >= SF_INITIAL) then allocate (value_array (sf_int%get_n_states ())) call sf_int%compute_values (value_array, x, xb, scale, E) value = value_array(i_state) else value = 0 end if end subroutine sf_int_compute_value @ %def sf_int_compute_value @ \subsection{Structure-function instance} This is a wrapper for [[sf_int_t]] objects, such that we can build an array with different structure-function types. The structure-function contains an array (a sequence) of [[sf_int_t]] objects. The object, it holds the evaluator that connects the preceding part of the structure-function chain to the current interaction. It also stores the input and output parameter values for the contained structure function. The [[r]] array has a second dimension, corresponding to the mapping channels in a multi-channel configuration. There is a Jacobian entry [[f]] for each channel. The corresponding logical array [[mapping]] tells whether we apply the mapping appropriate for the current structure function in this channel. The [[x]] parameter values (energy fractions) are common to all channels. <>= type :: sf_instance_t class(sf_int_t), allocatable :: int type(evaluator_t) :: eval real(default), dimension(:,:), allocatable :: r real(default), dimension(:,:), allocatable :: rb real(default), dimension(:), allocatable :: f logical, dimension(:), allocatable :: m real(default), dimension(:), allocatable :: x real(default), dimension(:), allocatable :: xb end type sf_instance_t @ %def sf_instance_t @ \subsection{Structure-function chain} A chain is an array of structure functions [[sf]], initiated by a beam setup. We do not use this directly for evaluation, but create instances with copies of the contained interactions. [[n_par]] is the total number of parameters that is necessary for completely determining the structure-function chain. [[n_bound]] is the number of MC input parameters that are requested from the integrator. The difference of [[n_par]] and [[n_bound]] is the number of free parameters, which are generated by a structure-function object in generator mode. <>= public :: sf_chain_t <>= type, extends (beam_t) :: sf_chain_t type(beam_data_t), pointer :: beam_data => null () integer :: n_in = 0 integer :: n_strfun = 0 integer :: n_par = 0 integer :: n_bound = 0 type(sf_instance_t), dimension(:), allocatable :: sf logical :: trace_enable = .false. integer :: trace_unit = 0 contains <> end type sf_chain_t @ %def sf_chain_t @ Finalizer. <>= procedure :: final => sf_chain_final <>= subroutine sf_chain_final (object) class(sf_chain_t), intent(inout) :: object integer :: i call object%final_tracing () if (allocated (object%sf)) then do i = 1, size (object%sf, 1) associate (sf => object%sf(i)) if (allocated (sf%int)) then call sf%int%final () end if end associate end do end if call beam_final (object%beam_t) end subroutine sf_chain_final @ %def sf_chain_final @ Output. <>= procedure :: write => sf_chain_write <>= subroutine sf_chain_write (object, unit) class(sf_chain_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "Incoming particles / structure-function chain:" if (associated (object%beam_data)) then write (u, "(3x,A,I0)") "n_in = ", object%n_in write (u, "(3x,A,I0)") "n_strfun = ", object%n_strfun write (u, "(3x,A,I0)") "n_par = ", object%n_par if (object%n_par /= object%n_bound) then write (u, "(3x,A,I0)") "n_bound = ", object%n_bound end if call object%beam_data%write (u) call write_separator (u) call beam_write (object%beam_t, u) if (allocated (object%sf)) then do i = 1, object%n_strfun associate (sf => object%sf(i)) call write_separator (u) if (allocated (sf%int)) then call sf%int%write (u) else write (u, "(1x,A)") "SF instance: [undefined]" end if end associate end do end if else write (u, "(3x,A)") "[undefined]" end if end subroutine sf_chain_write @ %def sf_chain_write @ Initialize: setup beams. The [[beam_data]] target must remain valid for the lifetime of the chain, since we just establish a pointer. The structure-function configuration array is used to initialize the individual structure-function entries. The target attribute is needed because the [[sf_int]] entries establish pointers to the configuration data. <>= procedure :: init => sf_chain_init <>= subroutine sf_chain_init (sf_chain, beam_data, sf_config) class(sf_chain_t), intent(out) :: sf_chain type(beam_data_t), intent(in), target :: beam_data type(sf_config_t), dimension(:), intent(in), optional, target :: sf_config integer :: i sf_chain%beam_data => beam_data sf_chain%n_in = beam_data%get_n_in () call beam_init (sf_chain%beam_t, beam_data) if (present (sf_config)) then sf_chain%n_strfun = size (sf_config) allocate (sf_chain%sf (sf_chain%n_strfun)) do i = 1, sf_chain%n_strfun call sf_chain%set_strfun (i, sf_config(i)%i, sf_config(i)%data) end do end if end subroutine sf_chain_init @ %def sf_chain_init @ Receive the beam momenta from a source to which the beam interaction is linked. <>= procedure :: receive_beam_momenta => sf_chain_receive_beam_momenta <>= subroutine sf_chain_receive_beam_momenta (sf_chain) class(sf_chain_t), intent(inout), target :: sf_chain type(interaction_t), pointer :: beam_int beam_int => sf_chain%get_beam_int_ptr () call beam_int%receive_momenta () end subroutine sf_chain_receive_beam_momenta @ %def sf_chain_receive_beam_momenta @ Explicitly set the beam momenta. <>= procedure :: set_beam_momenta => sf_chain_set_beam_momenta <>= subroutine sf_chain_set_beam_momenta (sf_chain, p) class(sf_chain_t), intent(inout) :: sf_chain type(vector4_t), dimension(:), intent(in) :: p call beam_set_momenta (sf_chain%beam_t, p) end subroutine sf_chain_set_beam_momenta @ %def sf_chain_set_beam_momenta @ Set a structure-function entry. We use the [[data]] input to allocate the [[int]] structure-function instance with appropriate type, then initialize the entry. The entry establishes a pointer to [[data]]. The index [[i]] is the structure-function index in the chain. <>= procedure :: set_strfun => sf_chain_set_strfun <>= subroutine sf_chain_set_strfun (sf_chain, i, beam_index, data) class(sf_chain_t), intent(inout) :: sf_chain integer, intent(in) :: i integer, dimension(:), intent(in) :: beam_index class(sf_data_t), intent(in), target :: data integer :: n_par, j n_par = data%get_n_par () call data%allocate_sf_int (sf_chain%sf(i)%int) associate (sf_int => sf_chain%sf(i)%int) call sf_int%init (data) call sf_int%set_beam_index (beam_index) call sf_int%set_par_index & ([(j, j = sf_chain%n_par + 1, sf_chain%n_par + n_par)]) sf_chain%n_par = sf_chain%n_par + n_par if (.not. data%is_generator ()) then sf_chain%n_bound = sf_chain%n_bound + n_par end if end associate end subroutine sf_chain_set_strfun @ %def sf_chain_set_strfun @ Return the number of structure-function parameters. <>= procedure :: get_n_par => sf_chain_get_n_par procedure :: get_n_bound => sf_chain_get_n_bound <>= function sf_chain_get_n_par (sf_chain) result (n) class(sf_chain_t), intent(in) :: sf_chain integer :: n n = sf_chain%n_par end function sf_chain_get_n_par function sf_chain_get_n_bound (sf_chain) result (n) class(sf_chain_t), intent(in) :: sf_chain integer :: n n = sf_chain%n_bound end function sf_chain_get_n_bound @ %def sf_chain_get_n_par @ %def sf_chain_get_n_bound @ Return a pointer to the beam interaction. <>= procedure :: get_beam_int_ptr => sf_chain_get_beam_int_ptr <>= function sf_chain_get_beam_int_ptr (sf_chain) result (int) type(interaction_t), pointer :: int class(sf_chain_t), intent(in), target :: sf_chain int => beam_get_int_ptr (sf_chain%beam_t) end function sf_chain_get_beam_int_ptr @ %def sf_chain_get_beam_int_ptr @ Enable the trace feature: record structure function data (input parameters, $x$ values, evaluation result) to an external file. <>= procedure :: setup_tracing => sf_chain_setup_tracing procedure :: final_tracing => sf_chain_final_tracing <>= subroutine sf_chain_setup_tracing (sf_chain, file) class(sf_chain_t), intent(inout) :: sf_chain type(string_t), intent(in) :: file if (sf_chain%n_strfun > 0) then sf_chain%trace_enable = .true. sf_chain%trace_unit = free_unit () open (sf_chain%trace_unit, file = char (file), action = "write", & status = "replace") call sf_chain%write_trace_header () else call msg_error ("Beam structure: no structure functions, tracing & &disabled") end if end subroutine sf_chain_setup_tracing subroutine sf_chain_final_tracing (sf_chain) class(sf_chain_t), intent(inout) :: sf_chain if (sf_chain%trace_enable) then close (sf_chain%trace_unit) sf_chain%trace_enable = .false. end if end subroutine sf_chain_final_tracing @ %def sf_chain_setup_tracing @ %def sf_chain_final_tracing @ Write the header for the tracing file. <>= procedure :: write_trace_header => sf_chain_write_trace_header <>= subroutine sf_chain_write_trace_header (sf_chain) class(sf_chain_t), intent(in) :: sf_chain integer :: u if (sf_chain%trace_enable) then u = sf_chain%trace_unit write (u, "('# ',A)") "WHIZARD output: & &structure-function sampling data" write (u, "('# ',A,1x,I0)") "Number of sf records:", sf_chain%n_strfun write (u, "('# ',A,1x,I0)") "Number of parameters:", sf_chain%n_par write (u, "('# ',A)") "Columns: channel, p(n_par), x(n_par), f, Jac * f" end if end subroutine sf_chain_write_trace_header @ %def sf_chain_write_trace_header @ Write a record which collects the structure function data for the current data point. For the selected channel, we print first the input integration parameters, then the $x$ values, then the structure-function value summed over all quantum numbers, then the structure function value times the mapping Jacobian. <>= procedure :: trace => sf_chain_trace <>= subroutine sf_chain_trace (sf_chain, c_sel, p, x, f, sf_sum) class(sf_chain_t), intent(in) :: sf_chain integer, intent(in) :: c_sel real(default), dimension(:,:), intent(in) :: p real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: f real(default), intent(in) :: sf_sum real(default) :: sf_sum_pac, f_sf_sum_pac integer :: u, i if (sf_chain%trace_enable) then u = sf_chain%trace_unit write (u, "(1x,I0)", advance="no") c_sel write (u, "(2x)", advance="no") do i = 1, sf_chain%n_par write (u, "(1x," // FMT_17 // ")", advance="no") p(i,c_sel) end do write (u, "(2x)", advance="no") do i = 1, sf_chain%n_par write (u, "(1x," // FMT_17 // ")", advance="no") x(i) end do write (u, "(2x)", advance="no") sf_sum_pac = sf_sum f_sf_sum_pac = f(c_sel) * sf_sum call pacify (sf_sum_pac, 1.E-28_default) call pacify (f_sf_sum_pac, 1.E-28_default) write (u, "(2(1x," // FMT_17 // "))") sf_sum_pac, f_sf_sum_pac end if end subroutine sf_chain_trace @ %def sf_chain_trace @ \subsection{Chain instances} A structure-function chain instance contains copies of the interactions in the configuration chain, suitably linked to each other and connected by evaluators. After initialization, [[out_sf]] should point, for each beam, to the last structure function that affects this beam. [[out_sf_i]] should indicate the index of the corresponding outgoing particle within that structure-function interaction. Analogously, [[out_eval]] is the last evaluator in the structure-function chain, which contains the complete set of outgoing particles. [[out_eval_i]] should indicate the index of the outgoing particles, within that evaluator, which will initiate the collision. When calculating actual kinematics, we fill the [[p]], [[r]], and [[x]] arrays and the [[f]] factor. The [[p]] array denotes the MC input parameters as they come from the random-number generator. The [[r]] array results from applying global mappings. The [[x]] array results from applying structure-function local mappings. The $x$ values can be interpreted directly as momentum fractions (or angle fractions, where recoil is involved). The [[f]] factor is the Jacobian that results from applying all mappings. Update 2017-08-22: carry and output all complements ([[pb]], [[rb]], [[xb]]). Previously, [[xb]] was not included in the record, and the output did not contain either. It does become more verbose, however. The [[mapping]] entry may store a global mapping that is applied to a combination of $x$ values and structure functions, as opposed to mappings that affect only a single structure function. It is applied before the latter mappings, in the transformation from the [[p]] array to the [[r]] array. For parameters affected by this mapping, we should ensure that they are not involved in a local mapping. <>= public :: sf_chain_instance_t <>= type, extends (beam_t) :: sf_chain_instance_t type(sf_chain_t), pointer :: config => null () integer :: status = SF_UNDEFINED type(sf_instance_t), dimension(:), allocatable :: sf integer, dimension(:), allocatable :: out_sf integer, dimension(:), allocatable :: out_sf_i integer :: out_eval = 0 integer, dimension(:), allocatable :: out_eval_i integer :: selected_channel = 0 real(default), dimension(:,:), allocatable :: p, pb real(default), dimension(:,:), allocatable :: r, rb real(default), dimension(:), allocatable :: f real(default), dimension(:), allocatable :: x, xb logical, dimension(:), allocatable :: bound real(default) :: x_free = 1 type(sf_channel_t), dimension(:), allocatable :: channel contains <> end type sf_chain_instance_t @ %def sf_chain_instance_t @ Finalizer. <>= procedure :: final => sf_chain_instance_final <>= subroutine sf_chain_instance_final (object) class(sf_chain_instance_t), intent(inout) :: object integer :: i if (allocated (object%sf)) then do i = 1, size (object%sf, 1) associate (sf => object%sf(i)) if (allocated (sf%int)) then call sf%eval%final () call sf%int%final () end if end associate end do end if call beam_final (object%beam_t) end subroutine sf_chain_instance_final @ %def sf_chain_instance_final @ Output. Note: nagfor 5.3.1 appears to be slightly confused with the allocation status. We check both for allocation and nonzero size. <>= procedure :: write => sf_chain_instance_write <>= subroutine sf_chain_instance_write (object, unit, col_verbose) class(sf_chain_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: col_verbose integer :: u, i, c u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "Structure-function chain instance:" call write_sf_status (object%status, u) if (allocated (object%out_sf)) then write (u, "(3x,A)", advance="no") "outgoing (interactions) =" do i = 1, size (object%out_sf) write (u, "(1x,I0,':',I0)", advance="no") & object%out_sf(i), object%out_sf_i(i) end do write (u, *) end if if (object%out_eval /= 0) then write (u, "(3x,A)", advance="no") "outgoing (evaluators) =" do i = 1, size (object%out_sf) write (u, "(1x,I0,':',I0)", advance="no") & object%out_eval, object%out_eval_i(i) end do write (u, *) end if if (allocated (object%sf)) then if (size (object%sf) /= 0) then write (u, "(1x,A)") "Structure-function parameters:" do c = 1, size (object%f) write (u, "(1x,A,I0,A)", advance="no") "Channel #", c, ":" if (c == object%selected_channel) then write (u, "(1x,A)") "[selected]" else write (u, *) end if write (u, "(3x,A,9(1x,F9.7))") "p =", object%p(:,c) write (u, "(3x,A,9(1x,F9.7))") "pb=", object%pb(:,c) write (u, "(3x,A,9(1x,F9.7))") "r =", object%r(:,c) write (u, "(3x,A,9(1x,F9.7))") "rb=", object%rb(:,c) write (u, "(3x,A,9(1x,ES13.7))") "f =", object%f(c) write (u, "(3x,A)", advance="no") "m =" call object%channel(c)%write (u) end do write (u, "(3x,A,9(1x,F9.7))") "x =", object%x write (u, "(3x,A,9(1x,F9.7))") "xb=", object%xb if (.not. all (object%bound)) then write (u, "(3x,A,9(1x,L1))") "bound =", object%bound end if end if end if call write_separator (u) call beam_write (object%beam_t, u, col_verbose = col_verbose) if (allocated (object%sf)) then do i = 1, size (object%sf) associate (sf => object%sf(i)) call write_separator (u) if (allocated (sf%int)) then if (allocated (sf%r)) then write (u, "(1x,A)") "Structure-function parameters:" do c = 1, size (sf%f) write (u, "(1x,A,I0,A)", advance="no") "Channel #", c, ":" if (c == object%selected_channel) then write (u, "(1x,A)") "[selected]" else write (u, *) end if write (u, "(3x,A,9(1x,F9.7))") "r =", sf%r(:,c) write (u, "(3x,A,9(1x,F9.7))") "rb=", sf%rb(:,c) write (u, "(3x,A,9(1x,ES13.7))") "f =", sf%f(c) write (u, "(3x,A,9(1x,L1,7x))") "m =", sf%m(c) end do write (u, "(3x,A,9(1x,F9.7))") "x =", sf%x write (u, "(3x,A,9(1x,F9.7))") "xb=", sf%xb end if call sf%int%write(u) if (.not. sf%eval%is_empty ()) then call sf%eval%write (u, col_verbose = col_verbose) end if end if end associate end do end if end subroutine sf_chain_instance_write @ %def sf_chain_instance_write @ Initialize. This creates a copy of the interactions in the configuration chain, assumed to be properly initialized. In the copy, we allocate the [[p]] etc.\ arrays. The brute-force assignment of the [[sf]] component would be straightforward, but at least gfortran 4.6.3 would like a more fine-grained copy. In any case, the copy is deep as far as allocatables are concerned, but for the contained [[interaction_t]] objects the copy is shallow, as long as we do not bind defined assignment to the type. Therefore, we have to re-assign the [[interaction_t]] components explicitly, this time calling the proper defined assignment. Furthermore, we allocate the parameter arrays for each structure function. <>= procedure :: init => sf_chain_instance_init <>= subroutine sf_chain_instance_init (chain, config, n_channel) class(sf_chain_instance_t), intent(out), target :: chain type(sf_chain_t), intent(in), target :: config integer, intent(in) :: n_channel integer :: i, j integer :: n_par_tot, n_par, n_strfun chain%config => config n_strfun = config%n_strfun chain%beam_t = config%beam_t allocate (chain%out_sf (config%n_in), chain%out_sf_i (config%n_in)) allocate (chain%out_eval_i (config%n_in)) chain%out_sf = 0 chain%out_sf_i = [(i, i = 1, config%n_in)] chain%out_eval_i = chain%out_sf_i n_par_tot = 0 if (n_strfun /= 0) then allocate (chain%sf (n_strfun)) do i = 1, n_strfun associate (sf => chain%sf(i)) allocate (sf%int, source=config%sf(i)%int) sf%int%interaction_t = config%sf(i)%int%interaction_t n_par = size (sf%int%par_index) allocate (sf%r (n_par, n_channel)); sf%r = 0 allocate (sf%rb(n_par, n_channel)); sf%rb= 0 allocate (sf%f (n_channel)); sf%f = 0 allocate (sf%m (n_channel)); sf%m = .false. allocate (sf%x (n_par)); sf%x = 0 allocate (sf%xb(n_par)); sf%xb= 0 n_par_tot = n_par_tot + n_par end associate end do allocate (chain%p (n_par_tot, n_channel)); chain%p = 0 allocate (chain%pb(n_par_tot, n_channel)); chain%pb= 0 allocate (chain%r (n_par_tot, n_channel)); chain%r = 0 allocate (chain%rb(n_par_tot, n_channel)); chain%rb= 0 allocate (chain%f (n_channel)); chain%f = 0 allocate (chain%x (n_par_tot)); chain%x = 0 allocate (chain%xb(n_par_tot)); chain%xb= 0 call allocate_sf_channels & (chain%channel, n_channel=n_channel, n_strfun=n_strfun) end if allocate (chain%bound (n_par_tot), source = .true.) do i = 1, n_strfun associate (sf => chain%sf(i)) if (sf%int%is_generator ()) then do j = 1, size (sf%int%par_index) chain%bound(sf%int%par_index(j)) = .false. end do end if end associate end do chain%status = SF_INITIAL end subroutine sf_chain_instance_init @ %def sf_chain_instance_init @ Manually select a channel. <>= procedure :: select_channel => sf_chain_instance_select_channel <>= subroutine sf_chain_instance_select_channel (chain, channel) class(sf_chain_instance_t), intent(inout) :: chain integer, intent(in), optional :: channel if (present (channel)) then chain%selected_channel = channel else chain%selected_channel = 0 end if end subroutine sf_chain_instance_select_channel @ %def sf_chain_instance_select_channel @ Copy a channel-mapping object to the structure-function chain instance. We assume that assignment is sufficient, i.e., any non-static components of the [[channel]] object are allocatable und thus recursively copied. After the copy, we extract the single-entry mappings and activate them for the individual structure functions. If there is a multi-entry mapping, we obtain the corresponding MC parameter indices and set them in the copy of the channel object. <>= procedure :: set_channel => sf_chain_instance_set_channel <>= subroutine sf_chain_instance_set_channel (chain, c, channel) class(sf_chain_instance_t), intent(inout) :: chain integer, intent(in) :: c type(sf_channel_t), intent(in) :: channel integer :: i, j, k if (chain%status >= SF_INITIAL) then chain%channel(c) = channel j = 0 do i = 1, chain%config%n_strfun associate (sf => chain%sf(i)) sf%m(c) = channel%is_single_mapping (i) if (channel%is_multi_mapping (i)) then do k = 1, size (sf%int%beam_index) j = j + 1 call chain%channel(c)%set_par_index & (j, sf%int%par_index(k)) end do end if end associate end do if (j /= chain%channel(c)%get_multi_mapping_n_par ()) then print *, "index last filled = ", j print *, "number of parameters = ", & chain%channel(c)%get_multi_mapping_n_par () call msg_bug ("Structure-function setup: mapping index mismatch") end if chain%status = SF_INITIAL end if end subroutine sf_chain_instance_set_channel @ %def sf_chain_instance_set_channel @ Link the interactions in the chain. First, link the beam instance to its template in the configuration chain, which should have the appropriate momenta fixed. Then, we follow the chain via the arrays [[out_sf]] and [[out_sf_i]]. The arrays are (up to) two-dimensional, the entries correspond to the beam particle(s). For each beam, the entry [[out_sf]] points to the last interaction that affected this beam, and [[out_sf_i]] is the out-particle index within that interaction. For the initial beam, [[out_sf]] is zero by definition. For each entry in the chain, we scan the affected beams (one or two). We look for [[out_sf]] and link the out-particle there to the corresponding in-particle in the current interaction. Then, we update the entry in [[out_sf]] and [[out_sf_i]] to point to the current interaction. <>= procedure :: link_interactions => sf_chain_instance_link_interactions <>= subroutine sf_chain_instance_link_interactions (chain) class(sf_chain_instance_t), intent(inout), target :: chain type(interaction_t), pointer :: int integer :: i, j, b if (chain%status >= SF_INITIAL) then do b = 1, chain%config%n_in int => beam_get_int_ptr (chain%beam_t) call interaction_set_source_link (int, b, & chain%config%beam_t, b) end do if (allocated (chain%sf)) then do i = 1, size (chain%sf) associate (sf_int => chain%sf(i)%int) do j = 1, size (sf_int%beam_index) b = sf_int%beam_index(j) call link (sf_int%interaction_t, b, sf_int%incoming(j)) chain%out_sf(b) = i chain%out_sf_i(b) = sf_int%outgoing(j) end do end associate end do end if chain%status = SF_DONE_LINKS end if contains subroutine link (int, b, in_index) type(interaction_t), intent(inout) :: int integer, intent(in) :: b, in_index integer :: i i = chain%out_sf(b) select case (i) case (0) call interaction_set_source_link (int, in_index, & chain%beam_t, chain%out_sf_i(b)) case default call int%set_source_link (in_index, & chain%sf(i)%int, chain%out_sf_i(b)) end select end subroutine link end subroutine sf_chain_instance_link_interactions @ %def sf_chain_instance_link_interactions @ Exchange the quantum-number masks between the interactions in the chain, so we can combine redundant entries and detect any obvious mismatch. We proceed first in the forward direction and then backwards again. After this is finished, we finalize initialization by calling the [[setup_constants]] method, which prepares constant data that depend on the matrix element structure. <>= procedure :: exchange_mask => sf_chain_exchange_mask <>= subroutine sf_chain_exchange_mask (chain) class(sf_chain_instance_t), intent(inout), target :: chain type(interaction_t), pointer :: int type(quantum_numbers_mask_t), dimension(:), allocatable :: mask integer :: i if (chain%status >= SF_DONE_LINKS) then if (allocated (chain%sf)) then int => beam_get_int_ptr (chain%beam_t) allocate (mask (int%get_n_out ())) mask = int%get_mask () if (size (chain%sf) /= 0) then do i = 1, size (chain%sf) - 1 call interaction_exchange_mask (chain%sf(i)%int%interaction_t) end do do i = size (chain%sf), 1, -1 call interaction_exchange_mask (chain%sf(i)%int%interaction_t) end do if (any (mask .neqv. int%get_mask ())) then chain%status = SF_FAILED_MASK return end if do i = 1, size (chain%sf) call chain%sf(i)%int%setup_constants () end do end if end if chain%status = SF_DONE_MASK end if end subroutine sf_chain_exchange_mask @ %def sf_chain_exchange_mask @ Initialize the evaluators that connect the interactions in the chain. <>= procedure :: init_evaluators => sf_chain_instance_init_evaluators <>= subroutine sf_chain_instance_init_evaluators (chain, extended_sf) class(sf_chain_instance_t), intent(inout), target :: chain logical, intent(in), optional :: extended_sf type(interaction_t), pointer :: int type(quantum_numbers_mask_t) :: mask integer :: i logical :: yorn yorn = .false.; if (present (extended_sf)) yorn = extended_sf if (chain%status >= SF_DONE_MASK) then if (allocated (chain%sf)) then if (size (chain%sf) /= 0) then mask = quantum_numbers_mask (.false., .false., .true.) int => beam_get_int_ptr (chain%beam_t) do i = 1, size (chain%sf) associate (sf => chain%sf(i)) if (yorn) then if (int%get_n_sub () == 0) then call int%declare_subtraction (n_beam_structure_int) end if if (sf%int%interaction_t%get_n_sub () == 0) then call sf%int%interaction_t%declare_subtraction & (n_beam_structure_int) end if end if call sf%eval%init_product (int, sf%int%interaction_t, mask,& & ignore_sub = .true.) if (sf%eval%is_empty ()) then chain%status = SF_FAILED_CONNECTIONS return end if int => sf%eval%interaction_t end associate end do call find_outgoing_particles () end if else if (chain%out_eval == 0) then int => beam_get_int_ptr (chain%beam_t) call int%tag_hard_process () end if chain%status = SF_DONE_CONNECTIONS end if contains <> end subroutine sf_chain_instance_init_evaluators @ %def sf_chain_instance_init_evaluators @ For debug purposes <>= procedure :: write_interaction => sf_chain_instance_write_interaction <>= subroutine sf_chain_instance_write_interaction (chain, i_sf, i_int, unit) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: i_sf, i_int integer, intent(in) :: unit class(interaction_t), pointer :: int_in1 => null () class(interaction_t), pointer :: int_in2 => null () integer :: u u = given_output_unit (unit); if (u < 0) return if (chain%status >= SF_DONE_MASK) then if (allocated (chain%sf)) then int_in1 => evaluator_get_int_in_ptr (chain%sf(i_sf)%eval, 1) int_in2 => evaluator_get_int_in_ptr (chain%sf(i_sf)%eval, 2) if (int_in1%get_tag () == i_int) then call int_in1%basic_write (u) else if (int_in2%get_tag () == i_int) then call int_in2%basic_write (u) else write (u, "(A,1x,I0,1x,A,1x,I0)") 'No tag of sf', i_sf, 'matches' , i_int end if else write (u, "(A)") 'No sf_chain allocated!' end if else write (u, "(A)") 'sf_chain not ready!' end if end subroutine sf_chain_instance_write_interaction @ %def sf_chain_instance_write_interaction @ This is an internal subroutine of the previous one: After evaluators are set, trace the outgoing particles to the last evaluator. We only need the first channel, all channels are equivalent for this purpose. For each beam, the outgoing particle is located by [[out_sf]] (the structure-function object where it originates) and [[out_sf_i]] (the index within that object). This particle is referenced by the corresponding evaluator, which in turn is referenced by the next evaluator, until we are at the end of the chain. We can trace back references by [[interaction_find_link]]. Knowing that [[out_eval]] is the index of the last evaluator, we thus determine [[out_eval_i]], the index of the outgoing particle within that evaluator. <>= subroutine find_outgoing_particles () type(interaction_t), pointer :: int, int_next integer :: i, j, out_sf, out_i chain%out_eval = size (chain%sf) do j = 1, size (chain%out_eval_i) out_sf = chain%out_sf(j) out_i = chain%out_sf_i(j) if (out_sf == 0) then int => beam_get_int_ptr (chain%beam_t) out_sf = 1 else int => chain%sf(out_sf)%int%interaction_t end if do i = out_sf, chain%out_eval int_next => chain%sf(i)%eval%interaction_t out_i = interaction_find_link (int_next, int, out_i) int => int_next end do chain%out_eval_i(j) = out_i end do call int%tag_hard_process (chain%out_eval_i) end subroutine find_outgoing_particles @ %def find_outgoing_particles @ Compute the kinematics in the chain instance. We can assume that the seed momenta are set in the configuration beams. Scanning the chain, we first transfer the incoming momenta. Then, the use up the MC input parameter array [[p]] to compute the radiated and outgoing momenta. In the multi-channel case, [[c_sel]] is the channel which we use for computing the kinematics and the [[x]] values. In the other channels, we invert the kinematics in order to recover the corresponding rows in the [[r]] array, and the Jacobian [[f]]. We first apply any global mapping to transform the input [[p]] into the array [[r]]. This is then given to the structure functions which compute the final array [[x]] and Jacobian factors [[f]], which we multiply to obtain the overall Jacobian. <>= procedure :: compute_kinematics => sf_chain_instance_compute_kinematics <>= subroutine sf_chain_instance_compute_kinematics (chain, c_sel, p_in) class(sf_chain_instance_t), intent(inout), target :: chain integer, intent(in) :: c_sel real(default), dimension(:), intent(in) :: p_in type(interaction_t), pointer :: int real(default) :: f_mapping logical, dimension(size (chain%bound)) :: bound integer :: i, j, c if (chain%status >= SF_DONE_CONNECTIONS) then call chain%select_channel (c_sel) int => beam_get_int_ptr (chain%beam_t) call int%receive_momenta () if (allocated (chain%sf)) then if (size (chain%sf) /= 0) then forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL !!! Bug in nagfor 5.3.1(907), fixed in 5.3.1(982) ! chain%p (:,c_sel) = unpack (p_in, chain%bound, 0._default) !!! Workaround: bound = chain%bound chain%p (:,c_sel) = unpack (p_in, bound, 0._default) chain%pb(:,c_sel) = 1 - chain%p(:,c_sel) chain%f = 1 chain%x_free = 1 do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%generate_free (sf%r(:,c_sel), sf%rb(:,c_sel), & chain%x_free) do j = 1, size (sf%x) if (.not. chain%bound(sf%int%par_index(j))) then chain%p (sf%int%par_index(j),c_sel) = sf%r (j,c_sel) chain%pb(sf%int%par_index(j),c_sel) = sf%rb(j,c_sel) end if end do end associate end do if (allocated (chain%channel(c_sel)%multi_mapping)) then call chain%channel(c_sel)%multi_mapping%compute & (chain%r(:,c_sel), chain%rb(:,c_sel), & f_mapping, & chain%p(:,c_sel), chain%pb(:,c_sel), & chain%x_free) chain%f(c_sel) = f_mapping else chain%r (:,c_sel) = chain%p (:,c_sel) chain%rb(:,c_sel) = chain%pb(:,c_sel) chain%f(c_sel) = 1 end if do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%seed_kinematics () do j = 1, size (sf%x) sf%r (j,c_sel) = chain%r (sf%int%par_index(j),c_sel) sf%rb(j,c_sel) = chain%rb(sf%int%par_index(j),c_sel) end do call sf%int%complete_kinematics & (sf%x, sf%xb, sf%f(c_sel), sf%r(:,c_sel), sf%rb(:,c_sel), & sf%m(c_sel)) do j = 1, size (sf%x) chain%x(sf%int%par_index(j)) = sf%x(j) chain%xb(sf%int%par_index(j)) = sf%xb(j) end do if (sf%int%status <= SF_FAILED_KINEMATICS) then chain%status = SF_FAILED_KINEMATICS return end if do c = 1, size (sf%f) if (c /= c_sel) then call sf%int%inverse_kinematics & (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c)) do j = 1, size (sf%x) chain%r (sf%int%par_index(j),c) = sf%r (j,c) chain%rb(sf%int%par_index(j),c) = sf%rb(j,c) end do end if chain%f(c) = chain%f(c) * sf%f(c) end do if (.not. sf%eval%is_empty ()) then call sf%eval%receive_momenta () end if end associate end do do c = 1, size (chain%f) if (c /= c_sel) then if (allocated (chain%channel(c)%multi_mapping)) then call chain%channel(c)%multi_mapping%inverse & (chain%r(:,c), chain%rb(:,c), & f_mapping, & chain%p(:,c), chain%pb(:,c), & chain%x_free) chain%f(c) = chain%f(c) * f_mapping else chain%p (:,c) = chain%r (:,c) chain%pb(:,c) = chain%rb(:,c) end if end if end do end if end if chain%status = SF_DONE_KINEMATICS end if end subroutine sf_chain_instance_compute_kinematics @ %def sf_chain_instance_compute_kinematics @ This is a variant of the previous procedure. We know the $x$ parameters and reconstruct the momenta and the MC input parameters [[p]]. We do not need to select a channel. Note: this is probably redundant, since the method we actually want starts from the momenta, recovers all $x$ parameters, and then inverts mappings. See below [[recover_kinematics]]. <>= procedure :: inverse_kinematics => sf_chain_instance_inverse_kinematics <>= subroutine sf_chain_instance_inverse_kinematics (chain, x, xb) class(sf_chain_instance_t), intent(inout), target :: chain real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb type(interaction_t), pointer :: int real(default) :: f_mapping integer :: i, j, c if (chain%status >= SF_DONE_CONNECTIONS) then call chain%select_channel () int => beam_get_int_ptr (chain%beam_t) call int%receive_momenta () if (allocated (chain%sf)) then chain%f = 1 if (size (chain%sf) /= 0) then forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL chain%x = x chain%xb= xb do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%seed_kinematics () do j = 1, size (sf%x) sf%x(j) = chain%x(sf%int%par_index(j)) sf%xb(j) = chain%xb(sf%int%par_index(j)) end do do c = 1, size (sf%f) call sf%int%inverse_kinematics & (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), & set_momenta = c==1) chain%f(c) = chain%f(c) * sf%f(c) do j = 1, size (sf%x) chain%r (sf%int%par_index(j),c) = sf%r (j,c) chain%rb(sf%int%par_index(j),c) = sf%rb(j,c) end do end do if (.not. sf%eval%is_empty ()) then call sf%eval%receive_momenta () end if end associate end do do c = 1, size (chain%f) if (allocated (chain%channel(c)%multi_mapping)) then call chain%channel(c)%multi_mapping%inverse & (chain%r(:,c), chain%rb(:,c), & f_mapping, & chain%p(:,c), chain%pb(:,c), & chain%x_free) chain%f(c) = chain%f(c) * f_mapping else chain%p (:,c) = chain%r (:,c) chain%pb(:,c) = chain%rb(:,c) end if end do end if end if chain%status = SF_DONE_KINEMATICS end if end subroutine sf_chain_instance_inverse_kinematics @ %def sf_chain_instance_inverse_kinematics @ Recover the kinematics: assuming that the last evaluator has been filled with a valid set of momenta, we travel the momentum links backwards and fill the preceding evaluators and, as a side effect, interactions. We stop at the beam interaction. After all momenta are set, apply the [[inverse_kinematics]] procedure above, suitably modified, to recover the $x$ and $p$ parameters and the Jacobian factors. The [[c_sel]] (channel) argument is just used to mark a selected channel for the records, otherwise the recovery procedure is independent of this. <>= procedure :: recover_kinematics => sf_chain_instance_recover_kinematics <>= subroutine sf_chain_instance_recover_kinematics (chain, c_sel) class(sf_chain_instance_t), intent(inout), target :: chain integer, intent(in) :: c_sel real(default) :: f_mapping integer :: i, j, c if (chain%status >= SF_DONE_CONNECTIONS) then call chain%select_channel (c_sel) if (allocated (chain%sf)) then do i = size (chain%sf), 1, -1 associate (sf => chain%sf(i)) if (.not. sf%eval%is_empty ()) then call interaction_send_momenta (sf%eval%interaction_t) end if end associate end do chain%f = 1 if (size (chain%sf) /= 0) then forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL chain%x_free = 1 do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%seed_kinematics () call sf%int%recover_x (sf%x, sf%xb, chain%x_free) do j = 1, size (sf%x) chain%x(sf%int%par_index(j)) = sf%x(j) chain%xb(sf%int%par_index(j)) = sf%xb(j) end do do c = 1, size (sf%f) call sf%int%inverse_kinematics & (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), & set_momenta = .false.) chain%f(c) = chain%f(c) * sf%f(c) do j = 1, size (sf%x) chain%r (sf%int%par_index(j),c) = sf%r (j,c) chain%rb(sf%int%par_index(j),c) = sf%rb(j,c) end do end do end associate end do do c = 1, size (chain%f) if (allocated (chain%channel(c)%multi_mapping)) then call chain%channel(c)%multi_mapping%inverse & (chain%r(:,c), chain%rb(:,c), & f_mapping, & chain%p(:,c), chain%pb(:,c), & chain%x_free) chain%f(c) = chain%f(c) * f_mapping else chain%p (:,c) = chain%r (:,c) chain%pb(:,c) = chain%rb(:,c) end if end do end if end if chain%status = SF_DONE_KINEMATICS end if end subroutine sf_chain_instance_recover_kinematics @ %def sf_chain_instance_recover_kinematics @ Return the initial beam momenta to their source, thus completing kinematics recovery. Obviously, this works as a side effect. <>= procedure :: return_beam_momenta => sf_chain_instance_return_beam_momenta <>= subroutine sf_chain_instance_return_beam_momenta (chain) class(sf_chain_instance_t), intent(in), target :: chain type(interaction_t), pointer :: int if (chain%status >= SF_DONE_KINEMATICS) then int => beam_get_int_ptr (chain%beam_t) call interaction_send_momenta (int) end if end subroutine sf_chain_instance_return_beam_momenta @ %def sf_chain_instance_return_beam_momenta @ Evaluate all interactions in the chain and the product evaluators. We provide a [[scale]] argument that is given to all structure functions in the chain. Hadronic NLO calculations involve rescaled fractions of the original beam momentum and PDF singlets (sums over flavors). In particular, we have to handle the following cases: \begin{itemize} \item normal evaluation (where [[n_sub = 0]]) for Born and Virtual processes, \item rescaled momentum fraction for matching [[i_beam == i_sub]], [[n_sub > 0]] and [[sf_rescale]] present, the other beam is kept at born kinematics, \item filling the subtraction terms with values from the current evaluation [[fill_sub = .true.]], used for the non-rescaled beam, \item restricted rescaling to only one beam with [[sf_rescale%is_restricted]]. \end{itemize} For the collinear final or intial state counter terms, we apply a rescaling to one beam, and keep the other beam as is. We redo it then vice versa having now two subtractions. We add two more subtraction where we apply the rescaled gluonic PDF to \textit{all} flavors for the PDF singlet calculations. For the real rescalation, we have only one rescaled beams, therefore, we have only one subtraction. <>= procedure :: evaluate => sf_chain_instance_evaluate <>= subroutine sf_chain_instance_evaluate (chain, scale, sf_rescale) class(sf_chain_instance_t), intent(inout), target :: chain real(default), intent(in) :: scale class(sf_rescale_t), intent(inout), optional :: sf_rescale type(interaction_t), pointer :: out_int real(default) :: sf_sum integer :: i_beam, i_sub, n_sub if (chain%status >= SF_DONE_KINEMATICS) then if (allocated (chain%sf)) then if (size (chain%sf) /= 0) then do i_beam = 1, size (chain%sf) associate (sf => chain%sf(i_beam)) n_sub = 0 ! default: no looping over rescaled beams if (present (sf_rescale)) then - ! TODO sbrass cache n_sub as it is computed from the state matrix n_sub = sf%int%get_n_sub () call sf_rescale%set_i_beam (i_beam) end if SUB: do i_sub = 0, n_sub select case (i_sub) case (0) if (n_sub == 0) then call sf%int%apply (scale, sf_rescale) else call sf%int%apply (scale, fill_sub = .true.) end if case (1:2) if (present (sf_rescale)) then if (sf_rescale%is_restricted (i_beam)) cycle SUB end if if (i_sub == i_beam) then call sf%int%apply(scale, sf_rescale, i_sub) end if case (3:4) ! dummy : handled more appropriately on a lower level (sf%int%apply ()) case default call msg_bug ("sf_chain_instance_evaluate: more than 2& & subtraction indices are curently not handled.") end select if (sf%int%status <= SF_FAILED_EVALUATION) then chain%status = SF_FAILED_EVALUATION return end if end do SUB if (.not. sf%eval%is_empty ()) call sf%eval%evaluate () end associate end do out_int => chain%get_out_int_ptr () sf_sum = real (out_int%sum ()) call chain%config%trace & (chain%selected_channel, chain%p, chain%x, chain%f, sf_sum) end if end if chain%status = SF_EVALUATED end if end subroutine sf_chain_instance_evaluate @ %def sf_chain_instance_evaluate @ \subsection{Access to the chain instance} Transfer the outgoing momenta to the array [[p]]. We assume that array sizes match. <>= procedure :: get_out_momenta => sf_chain_instance_get_out_momenta <>= subroutine sf_chain_instance_get_out_momenta (chain, p) class(sf_chain_instance_t), intent(in), target :: chain type(vector4_t), dimension(:), intent(out) :: p type(interaction_t), pointer :: int integer :: i, j if (chain%status >= SF_DONE_KINEMATICS) then do j = 1, size (chain%out_sf) i = chain%out_sf(j) select case (i) case (0) int => beam_get_int_ptr (chain%beam_t) case default int => chain%sf(i)%int%interaction_t end select p(j) = int%get_momentum (chain%out_sf_i(j)) end do end if end subroutine sf_chain_instance_get_out_momenta @ %def sf_chain_instance_get_out_momenta @ Return a pointer to the last evaluator in the chain (to the interaction). <>= procedure :: get_out_int_ptr => sf_chain_instance_get_out_int_ptr <>= function sf_chain_instance_get_out_int_ptr (chain) result (int) class(sf_chain_instance_t), intent(in), target :: chain type(interaction_t), pointer :: int if (chain%out_eval == 0) then int => beam_get_int_ptr (chain%beam_t) else int => chain%sf(chain%out_eval)%eval%interaction_t end if end function sf_chain_instance_get_out_int_ptr @ %def sf_chain_instance_get_out_int_ptr @ Return the index of the [[j]]-th outgoing particle, within the last evaluator. <>= procedure :: get_out_i => sf_chain_instance_get_out_i <>= function sf_chain_instance_get_out_i (chain, j) result (i) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: j integer :: i i = chain%out_eval_i(j) end function sf_chain_instance_get_out_i @ %def sf_chain_instance_get_out_i @ Return the mask for the outgoing particle(s), within the last evaluator. <>= procedure :: get_out_mask => sf_chain_instance_get_out_mask <>= function sf_chain_instance_get_out_mask (chain) result (mask) class(sf_chain_instance_t), intent(in), target :: chain type(quantum_numbers_mask_t), dimension(:), allocatable :: mask type(interaction_t), pointer :: int allocate (mask (chain%config%n_in)) int => chain%get_out_int_ptr () mask = int%get_mask (chain%out_eval_i) end function sf_chain_instance_get_out_mask @ %def sf_chain_instance_get_out_mask @ Return the array of MC input parameters that corresponds to channel [[c]]. This is the [[p]] array, the parameters before all mappings. The [[p]] array may be deallocated. This should correspond to a zero-size [[r]] argument, so nothing to do then. <>= procedure :: get_mcpar => sf_chain_instance_get_mcpar <>= subroutine sf_chain_instance_get_mcpar (chain, c, r) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: c real(default), dimension(:), intent(out) :: r if (allocated (chain%p)) r = pack (chain%p(:,c), chain%bound) end subroutine sf_chain_instance_get_mcpar @ %def sf_chain_instance_get_mcpar @ Return the Jacobian factor that corresponds to channel [[c]]. <>= procedure :: get_f => sf_chain_instance_get_f <>= function sf_chain_instance_get_f (chain, c) result (f) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: c real(default) :: f if (allocated (chain%f)) then f = chain%f(c) else f = 1 end if end function sf_chain_instance_get_f @ %def sf_chain_instance_get_f @ Return the evaluation status. <>= procedure :: get_status => sf_chain_instance_get_status <>= function sf_chain_instance_get_status (chain) result (status) class(sf_chain_instance_t), intent(in) :: chain integer :: status status = chain%status end function sf_chain_instance_get_status @ %def sf_chain_instance_get_status @ <>= procedure :: get_matrix_elements => sf_chain_instance_get_matrix_elements <>= subroutine sf_chain_instance_get_matrix_elements (chain, i, ff) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: i real(default), intent(out), dimension(:), allocatable :: ff associate (sf => chain%sf(i)) ff = real (sf%int%get_matrix_element ()) end associate end subroutine sf_chain_instance_get_matrix_elements @ %def sf_chain_instance_get_matrix_elements @ <>= procedure :: get_beam_int_ptr => sf_chain_instance_get_beam_int_ptr <>= function sf_chain_instance_get_beam_int_ptr (chain) result (int) type(interaction_t), pointer :: int class(sf_chain_instance_t), intent(in), target :: chain int => beam_get_int_ptr (chain%beam_t) end function sf_chain_instance_get_beam_int_ptr @ %def sf_chain_instance_get_beam_ptr @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_base_ut.f90]]>>= <> module sf_base_ut use unit_tests use sf_base_uti <> <> <> contains <> end module sf_base_ut @ %def sf_base_ut @ <<[[sf_base_uti.f90]]>>= <> module sf_base_uti <> <> use io_units use format_defs, only: FMT_19 use format_utils, only: write_separator use diagnostics use lorentz use pdg_arrays use flavors use colors use helicities use quantum_numbers use state_matrices, only: FM_IGNORE_HELICITY use interactions use particles use model_data use beams use sf_aux use sf_mappings use sf_base <> <> <> <> contains <> <> end module sf_base_uti @ %def sf_base_ut @ API: driver for the unit tests below. <>= public :: sf_base_test <>= subroutine sf_base_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_base_test @ %def sf_base_test @ \subsection{Test implementation: structure function} This is a template for the actual structure-function implementation which will be defined in separate modules. \subsubsection{Configuration data} The test structure function uses the [[Test]] model. It describes a scalar within an arbitrary initial particle, which is given in the initialization. The radiated particle is also a scalar, the same one, but we set its mass artificially to zero. <>= public :: sf_test_data_t <>= type, extends (sf_data_t) :: sf_test_data_t class(model_data_t), pointer :: model => null () integer :: mode = 0 type(flavor_t) :: flv_in type(flavor_t) :: flv_out type(flavor_t) :: flv_rad real(default) :: m = 0 logical :: collinear = .true. real(default), dimension(:), allocatable :: qbounds contains <> end type sf_test_data_t @ %def sf_test_data_t @ Output. <>= procedure :: write => sf_test_data_write <>= subroutine sf_test_data_write (data, unit, verbose) class(sf_test_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "SF test data:" write (u, "(3x,A,A)") "model = ", char (data%model%get_name ()) write (u, "(3x,A)", advance="no") "incoming = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A)", advance="no") "outgoing = " call data%flv_out%write (u); write (u, *) write (u, "(3x,A)", advance="no") "radiated = " call data%flv_rad%write (u); write (u, *) write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m write (u, "(3x,A,L1)") "collinear = ", data%collinear if (.not. data%collinear .and. allocated (data%qbounds)) then write (u, "(3x,A," // FMT_19 // ")") "qmin = ", data%qbounds(1) write (u, "(3x,A," // FMT_19 // ")") "qmax = ", data%qbounds(2) end if end subroutine sf_test_data_write @ %def sf_test_data_write @ Initialization. <>= procedure :: init => sf_test_data_init <>= subroutine sf_test_data_init (data, model, pdg_in, collinear, qbounds, mode) class(sf_test_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in logical, intent(in), optional :: collinear real(default), dimension(2), intent(in), optional :: qbounds integer, intent(in), optional :: mode data%model => model if (present (mode)) data%mode = mode if (pdg_array_get (pdg_in, 1) /= 25) then call msg_fatal ("Test spectrum function: input flavor must be 's'") end if call data%flv_in%init (25, model) data%m = data%flv_in%get_mass () if (present (collinear)) data%collinear = collinear call data%flv_out%init (25, model) call data%flv_rad%init (25, model) if (present (qbounds)) then allocate (data%qbounds (2)) data%qbounds = qbounds end if end subroutine sf_test_data_init @ %def sf_test_data_init @ Return the number of parameters: 1 if only consider collinear splitting, 3 otherwise. <>= procedure :: get_n_par => sf_test_data_get_n_par <>= function sf_test_data_get_n_par (data) result (n) class(sf_test_data_t), intent(in) :: data integer :: n if (data%collinear) then n = 1 else n = 3 end if end function sf_test_data_get_n_par @ %def sf_test_data_get_n_par @ Return the outgoing particle PDG code: 25 <>= procedure :: get_pdg_out => sf_test_data_get_pdg_out <>= subroutine sf_test_data_get_pdg_out (data, pdg_out) class(sf_test_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = 25 end subroutine sf_test_data_get_pdg_out @ %def sf_test_data_get_pdg_out @ Allocate the matching interaction. <>= procedure :: allocate_sf_int => sf_test_data_allocate_sf_int <>= subroutine sf_test_data_allocate_sf_int (data, sf_int) class(sf_test_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int if (allocated (sf_int)) deallocate (sf_int) allocate (sf_test_t :: sf_int) end subroutine sf_test_data_allocate_sf_int @ %def sf_test_data_allocate_sf_int @ \subsubsection{Interaction} <>= type, extends (sf_int_t) :: sf_test_t type(sf_test_data_t), pointer :: data => null () real(default) :: x = 0 contains <> end type sf_test_t @ %def sf_test_t @ Type string: constant <>= procedure :: type_string => sf_test_type_string <>= function sf_test_type_string (object) result (string) class(sf_test_t), intent(in) :: object type(string_t) :: string string = "Test" end function sf_test_type_string @ %def sf_test_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => sf_test_write <>= subroutine sf_test_write (object, unit, testflag) class(sf_test_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "SF test data: [undefined]" end if end subroutine sf_test_write @ %def sf_test_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. Optionally, we can provide minimum and maximum values for the momentum transfer. <>= procedure :: init => sf_test_init <>= subroutine sf_test_init (sf_int, data) class(sf_test_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask type(helicity_t) :: hel0 type(color_t) :: col0 type(quantum_numbers_t), dimension(3) :: qn mask = quantum_numbers_mask (.false., .false., .false.) select type (data) type is (sf_test_data_t) if (allocated (data%qbounds)) then call sf_int%base_init (mask, & [data%m**2], [0._default], [data%m**2], & [data%qbounds(1)], [data%qbounds(2)]) else call sf_int%base_init (mask, & [data%m**2], [0._default], [data%m**2]) end if sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_rad, col0, hel0) call qn(3)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn) call sf_int%freeze () call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) end select sf_int%status = SF_INITIAL end subroutine sf_test_init @ %def sf_test_init @ Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ and consequently $f(r)=2r$. <>= procedure :: complete_kinematics => sf_test_complete_kinematics <>= subroutine sf_test_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(sf_test_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then x(1) = r(1)**2 f = 2 * r(1) else x(1) = r(1) f = 1 end if xb(1) = 1 - x(1) if (size (x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) sf_int%x = x(1) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end subroutine sf_test_complete_kinematics @ %def sf_test_complete_kinematics @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => sf_test_inverse_kinematics <>= subroutine sf_test_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(sf_test_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then r(1) = sqrt (x(1)) f = 2 * r(1) else r(1) = x(1) f = 1 end if if (size (x) == 3) r(2:3) = x(2:3) rb = 1 - r sf_int%x = x(1) if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine sf_test_inverse_kinematics @ %def sf_test_inverse_kinematics @ Apply the structure function. The matrix element becomes unity and the application always succeeds. If the [[mode]] indicator is one, the matrix element is equal to the parameter~$x$. <>= procedure :: apply => sf_test_apply <>= subroutine sf_test_apply (sf_int, scale, rescale, i_sub, fill_sub) class(sf_test_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub logical, intent(in), optional :: fill_sub select case (sf_int%data%mode) case (0) call sf_int%set_matrix_element & (cmplx (1._default, kind=default)) case (1) call sf_int%set_matrix_element & (cmplx (sf_int%x, kind=default)) end select sf_int%status = SF_EVALUATED end subroutine sf_test_apply @ %def sf_test_apply @ \subsection{Test implementation: pair spectrum} Another template, this time for a incoming particle pair, splitting into two radiated and two outgoing particles. \subsubsection{Configuration data} For simplicity, the spectrum contains two mirror images of the previous structure-function configuration: the incoming and all outgoing particles are test scalars. We have two versions, one with radiated particles, one without. <>= type, extends (sf_data_t) :: sf_test_spectrum_data_t class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in type(flavor_t) :: flv_out type(flavor_t) :: flv_rad logical :: with_radiation = .true. real(default) :: m = 0 contains <> end type sf_test_spectrum_data_t @ %def sf_test_spectrum_data_t @ Output. <>= procedure :: write => sf_test_spectrum_data_write <>= subroutine sf_test_spectrum_data_write (data, unit, verbose) class(sf_test_spectrum_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "SF test spectrum data:" write (u, "(3x,A,A)") "model = ", char (data%model%get_name ()) write (u, "(3x,A)", advance="no") "incoming = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A)", advance="no") "outgoing = " call data%flv_out%write (u); write (u, *) write (u, "(3x,A)", advance="no") "radiated = " call data%flv_rad%write (u); write (u, *) write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m end subroutine sf_test_spectrum_data_write @ %def sf_test_spectrum_data_write @ Initialization. <>= procedure :: init => sf_test_spectrum_data_init <>= subroutine sf_test_spectrum_data_init (data, model, pdg_in, with_radiation) class(sf_test_spectrum_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in logical, intent(in) :: with_radiation data%model => model data%with_radiation = with_radiation if (pdg_array_get (pdg_in, 1) /= 25) then call msg_fatal ("Test structure function: input flavor must be 's'") end if call data%flv_in%init (25, model) data%m = data%flv_in%get_mass () call data%flv_out%init (25, model) if (with_radiation) then call data%flv_rad%init (25, model) end if end subroutine sf_test_spectrum_data_init @ %def sf_test_spectrum_data_init @ Return the number of parameters: 2, since we have only collinear splitting here. <>= procedure :: get_n_par => sf_test_spectrum_data_get_n_par <>= function sf_test_spectrum_data_get_n_par (data) result (n) class(sf_test_spectrum_data_t), intent(in) :: data integer :: n n = 2 end function sf_test_spectrum_data_get_n_par @ %def sf_test_spectrum_data_get_n_par @ Return the outgoing particle PDG codes: 25 <>= procedure :: get_pdg_out => sf_test_spectrum_data_get_pdg_out <>= subroutine sf_test_spectrum_data_get_pdg_out (data, pdg_out) class(sf_test_spectrum_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = 25 pdg_out(2) = 25 end subroutine sf_test_spectrum_data_get_pdg_out @ %def sf_test_spectrum_data_get_pdg_out @ Allocate the matching interaction. <>= procedure :: allocate_sf_int => & sf_test_spectrum_data_allocate_sf_int <>= subroutine sf_test_spectrum_data_allocate_sf_int (data, sf_int) class(sf_test_spectrum_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (sf_test_spectrum_t :: sf_int) end subroutine sf_test_spectrum_data_allocate_sf_int @ %def sf_test_spectrum_data_allocate_sf_int @ \subsubsection{Interaction} <>= type, extends (sf_int_t) :: sf_test_spectrum_t type(sf_test_spectrum_data_t), pointer :: data => null () contains <> end type sf_test_spectrum_t @ %def sf_test_spectrum_t <>= procedure :: type_string => sf_test_spectrum_type_string <>= function sf_test_spectrum_type_string (object) result (string) class(sf_test_spectrum_t), intent(in) :: object type(string_t) :: string string = "Test Spectrum" end function sf_test_spectrum_type_string @ %def sf_test_spectrum_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => sf_test_spectrum_write <>= subroutine sf_test_spectrum_write (object, unit, testflag) class(sf_test_spectrum_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "SF test spectrum data: [undefined]" end if end subroutine sf_test_spectrum_write @ %def sf_test_spectrum_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_spectrum_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. Optionally, we can provide minimum and maximum values for the momentum transfer. <>= procedure :: init => sf_test_spectrum_init <>= subroutine sf_test_spectrum_init (sf_int, data) class(sf_test_spectrum_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(6) :: mask type(helicity_t) :: hel0 type(color_t) :: col0 type(quantum_numbers_t), dimension(6) :: qn mask = quantum_numbers_mask (.false., .false., .false.) select type (data) type is (sf_test_spectrum_data_t) if (data%with_radiation) then call sf_int%base_init (mask(1:6), & [data%m**2, data%m**2], & [0._default, 0._default], & [data%m**2, data%m**2]) sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_in, col0, hel0) call qn(3)%init (data%flv_rad, col0, hel0) call qn(4)%init (data%flv_rad, col0, hel0) call qn(5)%init (data%flv_out, col0, hel0) call qn(6)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn(1:6)) call sf_int%set_incoming ([1,2]) call sf_int%set_radiated ([3,4]) call sf_int%set_outgoing ([5,6]) else call sf_int%base_init (mask(1:4), & [data%m**2, data%m**2], & [real(default) :: ], & [data%m**2, data%m**2]) sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_in, col0, hel0) call qn(3)%init (data%flv_out, col0, hel0) call qn(4)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn(1:4)) call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) end if call sf_int%freeze () end select sf_int%status = SF_INITIAL end subroutine sf_test_spectrum_init @ %def sf_test_spectrum_init @ Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ (as above) for both $x$ parameters and consequently $f(r)=4r_1r_2$. <>= procedure :: complete_kinematics => sf_test_spectrum_complete_kinematics <>= subroutine sf_test_spectrum_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(sf_test_spectrum_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default), dimension(2) :: xb1 if (map) then x = r**2 f = 4 * r(1) * r(2) else x = r f = 1 end if xb = 1 - x if (sf_int%data%with_radiation) then call sf_int%split_momenta (x, xb) else call sf_int%reduce_momenta (x) end if select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end subroutine sf_test_spectrum_complete_kinematics @ %def sf_test_spectrum_complete_kinematics @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => sf_test_spectrum_inverse_kinematics <>= subroutine sf_test_spectrum_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(sf_test_spectrum_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default), dimension(2) :: xb1 logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then r = sqrt (x) f = 4 * r(1) * r(2) else r = x f = 1 end if rb = 1 - r if (set_mom) then if (sf_int%data%with_radiation) then call sf_int%split_momenta (x, xb) else call sf_int%reduce_momenta (x) end if select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine sf_test_spectrum_inverse_kinematics @ %def sf_test_spectrum_inverse_kinematics @ Apply the structure function. The matrix element becomes unity and the application always succeeds. <>= procedure :: apply => sf_test_spectrum_apply <>= subroutine sf_test_spectrum_apply (sf_int, scale, rescale, i_sub, fill_sub) class(sf_test_spectrum_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub logical, intent(in), optional :: fill_sub call sf_int%set_matrix_element & (cmplx (1._default, kind=default)) sf_int%status = SF_EVALUATED end subroutine sf_test_spectrum_apply @ %def sf_test_spectrum_apply @ \subsection{Test implementation: generator spectrum} A generator for two beams, no radiation (for simplicity). \subsubsection{Configuration data} For simplicity, the spectrum contains two mirror images of the previous structure-function configuration: the incoming and all outgoing particles are test scalars. We have two versions, one with radiated particles, one without. <>= type, extends (sf_data_t) :: sf_test_generator_data_t class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in type(flavor_t) :: flv_out type(flavor_t) :: flv_rad real(default) :: m = 0 contains <> end type sf_test_generator_data_t @ %def sf_test_generator_data_t @ Output. <>= procedure :: write => sf_test_generator_data_write <>= subroutine sf_test_generator_data_write (data, unit, verbose) class(sf_test_generator_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "SF test generator data:" write (u, "(3x,A,A)") "model = ", char (data%model%get_name ()) write (u, "(3x,A)", advance="no") "incoming = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A)", advance="no") "outgoing = " call data%flv_out%write (u); write (u, *) write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m end subroutine sf_test_generator_data_write @ %def sf_test_generator_data_write @ Initialization. <>= procedure :: init => sf_test_generator_data_init <>= subroutine sf_test_generator_data_init (data, model, pdg_in) class(sf_test_generator_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in data%model => model if (pdg_array_get (pdg_in, 1) /= 25) then call msg_fatal ("Test generator: input flavor must be 's'") end if call data%flv_in%init (25, model) data%m = data%flv_in%get_mass () call data%flv_out%init (25, model) end subroutine sf_test_generator_data_init @ %def sf_test_generator_data_init @ This structure function is a generator. <>= procedure :: is_generator => sf_test_generator_data_is_generator <>= function sf_test_generator_data_is_generator (data) result (flag) class(sf_test_generator_data_t), intent(in) :: data logical :: flag flag = .true. end function sf_test_generator_data_is_generator @ %def sf_test_generator_data_is_generator @ Return the number of parameters: 2, since we have only collinear splitting here. <>= procedure :: get_n_par => sf_test_generator_data_get_n_par <>= function sf_test_generator_data_get_n_par (data) result (n) class(sf_test_generator_data_t), intent(in) :: data integer :: n n = 2 end function sf_test_generator_data_get_n_par @ %def sf_test_generator_data_get_n_par @ Return the outgoing particle PDG codes: 25 <>= procedure :: get_pdg_out => sf_test_generator_data_get_pdg_out <>= subroutine sf_test_generator_data_get_pdg_out (data, pdg_out) class(sf_test_generator_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = 25 pdg_out(2) = 25 end subroutine sf_test_generator_data_get_pdg_out @ %def sf_test_generator_data_get_pdg_out @ Allocate the matching interaction. <>= procedure :: allocate_sf_int => & sf_test_generator_data_allocate_sf_int <>= subroutine sf_test_generator_data_allocate_sf_int (data, sf_int) class(sf_test_generator_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (sf_test_generator_t :: sf_int) end subroutine sf_test_generator_data_allocate_sf_int @ %def sf_test_generator_data_allocate_sf_int @ \subsubsection{Interaction} <>= type, extends (sf_int_t) :: sf_test_generator_t type(sf_test_generator_data_t), pointer :: data => null () contains <> end type sf_test_generator_t @ %def sf_test_generator_t <>= procedure :: type_string => sf_test_generator_type_string <>= function sf_test_generator_type_string (object) result (string) class(sf_test_generator_t), intent(in) :: object type(string_t) :: string string = "Test Generator" end function sf_test_generator_type_string @ %def sf_test_generator_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => sf_test_generator_write <>= subroutine sf_test_generator_write (object, unit, testflag) class(sf_test_generator_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "SF test generator data: [undefined]" end if end subroutine sf_test_generator_write @ %def sf_test_generator_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_generator_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass. No radiation. <>= procedure :: init => sf_test_generator_init <>= subroutine sf_test_generator_init (sf_int, data) class(sf_test_generator_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(4) :: mask type(helicity_t) :: hel0 type(color_t) :: col0 type(quantum_numbers_t), dimension(4) :: qn mask = quantum_numbers_mask (.false., .false., .false.) select type (data) type is (sf_test_generator_data_t) call sf_int%base_init (mask(1:4), & [data%m**2, data%m**2], & [real(default) :: ], & [data%m**2, data%m**2]) sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_in, col0, hel0) call qn(3)%init (data%flv_out, col0, hel0) call qn(4)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn(1:4)) call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%freeze () end select sf_int%status = SF_INITIAL end subroutine sf_test_generator_init @ %def sf_test_generator_init @ This structure function is a generator. <>= procedure :: is_generator => sf_test_generator_is_generator <>= function sf_test_generator_is_generator (sf_int) result (flag) class(sf_test_generator_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function sf_test_generator_is_generator @ %def sf_test_generator_is_generator @ Generate free parameters. This mock generator always produces the nubmers 0.8 and 0.5. <>= procedure :: generate_free => sf_test_generator_generate_free <>= subroutine sf_test_generator_generate_free (sf_int, r, rb, x_free) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free r = [0.8, 0.5] rb= 1 - r x_free = x_free * product (r) end subroutine sf_test_generator_generate_free @ %def sf_test_generator_generate_free @ Recover momentum fractions. Since the x values are free, we also set the [[x_free]] parameter. <>= procedure :: recover_x => sf_test_generator_recover_x <>= subroutine sf_test_generator_recover_x (sf_int, x, xb, x_free) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb) if (present (x_free)) x_free = x_free * product (x) end subroutine sf_test_generator_recover_x @ %def sf_test_generator_recover_x @ Set kinematics. Since this is a generator, just transfer input to output. <>= procedure :: complete_kinematics => sf_test_generator_complete_kinematics <>= subroutine sf_test_generator_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map x = r xb= rb f = 1 call sf_int%reduce_momenta (x) end subroutine sf_test_generator_complete_kinematics @ %def sf_test_generator_complete_kinematics @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => sf_test_generator_inverse_kinematics <>= subroutine sf_test_generator_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta r = x rb= xb f = 1 if (set_mom) call sf_int%reduce_momenta (x) end subroutine sf_test_generator_inverse_kinematics @ %def sf_test_generator_inverse_kinematics @ Apply the structure function. The matrix element becomes unity and the application always succeeds. <>= procedure :: apply => sf_test_generator_apply <>= subroutine sf_test_generator_apply (sf_int, scale, rescale, i_sub, fill_sub) class(sf_test_generator_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub logical, intent(in), optional :: fill_sub call sf_int%set_matrix_element & (cmplx (1._default, kind=default)) sf_int%status = SF_EVALUATED end subroutine sf_test_generator_apply @ %def sf_test_generator_apply @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_base_1, "sf_base_1", & "structure function configuration", & u, results) <>= public :: sf_base_1 <>= subroutine sf_base_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_base_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") call model%init_test () pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle code:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_1" end subroutine sf_base_1 @ %def sf_base_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the test structure function. <>= call test (sf_base_2, "sf_base_2", & "structure function instance", & u, results) <>= public :: sf_base_2 <>= subroutine sf_base_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () pdg_in = 25 call flv%init (25, model) call reset_interaction_counter () allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics for x=1" write (u, "(A)") r = 1 rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5" write (u, "(A)") r = 0.5_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics with mapping for r=0.8" write (u, "(A)") r = 0.8_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics for x=0.64 and evaluate" write (u, "(A)") x = 0.64_default call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_2" end subroutine sf_base_2 @ %def sf_base_2 @ \subsubsection{Collinear kinematics} Scan over the possibilities for mass assignment and on-shell projections, collinear case. <>= call test (sf_base_3, "sf_base_3", & "alternatives for collinear kinematics", & u, results) <>= public :: sf_base_3 <>= subroutine sf_base_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_3" write (u, "(A)") "* Purpose: check various kinematical setups" write (u, "(A)") "* for collinear structure-function splitting." write (u, "(A)") " (two masses equal, one zero)" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () pdg_in = 25 call flv%init (25, model) call reset_interaction_counter () allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%write (u) allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set radiated mass to zero" sf_int%mr2 = 0 sf_int%mo2 = sf_int%mi2 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set outgoing mass to zero" sf_int%mr2 = sf_int%mi2 sf_int%mo2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set incoming mass to zero" k = vector4_moving (E, E, 3) call sf_int%seed_kinematics ([k]) sf_int%mr2 = sf_int%mi2 sf_int%mo2 = sf_int%mi2 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set all masses to zero" sf_int%mr2 = 0 sf_int%mo2 = 0 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_3" end subroutine sf_base_3 @ %def sf_base_3 @ \subsubsection{Non-collinear kinematics} Scan over the possibilities for mass assignment and on-shell projections, non-collinear case. <>= call test (sf_base_4, "sf_base_4", & "alternatives for non-collinear kinematics", & u, results) <>= public :: sf_base_4 <>= subroutine sf_base_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_4" write (u, "(A)") "* Purpose: check various kinematical setups" write (u, "(A)") "* for free structure-function splitting." write (u, "(A)") " (two masses equal, one zero)" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () pdg_in = 25 call flv%init (25, model) call reset_interaction_counter () allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in, collinear=.false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%write (u) allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set radiated mass to zero" sf_int%mr2 = 0 sf_int%mo2 = sf_int%mi2 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set outgoing mass to zero" sf_int%mr2 = sf_int%mi2 sf_int%mo2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set incoming mass to zero" k = vector4_moving (E, E, 3) call sf_int%seed_kinematics ([k]) sf_int%mr2 = sf_int%mi2 sf_int%mo2 = sf_int%mi2 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set all masses to zero" sf_int%mr2 = 0 sf_int%mo2 = 0 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Re-Initialize structure-function object with Q bounds" call reset_interaction_counter () select type (data) type is (sf_test_data_t) call data%init (model, pdg_in, collinear=.false., & qbounds = [1._default, 100._default]) end select call sf_int%init (data) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_4" end subroutine sf_base_4 @ %def sf_base_4 @ \subsubsection{Pair spectrum} Construct and display a structure function object for a pair spectrum (a structure function involving two particles simultaneously). <>= call test (sf_base_5, "sf_base_5", & "pair spectrum with radiation", & u, results) <>= public :: sf_base_5 <>= subroutine sf_base_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t), dimension(2) :: k type(vector4_t), dimension(4) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_5" write (u, "(A)") "* Purpose: initialize and fill & &a pair spectrum object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () allocate (sf_test_spectrum_data_t :: data) select type (data) type is (sf_test_spectrum_data_t) call data%init (model, pdg_in, with_radiation=.true.) end select write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 write (u, "(A)") write (u, "(A)") "* Initialize spectrum object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momenta with sqrts=1000" E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics (k) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.4,0.8" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.4_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics with mapping for r=0.6,0.8" write (u, "(A)") r = [0.6_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call reset_interaction_counter () call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%seed_kinematics (k) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics for x=0.36,0.64 & &and evaluate" write (u, "(A)") x = [0.36_default, 0.64_default] xb = 1 - x call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_5" end subroutine sf_base_5 @ %def sf_base_5 @ \subsubsection{Pair spectrum without radiation} Construct and display a structure function object for a pair spectrum (a structure function involving two particles simultaneously). <>= call test (sf_base_6, "sf_base_6", & "pair spectrum without radiation", & u, results) <>= public :: sf_base_6 <>= subroutine sf_base_6 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_6" write (u, "(A)") "* Purpose: initialize and fill & &a pair spectrum object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () allocate (sf_test_spectrum_data_t :: data) select type (data) type is (sf_test_spectrum_data_t) call data%init (model, pdg_in, with_radiation=.false.) end select write (u, "(A)") "* Initialize spectrum object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) write (u, "(A)") "* Initialize incoming momenta with sqrts=1000" E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics (k) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.4,0.8" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.4_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call reset_interaction_counter () call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%seed_kinematics (k) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics for x=0.4,0.8 & &and evaluate" write (u, "(A)") x = [0.4_default, 0.8_default] xb = 1 - x call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_6" end subroutine sf_base_6 @ %def sf_base_6 @ \subsubsection{Direct access to structure function} Probe a structure function directly. <>= call test (sf_base_7, "sf_base_7", & "direct access", & u, results) <>= public :: sf_base_7 <>= subroutine sf_base_7 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int real(default), dimension(:), allocatable :: value write (u, "(A)") "* Test output: sf_base_7" write (u, "(A)") "* Purpose: check direct access method" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select call data%allocate_sf_int (sf_int) call sf_int%init (data) write (u, "(A)") "* Probe structure function: states" write (u, "(A)") write (u, "(A,I0)") "n_states = ", sf_int%get_n_states () write (u, "(A,I0)") "n_in = ", sf_int%get_n_in () write (u, "(A,I0)") "n_rad = ", sf_int%get_n_rad () write (u, "(A,I0)") "n_out = ", sf_int%get_n_out () write (u, "(A)") write (u, "(A)", advance="no") "state(1) = " call quantum_numbers_write (sf_int%get_state (1), u) write (u, *) allocate (value (sf_int%get_n_states ())) call sf_int%compute_values (value, & E=[500._default], x=[0.5_default], xb=[0.5_default], scale=0._default) write (u, "(A)") write (u, "(A)", advance="no") "value (E=500, x=0.5) =" write (u, "(9(1x," // FMT_19 // "))") value call sf_int%compute_values (value, & x=[0.1_default], xb=[0.9_default], scale=0._default) write (u, "(A)") write (u, "(A)", advance="no") "value (E=500, x=0.1) =" write (u, "(9(1x," // FMT_19 // "))") value write (u, "(A)") write (u, "(A)") "* Initialize spectrum object" write (u, "(A)") deallocate (value) call sf_int%final () deallocate (sf_int) deallocate (data) allocate (sf_test_spectrum_data_t :: data) select type (data) type is (sf_test_spectrum_data_t) call data%init (model, pdg_in, with_radiation=.false.) end select call data%allocate_sf_int (sf_int) call sf_int%init (data) write (u, "(A)") "* Probe spectrum: states" write (u, "(A)") write (u, "(A,I0)") "n_states = ", sf_int%get_n_states () write (u, "(A,I0)") "n_in = ", sf_int%get_n_in () write (u, "(A,I0)") "n_rad = ", sf_int%get_n_rad () write (u, "(A,I0)") "n_out = ", sf_int%get_n_out () write (u, "(A)") write (u, "(A)", advance="no") "state(1) = " call quantum_numbers_write (sf_int%get_state (1), u) write (u, *) allocate (value (sf_int%get_n_states ())) call sf_int%compute_value (1, value(1), & E = [500._default, 500._default], & x = [0.5_default, 0.6_default], & xb= [0.5_default, 0.4_default], & scale = 0._default) write (u, "(A)") write (u, "(A)", advance="no") "value (E=500,500, x=0.5,0.6) =" write (u, "(9(1x," // FMT_19 // "))") value write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_7" end subroutine sf_base_7 @ %def sf_base_7 @ \subsubsection{Structure function chain configuration} <>= call test (sf_base_8, "sf_base_8", & "structure function chain configuration", & u, results) <>= public :: sf_base_8 <>= subroutine sf_base_8 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_spectrum type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_chain_t) :: sf_chain write (u, "(A)") "* Test output: sf_base_8" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_spectrum_data_t :: data_spectrum) select type (data_spectrum) type is (sf_test_spectrum_data_t) call data_spectrum%init (model, pdg_in, with_radiation=.true.) end select write (u, "(A)") "* Set up chain with beams only" write (u, "(A)") call sf_chain%init (beam_data) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with structure function" write (u, "(A)") allocate (sf_config (1)) call sf_config(1)%init ([1], data_strfun) call sf_chain%init (beam_data, sf_config) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with spectrum and structure function" write (u, "(A)") deallocate (sf_config) allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_spectrum) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_8" end subroutine sf_base_8 @ %def sf_base_8 @ \subsubsection{Structure function instance configuration} We create a structure-function chain instance which implements a configured structure-function chain. We link the momentum entries in the interactions and compute kinematics. We do not actually connect the interactions and create evaluators. We skip this step and manually advance the status of the chain instead. <>= call test (sf_base_9, "sf_base_9", & "structure function chain instance", & u, results) <>= public :: sf_base_9 <>= subroutine sf_base_9 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_spectrum type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance type(sf_channel_t), dimension(2) :: sf_channel type(vector4_t), dimension(2) :: p integer :: j write (u, "(A)") "* Test output: sf_base_9" write (u, "(A)") "* Purpose: set up a structure-function chain & &and create an instance" write (u, "(A)") "* compute kinematics" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_spectrum_data_t :: data_spectrum) select type (data_spectrum) type is (sf_test_spectrum_data_t) call data_spectrum%init (model, pdg_in, with_radiation=.true.) end select write (u, "(A)") "* Set up chain with beams only" write (u, "(A)") call sf_chain%init (beam_data) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics (1, [real(default) ::]) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%get_out_momenta (p) write (u, "(A)") write (u, "(A)") "* Outgoing momenta:" do j = 1, 2 write (u, "(A)") call vector4_write (p(j), u) end do call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with structure function" write (u, "(A)") allocate (sf_config (1)) call sf_config(1)%init ([1], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (1) call sf_channel(1)%activate_mapping ([1]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics (1, [0.8_default]) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%get_out_momenta (p) write (u, "(A)") write (u, "(A)") "* Outgoing momenta:" do j = 1, 2 write (u, "(A)") call vector4_write (p(j), u) end do call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with spectrum and structure function" write (u, "(A)") deallocate (sf_config) allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_spectrum) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics & (1, [0.5_default, 0.6_default, 0.8_default]) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%get_out_momenta (p) write (u, "(A)") write (u, "(A)") "* Outgoing momenta:" do j = 1, 2 write (u, "(A)") call vector4_write (p(j), u) end do call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_9" end subroutine sf_base_9 @ %def sf_base_9 @ \subsubsection{Structure function chain mappings} Set up a structure function chain instance with a pair of single-particle structure functions. We test different global mappings for this setup. Again, we skip evaluators. <>= call test (sf_base_10, "sf_base_10", & "structure function chain mapping", & u, results) <>= public :: sf_base_10 <>= subroutine sf_base_10 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance type(sf_channel_t), dimension(2) :: sf_channel real(default), dimension(2) :: x_saved write (u, "(A)") "* Test output: sf_base_10" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") "* and check mappings" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select write (u, "(A)") "* Set up chain with structure function pair & &and standard mapping" write (u, "(A)") allocate (sf_config (2)) call sf_config(1)%init ([1], data_strfun) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (2) call sf_channel(1)%set_s_mapping ([1,2]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default]) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Invert the kinematics calculation" write (u, "(A)") x_saved = sf_chain_instance%x call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%set_s_mapping ([1, 2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_10" end subroutine sf_base_10 @ %def sf_base_10 @ \subsubsection{Structure function chain evaluation} Here, we test the complete workflow for structure-function chains. First, we create the template chain, then initialize an instance. We set up links, mask, and evaluators. Finally, we set kinematics and evaluate the matrix elements and their products. <>= call test (sf_base_11, "sf_base_11", & "structure function chain evaluation", & u, results) <>= public :: sf_base_11 <>= subroutine sf_base_11 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_spectrum type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance type(sf_channel_t), dimension(2) :: sf_channel type(particle_set_t) :: pset type(interaction_t), pointer :: int logical :: ok write (u, "(A)") "* Test output: sf_base_11" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") "* create an instance and evaluate" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_spectrum_data_t :: data_spectrum) select type (data_spectrum) type is (sf_test_spectrum_data_t) call data_spectrum%init (model, pdg_in, with_radiation=.true.) end select write (u, "(A)") "* Set up chain with beams only" write (u, "(A)") call sf_chain%init (beam_data) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () call sf_chain_instance%compute_kinematics (1, [real(default) ::]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) int => sf_chain_instance%get_out_int_ptr () call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true.) call sf_chain_instance%final () write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover chain:" write (u, "(A)") call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () int => sf_chain_instance%get_out_int_ptr () call pset%fill_interaction (int, 2, check_match=.false.) call sf_chain_instance%recover_kinematics (1) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call pset%final () call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Set up chain with structure function" write (u, "(A)") allocate (sf_config (1)) call sf_config(1)%init ([1], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (1) call sf_channel(1)%activate_mapping ([1]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () call sf_chain_instance%compute_kinematics (1, [0.8_default]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) int => sf_chain_instance%get_out_int_ptr () call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true.) call sf_chain_instance%final () write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover chain:" write (u, "(A)") call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (1) call sf_channel(1)%activate_mapping ([1]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () int => sf_chain_instance%get_out_int_ptr () call pset%fill_interaction (int, 2, check_match=.false.) call sf_chain_instance%recover_kinematics (1) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call pset%final () call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Set up chain with spectrum and structure function" write (u, "(A)") deallocate (sf_config) allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_spectrum) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () call sf_chain_instance%compute_kinematics & (1, [0.5_default, 0.6_default, 0.8_default]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) int => sf_chain_instance%get_out_int_ptr () call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true.) call sf_chain_instance%final () write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover chain:" write (u, "(A)") call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () int => sf_chain_instance%get_out_int_ptr () call pset%fill_interaction (int, 2, check_match=.false.) call sf_chain_instance%recover_kinematics (1) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call pset%final () call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_11" end subroutine sf_base_11 @ %def sf_base_11 @ \subsubsection{Multichannel case} We set up a structure-function chain as before, but with three different parameterizations. The first instance is without mappings, the second one with single-particle mappings, and the third one with two-particle mappings. <>= call test (sf_base_12, "sf_base_12", & "multi-channel structure function chain", & u, results) <>= public :: sf_base_12 <>= subroutine sf_base_12 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance real(default), dimension(2) :: x_saved real(default), dimension(2,3) :: p_saved type(sf_channel_t), dimension(:), allocatable :: sf_channel write (u, "(A)") "* Test output: sf_base_12" write (u, "(A)") "* Purpose: set up and evaluate a multi-channel & &structure-function chain" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Set up chain with structure function pair & &and three different mappings" write (u, "(A)") allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 3) call allocate_sf_channels (sf_channel, n_channel = 3, n_strfun = 2) ! channel 1: no mapping call sf_chain_instance%set_channel (1, sf_channel(1)) ! channel 2: single-particle mappings call sf_channel(2)%activate_mapping ([1,2]) ! call sf_chain_instance%activate_mapping (2, [1,2]) call sf_chain_instance%set_channel (2, sf_channel(2)) ! channel 3: two-particle mapping call sf_channel(3)%set_s_mapping ([1,2]) ! call sf_chain_instance%set_s_mapping (3, [1, 2]) call sf_chain_instance%set_channel (3, sf_channel(3)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () write (u, "(A)") "* Compute kinematics in channel 1 and evaluate" write (u, "(A)") call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Invert the kinematics calculation" write (u, "(A)") x_saved = sf_chain_instance%x call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Compute kinematics in channel 2 and evaluate" write (u, "(A)") p_saved = sf_chain_instance%p call sf_chain_instance%compute_kinematics (2, p_saved(:,2)) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Compute kinematics in channel 3 and evaluate" write (u, "(A)") call sf_chain_instance%compute_kinematics (3, p_saved(:,3)) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_chain_instance%final () call sf_chain%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_12" end subroutine sf_base_12 @ %def sf_base_12 @ \subsubsection{Generated spectrum} Construct and evaluate a structure function object for a pair spectrum which is evaluated as a beam-event generator. <>= call test (sf_base_13, "sf_base_13", & "pair spectrum generator", & u, results) <>= public :: sf_base_13 <>= subroutine sf_base_13 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_base_13" write (u, "(A)") "* Purpose: initialize and fill & &a pair generator object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () allocate (sf_test_generator_data_t :: data) select type (data) type is (sf_test_generator_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize generator object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) write (u, "(A)") "* Generate free r values" write (u, "(A)") x_free = 1 call sf_int%generate_free (r, rb, x_free) write (u, "(A)") "* Initialize incoming momenta with sqrts=1000" E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics (k) write (u, "(A)") write (u, "(A)") "* Complete kinematics" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call reset_interaction_counter () call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%seed_kinematics (k) call sf_int%set_momenta (q, outgoing=.true.) x_free = 1 call sf_int%recover_x (x, xb, x_free) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics & &and evaluate" write (u, "(A)") call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_13" end subroutine sf_base_13 @ %def sf_base_13 @ \subsubsection{Structure function chain evaluation} Here, we test the complete workflow for a structure-function chain with generator. First, we create the template chain, then initialize an instance. We set up links, mask, and evaluators. Finally, we set kinematics and evaluate the matrix elements and their products. <>= call test (sf_base_14, "sf_base_14", & "structure function generator evaluation", & u, results) <>= public :: sf_base_14 <>= subroutine sf_base_14 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_generator type(sf_config_t), dimension(:), allocatable, target :: sf_config real(default), dimension(:), allocatable :: p_in type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance write (u, "(A)") "* Test output: sf_base_14" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") "* create an instance and evaluate" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_generator_data_t :: data_generator) select type (data_generator) type is (sf_test_generator_data_t) call data_generator%init (model, pdg_in) end select write (u, "(A)") "* Set up chain with generator and structure function" write (u, "(A)") allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_generator) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () write (u, "(A)") "* Inject integration parameter" write (u, "(A)") allocate (p_in (sf_chain%get_n_bound ()), source = 0.9_default) write (u, "(A,9(1x,F10.7))") "p_in =", p_in write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_chain_instance%compute_kinematics (1, p_in) call sf_chain_instance%evaluate (scale=0._default) call sf_chain_instance%write (u) write (u, "(A)") write (u, "(A)") "* Extract integration parameter" write (u, "(A)") call sf_chain_instance%get_mcpar (1, p_in) write (u, "(A,9(1x,F10.7))") "p_in =", p_in call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_14" end subroutine sf_base_14 @ %def sf_base_14 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Photon radiation: ISR} <<[[sf_isr.f90]]>>= <> module sf_isr <> <> use io_units use constants, only: pi use format_defs, only: FMT_15, FMT_19 use numeric_utils use diagnostics use physics_defs, only: PHOTON use lorentz use sm_physics, only: Li2 use pdg_arrays use model_data use flavors use colors use quantum_numbers use polarizations use sf_aux use sf_mappings use sf_base use electron_pdfs <> <> <> <> contains <> end module sf_isr @ %def sf_isr @ \subsection{Physics} The ISR structure function is in the most crude approximation (LLA without $\alpha$ corrections, i.e. $\epsilon^0$) \begin{equation} f_0(x) = \epsilon (1-x)^{-1+\epsilon} \qquad\text{with}\qquad \epsilon = \frac{\alpha}{\pi}q_e^2\ln\frac{s}{m^2}, \end{equation} where $m$ is the mass of the incoming (and outgoing) particle, which is initially assumed on-shell. In $f_0(x)$, there is an integrable singularity at $x=1$ which does not spoil the integration, but would lead to an unbounded $f_{\rm max}$. Therefore, we map this singularity like \begin{equation}\label{ISR-mapping} x = 1 - (1-x')^{1/\epsilon} \end{equation} such that \begin{equation} \int dx\,f_0(x) = \int dx' \end{equation} For the detailed form of the QED ISR structure function cf. Chap.~\ref{chap:qed_pdf}. \subsection{Implementation} In the concrete implementation, the zeroth order mapping (\ref{ISR-mapping}) is implemented, and the Jacobian is equal to $f_i(x)/f_0(x)$. This can be written as \begin{align} \frac{f_0(x)}{f_0(x)} &= 1 \\ \frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon - \frac{1-x^2}{2(1-x')} \\ \begin{split}\label{ISR-f2} \frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon + \frac{27 - 8\pi^2}{96}\epsilon^2 - \frac{1-x^2}{2(1-x')} \\ &\quad - \frac{(1+3x^2)\ln x + (1-x)\left(4(1+x)\ln(1-x) + 5 + x\right)}{8(1-x')}\epsilon \end{split} \end{align} %' For $x=1$ (i.e., numerically indistinguishable from $1$), this reduces to \begin{align} \frac{f_0(x)}{f_0(x)} &= 1 \\ \frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon \\ \frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon + \frac{27 - 8\pi^2}{96}\epsilon^2 \end{align} The last line in (\ref{ISR-f2}) is zero for \begin{equation} x_{\rm min} = 0.00714053329734592839549879772019 \end{equation} (Mathematica result), independent of $\epsilon$. For $x$ values less than this we ignore this correction because of the logarithmic singularity which should in principle be resummed. \subsection{The ISR data block} <>= public :: isr_data_t <>= type, extends (sf_data_t) :: isr_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:), allocatable :: flv_in type(qed_pdf_t) :: pdf real(default) :: alpha = 0 real(default) :: q_max = 0 real(default) :: real_mass = 0 real(default) :: mass = 0 real(default) :: eps = 0 real(default) :: log = 0 logical :: recoil = .false. logical :: keep_energy = .true. integer :: order = 3 integer :: error = NONE contains <> end type isr_data_t @ %def isr_data_t @ Error codes <>= integer, parameter :: NONE = 0 integer, parameter :: ZERO_MASS = 1 integer, parameter :: Q_MAX_TOO_SMALL = 2 integer, parameter :: EPS_TOO_LARGE = 3 integer, parameter :: INVALID_ORDER = 4 integer, parameter :: CHARGE_MIX = 5 integer, parameter :: CHARGE_ZERO = 6 integer, parameter :: MASS_MIX = 7 @ Generate flavor-dependent ISR data: <>= procedure :: init => isr_data_init <>= subroutine isr_data_init (data, model, pdg_in, alpha, q_max, & mass, order, recoil, keep_energy) class(isr_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in real(default), intent(in) :: alpha real(default), intent(in) :: q_max real(default), intent(in), optional :: mass integer, intent(in), optional :: order logical, intent(in), optional :: recoil logical, intent(in), optional :: keep_energy integer :: i, n_flv real(default) :: charge data%model => model n_flv = pdg_array_get_length (pdg_in) allocate (data%flv_in (n_flv)) do i = 1, n_flv call data%flv_in(i)%init (pdg_array_get (pdg_in, i), model) end do data%alpha = alpha data%q_max = q_max if (present (order)) then call data%set_order (order) end if if (present (recoil)) then data%recoil = recoil end if if (present (keep_energy)) then data%keep_energy = keep_energy end if data%real_mass = data%flv_in(1)%get_mass () if (present (mass)) then if (mass > 0) then data%mass = mass else data%mass = data%real_mass if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if else data%mass = data%real_mass if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if if (vanishes (data%mass)) then data%error = ZERO_MASS; return else if (data%mass >= data%q_max) then data%error = Q_MAX_TOO_SMALL; return end if data%log = log (1 + (data%q_max / data%mass)**2) charge = data%flv_in(1)%get_charge () if (any (abs (data%flv_in%get_charge ()) /= abs (charge))) then data%error = CHARGE_MIX; return else if (charge == 0) then data%error = CHARGE_ZERO; return end if data%eps = data%alpha / pi * charge ** 2 & * (2 * log (data%q_max / data%mass) - 1) if (data%eps > 1) then data%error = EPS_TOO_LARGE; return end if call data%pdf%init & (data%mass, data%alpha, charge, data%q_max, data%order) end subroutine isr_data_init @ %def isr_data_init @ Explicitly set ISR order <>= procedure :: set_order => isr_data_set_order <>= elemental subroutine isr_data_set_order (data, order) class(isr_data_t), intent(inout) :: data integer, intent(in) :: order if (order < 0 .or. order > 3) then data%error = INVALID_ORDER else data%order = order end if end subroutine isr_data_set_order @ %def isr_data_set_order @ Handle error conditions. Should always be done after initialization, unless we are sure everything is ok. <>= procedure :: check => isr_data_check <>= subroutine isr_data_check (data) class(isr_data_t), intent(in) :: data select case (data%error) case (ZERO_MASS) call msg_fatal ("ISR: Particle mass is zero") case (Q_MAX_TOO_SMALL) call msg_fatal ("ISR: Particle mass exceeds Qmax") case (EPS_TOO_LARGE) call msg_fatal ("ISR: Expansion parameter too large, " // & "perturbative expansion breaks down") case (INVALID_ORDER) call msg_error ("ISR: LLA order invalid (valid values are 0,1,2,3)") case (MASS_MIX) call msg_fatal ("ISR: Incoming particle masses must be uniform") case (CHARGE_MIX) call msg_fatal ("ISR: Incoming particle charges must be uniform") case (CHARGE_ZERO) call msg_fatal ("ISR: Incoming particle must be charged") end select end subroutine isr_data_check @ %def isr_data_check @ Output <>= procedure :: write => isr_data_write <>= subroutine isr_data_write (data, unit, verbose) class(isr_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "ISR data:" if (allocated (data%flv_in)) then write (u, "(3x,A)", advance="no") " flavor = " do i = 1, size (data%flv_in) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_in(i)%write (u) end do write (u, *) write (u, "(3x,A," // FMT_19 // ")") " alpha = ", data%alpha write (u, "(3x,A," // FMT_19 // ")") " q_max = ", data%q_max write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass write (u, "(3x,A," // FMT_19 // ")") " eps = ", data%eps write (u, "(3x,A," // FMT_19 // ")") " log = ", data%log write (u, "(3x,A,I2)") " order = ", data%order write (u, "(3x,A,L2)") " recoil = ", data%recoil write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy else write (u, "(3x,A)") "[undefined]" end if end subroutine isr_data_write @ %def isr_data_write @ For ISR, there is the option to generate transverse momentum is generated. Hence, there can be up to three parameters, $x$, and two angles. <>= procedure :: get_n_par => isr_data_get_n_par <>= function isr_data_get_n_par (data) result (n) class(isr_data_t), intent(in) :: data integer :: n if (data%recoil) then n = 3 else n = 1 end if end function isr_data_get_n_par @ %def isr_data_get_n_par @ Return the outgoing particles PDG codes. For ISR, these are identical to the incoming particles. <>= procedure :: get_pdg_out => isr_data_get_pdg_out <>= subroutine isr_data_get_pdg_out (data, pdg_out) class(isr_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = data%flv_in%get_pdg () end subroutine isr_data_get_pdg_out @ %def isr_data_get_pdg_out @ Return the [[eps]] value. We need it for an appropriate mapping of structure-function parameters. <>= procedure :: get_eps => isr_data_get_eps <>= function isr_data_get_eps (data) result (eps) class(isr_data_t), intent(in) :: data real(default) :: eps eps = data%eps end function isr_data_get_eps @ %def isr_data_get_eps @ Allocate the interaction record. <>= procedure :: allocate_sf_int => isr_data_allocate_sf_int <>= subroutine isr_data_allocate_sf_int (data, sf_int) class(isr_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (isr_t :: sf_int) end subroutine isr_data_allocate_sf_int @ %def isr_data_allocate_sf_int @ \subsection{The ISR object} The [[isr_t]] data type is a $1\to 2$ interaction, i.e., we allow for single-photon emission only (but use the multi-photon resummed radiator function). The particles are ordered as (incoming, photon, outgoing). There is no need to handle several flavors (and data blocks) in parallel, since ISR is always applied immediately after beam collision. (ISR for partons is accounted for by the PDFs themselves.) Polarization is carried through, i.e., we retain the polarization of the incoming particle and treat the emitted photon as unpolarized. Color is trivially carried through. This implies that particles 1 and 3 should be locked together. For ISR we don't need the q variable. <>= public :: isr_t <>= type, extends (sf_int_t) :: isr_t private type(isr_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: xb= 0 contains <> end type isr_t @ %def isr_t @ Type string: has to be here, but there is no string variable on which ISR depends. Hence, a dummy routine. <>= procedure :: type_string => isr_type_string <>= function isr_type_string (object) result (string) class(isr_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "ISR: e+ e- ISR spectrum" else string = "ISR: [undefined]" end if end function isr_type_string @ %def isr_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => isr_write <>= subroutine isr_write (object, unit, testflag) class(isr_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_15 // ")") "x =", object%x write (u, "(3x,A," // FMT_15 // ")") "xb=", object%xb end if call object%base_write (u, testflag) else write (u, "(1x,A)") "ISR data: [undefined]" end if end subroutine isr_write @ %def isr_write @ Explicitly set ISR order (for unit test). <>= procedure :: set_order => isr_set_order <>= subroutine isr_set_order (object, order) class(isr_t), intent(inout) :: object integer, intent(in) :: order call object%data%set_order (order) call object%data%pdf%set_order (order) end subroutine isr_set_order @ %def isr_set_order @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ were trivial. The ISR structure function allows for a straightforward mapping of the unit interval. So, to leading order, the structure function value is unity, but the $x$ value is transformed. Higher orders affect the function value. The structure function implementation applies the above mapping to the input (random) number [[r]] to generate the momentum fraction [[x]] and the function value [[f]]. For numerical stability reasons, we also output [[xb]], which is $\bar x=1-x$. For the ISR structure function, the mapping Jacobian cancels the structure function (to order zero). We apply the cancellation explicitly, therefore both the Jacobian [[f]] and the zeroth-order value (see the [[apply]] method) are unity if mapping is turned on. If mapping is turned off, the Jacobian [[f]] includes the value of the (zeroth-order) structure function, and strongly peaked. <>= procedure :: complete_kinematics => isr_complete_kinematics <>= subroutine isr_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default) :: eps eps = sf_int%data%eps if (map) then call map_power_1 (sf_int%xb, f, rb(1), eps) else sf_int%xb = rb(1) if (rb(1) > 0) then f = 1 else f = 0 end if end if sf_int%x = 1 - sf_int%xb x(1) = sf_int%x xb(1) = sf_int%xb if (size (x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS) sf_int%x = 0 sf_int%xb= 0 f = 0 end select end subroutine isr_complete_kinematics @ %def isr_complete_kinematics @ Overriding the default method: we compute the [[x]] array from the momentum configuration. In the specific case of ISR, we also set the internally stored $x$ and $\bar x$ values, so they can be used in the following routine. <>= procedure :: recover_x => sf_isr_recover_x <>= subroutine sf_isr_recover_x (sf_int, x, xb, x_free) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) sf_int%xb = xb(1) end subroutine sf_isr_recover_x @ %def sf_isr_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. For extracting $x$, we rely on the stored $\bar x$ value, since the $x$ value in the argument is likely imprecise. This means that either [[complete_kinematics]] or [[recover_x]] must be called first, for the current sampling point (but maybe another channel). <>= procedure :: inverse_kinematics => isr_inverse_kinematics <>= subroutine isr_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: eps logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta eps = sf_int%data%eps if (map) then call map_power_inverse_1 (xb(1), f, rb(1), eps) else rb(1) = xb(1) if (rb(1) > 0) then f = 1 else f = 0 end if end if r(1) = 1 - rb(1) if (size(r) == 3) then r(2:3) = x(2:3) rb(2:3)= xb(2:3) end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS) r = 0 rb= 0 f = 0 end select end if end subroutine isr_inverse_kinematics @ %def isr_inverse_kinematics @ <>= procedure :: init => isr_init <>= subroutine isr_init (sf_int, data) class(isr_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask integer, dimension(3) :: hel_lock type(polarization_t), target :: pol type(quantum_numbers_t), dimension(1) :: qn_fc type(flavor_t) :: flv_photon type(color_t) :: col_photon type(quantum_numbers_t) :: qn_hel, qn_photon, qn type(polarization_iterator_t) :: it_hel real(default) :: m2 integer :: i mask = quantum_numbers_mask (.false., .false., & mask_h = [.false., .true., .false.]) hel_lock = [3, 0, 1] select type (data) type is (isr_data_t) m2 = data%mass**2 call sf_int%base_init (mask, [m2], [0._default], [m2], & hel_lock = hel_lock) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col_photon%init () call qn_photon%init (flv_photon, col_photon) call qn_photon%tag_radiated () do i = 1, size (data%flv_in) call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init (& flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) call sf_int%add_state ([qn, qn_photon, qn]) call it_hel%advance () end do ! call pol%final () !!! Obsolete end do call sf_int%freeze () if (data%keep_energy) then sf_int%on_shell_mode = KEEP_ENERGY else sf_int%on_shell_mode = KEEP_MOMENTUM end if call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) sf_int%status = SF_INITIAL end select end subroutine isr_init @ %def isr_init @ \subsection{ISR application} For ISR, we could in principle compute kinematics and function value in a single step. In order to be able to reweight matrix elements including structure functions we split kinematics and structure function calculation. The structure function works on a single beam, assuming that the input momentum has been set. For the structure-function evaluation, we rely on the fact that the power mapping, which we apply in the kinematics method (if the [[map]] flag is set), has a Jacobian which is just the inverse lowest-order structure function. With mapping active, the two should cancel exactly. After splitting momenta, we set the outgoing momenta on-shell. We choose to conserve momentum, so energy conservation may be violated. <>= procedure :: apply => isr_apply <>= subroutine isr_apply (sf_int, scale, rescale, i_sub, fill_sub) class(isr_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub logical, intent(in), optional :: fill_sub real(default) :: f, finv, x, xb, eps, rb real(default) :: log_x, log_xb, x_2 associate (data => sf_int%data) eps = sf_int%data%eps x = sf_int%x xb = sf_int%xb call map_power_inverse_1 (xb, finv, rb, eps) if (finv > 0) then f = 1 / finv else f = 0 end if call data%pdf%evolve_qed_pdf (x, xb, rb, f) end associate call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine isr_apply @ %def isr_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_isr_ut.f90]]>>= <> module sf_isr_ut use unit_tests use sf_isr_uti <> <> contains <> end module sf_isr_ut @ %def sf_isr_ut @ <<[[sf_isr_uti.f90]]>>= <> module sf_isr_uti <> <> use io_units use format_defs, only: FMT_12 use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use interactions, only: interaction_pacify_momenta use model_data use sf_aux, only: KEEP_ENERGY use sf_mappings use sf_base use sf_isr <> <> contains <> end module sf_isr_uti @ %def sf_isr_ut @ API: driver for the unit tests below. <>= public :: sf_isr_test <>= subroutine sf_isr_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_isr_test @ %def sf_isr_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_isr_1, "sf_isr_1", & "structure function configuration", & u, results) <>= public :: sf_isr_1 <>= subroutine sf_isr_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_isr_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_qed_test () pdg_in = ELECTRON allocate (isr_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 10._default, & 0.000511_default, order = 3, recoil = .false.) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_1" end subroutine sf_isr_1 @ %def sf_isr_1 @ \subsubsection{Structure function without mapping} Direct ISR evaluation. This is the use case for a double-beam structure function. The parameter pair is mapped in the calling program. <>= call test (sf_isr_2, "sf_isr_2", & "no ISR mapping", & u, results) <>= public :: sf_isr_2 <>= subroutine sf_isr_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, f_isr write (u, "(A)") "* Test output: sf_isr_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () pdg_in = ELECTRON call flv%init (ELECTRON, model) call reset_interaction_counter () allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.9, no ISR mapping, & &collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.9_default rb = 1 - r write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A)") write (u, "(A,9(1x," // FMT_12 // "))") "x =", x write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Invert kinematics" write (u, "(A)") call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Structure-function value, default order" write (u, "(A)") f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Re-evaluate structure function, leading order" write (u, "(A)") select type (sf_int) type is (isr_t) call sf_int%set_order (0) end select call sf_int%apply (scale = 100._default) f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_2" end subroutine sf_isr_2 @ %def sf_isr_2 @ \subsubsection{Structure function with mapping} Apply the optimal ISR mapping. This is the use case for a single-beam structure function. <>= call test (sf_isr_3, "sf_isr_3", & "ISR mapping", & u, results) <>= public :: sf_isr_3 <>= subroutine sf_isr_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, f_isr write (u, "(A)") "* Test output: sf_isr_3" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.7, with ISR mapping, & &collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.7_default rb = 1 - r write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A)") write (u, "(A,9(1x," // FMT_12 // "))") "x =", x write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Invert kinematics" write (u, "(A)") call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Structure-function value, default order" write (u, "(A)") f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Re-evaluate structure function, leading order" write (u, "(A)") select type (sf_int) type is (isr_t) call sf_int%set_order (0) end select call sf_int%apply (scale = 100._default) f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_3" end subroutine sf_isr_3 @ %def sf_isr_3 @ \subsubsection{Non-collinear ISR splitting} Construct and display a structure function object based on the ISR structure function. We blank out numerical fluctuations for 32bit. <>= call test (sf_isr_4, "sf_isr_4", & "ISR non-collinear", & u, results) <>= public :: sf_isr_4 <>= subroutine sf_isr_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, f_isr character(len=80) :: buffer integer :: u_scratch, iostat write (u, "(A)") "* Test output: sf_isr_4" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () write (u, "(A)") write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .true.) end select call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.25, with ISR mapping, " write (u, "(A)") " non-coll., keeping energy" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.5_default, 0.5_default, 0.25_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x and r from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) call sf_int%apply (scale = 10._default) u_scratch = free_unit () open (u_scratch, status="scratch", action = "readwrite") call sf_int%write (u_scratch, testflag = .true.) rewind (u_scratch) do read (u_scratch, "(A)", iostat=iostat) buffer if (iostat /= 0) exit if (buffer(1:25) == " P = 0.000000E+00 9.57") then buffer = replace (buffer, 26, "XXXX") end if if (buffer(1:25) == " P = 0.000000E+00 -9.57") then buffer = replace (buffer, 26, "XXXX") end if write (u, "(A)") buffer end do close (u_scratch) write (u, "(A)") write (u, "(A)") "* Structure-function value" write (u, "(A)") f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_4" end subroutine sf_isr_4 @ %def sf_isr_4 @ \subsubsection{Structure function pair with mapping} Apply the ISR mapping for a ISR pair. structure function. <>= call test (sf_isr_5, "sf_isr_5", & "ISR pair mapping", & u, results) <>= public :: sf_isr_5 <>= subroutine sf_isr_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_mapping_t), allocatable :: mapping class(sf_int_t), dimension(:), allocatable :: sf_int type(vector4_t), dimension(2) :: k real(default) :: E, f_map real(default), dimension(:), allocatable :: p, pb, r, rb, x, xb real(default), dimension(2) :: f, f_isr integer :: i write (u, "(A)") "* Test output: sf_isr_5" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .false.) end select allocate (sf_ip_mapping_t :: mapping) select type (mapping) type is (sf_ip_mapping_t) select type (data) type is (isr_data_t) call mapping%init (eps = data%get_eps ()) end select call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, "(A)") write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") allocate (isr_t :: sf_int (2)) do i = 1, 2 call sf_int(i)%init (data) call sf_int(i)%set_beam_index ([i]) end do write (u, "(A)") "* Initialize incoming momenta with E=500" write (u, "(A)") E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, - sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) do i = 1, 2 call vector4_write (k(i), u) call sf_int(i)%seed_kinematics (k(i:i)) end do write (u, "(A)") write (u, "(A)") "* Set kinematics for p=[0.7,0.4], collinear" write (u, "(A)") allocate (p (2 * data%get_n_par ())) allocate (pb(size (p))) allocate (r (size (p))) allocate (rb(size (p))) allocate (x (size (p))) allocate (xb(size (p))) p = [0.7_default, 0.4_default] pb= 1 - p call mapping%compute (r, rb, f_map, p, pb) write (u, "(A,9(1x," // FMT_12 // "))") "p =", p write (u, "(A,9(1x," // FMT_12 // "))") "pb=", pb write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "fm=", f_map do i = 1, 2 call sf_int(i)%complete_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), & map=.false.) end do write (u, "(A)") write (u, "(A,9(1x," // FMT_12 // "))") "x =", x write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Invert kinematics" write (u, "(A)") do i = 1, 2 call sf_int(i)%inverse_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), & map=.false.) end do call mapping%inverse (r, rb, f_map, p, pb) write (u, "(A,9(1x," // FMT_12 // "))") "p =", p write (u, "(A,9(1x," // FMT_12 // "))") "pb=", pb write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "fm=", f_map write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" call sf_int(1)%apply (scale = 100._default) call sf_int(2)%apply (scale = 100._default) write (u, "(A)") write (u, "(A)") "* Structure function #1" write (u, "(A)") call sf_int(1)%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Structure function #2" write (u, "(A)") call sf_int(2)%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Structure-function value, default order" write (u, "(A)") do i = 1, 2 f_isr(i) = sf_int(i)%get_matrix_element (1) end do write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", & product (f_isr) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", & product (f_isr * f) * f_map write (u, "(A)") write (u, "(A)") "* Cleanup" do i = 1, 2 call sf_int(i)%final () end do call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_5" end subroutine sf_isr_5 @ %def sf_isr_5 @ \clearpage %------------------------------------------------------------------------ \section{EPA} <<[[sf_epa.f90]]>>= <> module sf_epa <> <> use io_units use constants, only: pi use format_defs, only: FMT_17, FMT_19 use numeric_utils use diagnostics use physics_defs, only: PHOTON use lorentz use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use interactions use sf_aux use sf_base <> <> <> <> contains <> end module sf_epa @ %def sf_epa @ \subsection{Physics} The EPA structure function for a photon inside an (elementary) particle $p$ with energy $E$, mass $m$ and charge $q_p$ (e.g., electron) is given by ($\bar x \equiv 1-x$) %% %\cite{Budnev:1974de} %% \bibitem{Budnev:1974de} %% V.~M.~Budnev, I.~F.~Ginzburg, G.~V.~Meledin and V.~G.~Serbo, %% %``The Two photon particle production mechanism. Physical problems. %% %Applications. Equivalent photon approximation,'' %% Phys.\ Rept.\ {\bf 15} (1974) 181. %% %%CITATION = PRPLC,15,181;%% \begin{multline} \label{EPA} f(x) = \frac{\alpha}{\pi}\,q_p^2\, \frac{1}{x}\, \biggl[\left(\bar x + \frac{x^2}{2}\right) \ln\frac{Q^2_{\rm max}}{Q^2_{\rm min}} \\ - \left(1 - \frac{x}{2}\right)^2 \ln\frac{x^2+\frac{Q^2_{\rm max}}{E^2}} {x^2+\frac{Q^2_{\rm min}}{E^2}} - x^2\frac{m^2}{Q^2_{\rm min}} \left(1 - \frac{Q^2_{\rm min}}{Q^2_{\rm max}}\right) \biggr]. \end{multline} If no explicit $Q$ bounds are provided, the kinematical bounds are \begin{align} -Q^2_{\rm max} &= t_0 = -2\bar x(E^2+p\bar p) + 2m^2 \approx -4\bar x E^2, \\ -Q^2_{\rm min} &= t_1 = -2\bar x(E^2-p\bar p) + 2m^2 \approx -\frac{x^2}{\bar x}m^2. \end{align} The second and third terms in (\ref{EPA}) are negative definite (and subleading). Noting that $\bar x + x^2/2$ is bounded between $1/2$ and $1$, we derive that $f(x)$ is always smaller than \begin{equation} \bar f(x) = \frac{\alpha}{\pi}\,q_p^2\,\frac{L - 2\ln x}{x} \qquad\text{where}\qquad L = \ln\frac{\min(4E_{\rm max}^2,Q^2_{\rm max})}{\max(m^2,Q_{\rm min}^2)}, \end{equation} where we allow for explicit $Q$ bounds that narrow the kinematical range. Therefore, we generate this distribution: \begin{equation}\label{EPA-subst} \int_{x_0}^{x_1} dx\,\bar f(x) = C(x_0,x_1)\int_0^1 dx' \end{equation} We set \begin{equation}\label{EPA-x(x')} \ln x = \frac12\left\{ L - \sqrt{L^2 - 4\left[ x'\ln x_1(L-\ln x_1) + \bar x'\ln x_0(L-\ln x_0) \right]} \right\} \end{equation} such that $x(0)=x_0$ and $x(1)=x_1$ and \begin{equation} \frac{dx}{dx'} = \left(\frac{\alpha}{\pi} q_p^2 \right)^{-1} x\frac{C(x_0,x_1)}{L - 2\ln x} \end{equation} with \begin{equation} C(x_0,x_1) = \frac{\alpha}{\pi} q_p^2\,\left[\ln x_1(L-\ln x_1) - \ln x_0(L-\ln x_0)\right] \end{equation} such that (\ref{EPA-subst}) is satisfied. Finally, we have \begin{equation} \int_{x_0}^{x_1} dx\,f(x) = C(x_0,x_1)\int_0^1 dx'\, \frac{f(x(x'))}{\bar f(x(x'))} \end{equation} where $x'$ is calculated from $x$ via (\ref{EPA-x(x')}). The structure of the mapping is most obvious from: \begin{equation} x'(x) = \frac{\log x ( L - \log x) - \log x_0 (L - \log x_0)} {\log x_1 ( L - \log x_1) - \log x_0 (L - \log x_0)} \; . \end{equation} \subsection{The EPA data block} The EPA parameters are: $\alpha$, $E_{\rm max}$, $m$, $Q_{\rm min}$, and $x_{\rm min}$. Instead of $m$ we can use the incoming particle PDG code as input; from this we can deduce the mass and charge. Internally we store in addition $C_{0/1} = \frac{\alpha}{\pi}q_e^2\ln x_{0/1} (L - \ln x_{0/1})$, the c.m. energy squared and the incoming particle mass. <>= public :: epa_data_t <>= type, extends(sf_data_t) :: epa_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:), allocatable :: flv_in real(default) :: alpha real(default) :: x_min real(default) :: x_max real(default) :: q_min real(default) :: q_max real(default) :: E_max real(default) :: mass real(default) :: log real(default) :: a real(default) :: c0 real(default) :: c1 real(default) :: dc integer :: error = NONE logical :: recoil = .false. logical :: keep_energy = .true. contains <> end type epa_data_t @ %def epa_data_t @ Error codes <>= integer, parameter :: NONE = 0 integer, parameter :: ZERO_QMIN = 1 integer, parameter :: Q_MAX_TOO_SMALL = 2 integer, parameter :: ZERO_XMIN = 3 integer, parameter :: MASS_MIX = 4 integer, parameter :: NO_EPA = 5 <>= procedure :: init => epa_data_init <>= subroutine epa_data_init (data, model, pdg_in, alpha, & x_min, q_min, E_max, mass, recoil, keep_energy) class(epa_data_t), intent(inout) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in real(default), intent(in) :: alpha, x_min, q_min, E_max real(default), intent(in), optional :: mass logical, intent(in), optional :: recoil logical, intent(in), optional :: keep_energy integer :: n_flv, i data%model => model n_flv = pdg_array_get_length (pdg_in) allocate (data%flv_in (n_flv)) do i = 1, n_flv call data%flv_in(i)%init (pdg_array_get (pdg_in, i), model) end do data%alpha = alpha data%E_max = E_max data%x_min = x_min data%x_max = 1 if (vanishes (data%x_min)) then data%error = ZERO_XMIN; return end if data%q_min = q_min data%q_max = 2 * data%E_max select case (char (data%model%get_name ())) case ("QCD","Test") data%error = NO_EPA; return end select if (present (recoil)) then data%recoil = recoil end if if (present (keep_energy)) then data%keep_energy = keep_energy end if if (present (mass)) then data%mass = mass else data%mass = data%flv_in(1)%get_mass () if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if if (max (data%mass, data%q_min) == 0) then data%error = ZERO_QMIN; return else if (max (data%mass, data%q_min) >= data%E_max) then data%error = Q_MAX_TOO_SMALL; return end if data%log = log (4 * (data%E_max / max (data%mass, data%q_min)) ** 2 ) data%a = data%alpha / pi data%c0 = log (data%x_min) * (data%log - log (data%x_min)) data%c1 = log (data%x_max) * (data%log - log (data%x_max)) data%dc = data%c1 - data%c0 end subroutine epa_data_init @ %def epa_data_init @ Handle error conditions. Should always be done after initialization, unless we are sure everything is ok. <>= procedure :: check => epa_data_check <>= subroutine epa_data_check (data) class(epa_data_t), intent(in) :: data select case (data%error) case (NO_EPA) call msg_fatal ("EPA structure function not available for model " & // char (data%model%get_name ()) // ".") case (ZERO_QMIN) call msg_fatal ("EPA: Particle mass is zero") case (Q_MAX_TOO_SMALL) call msg_fatal ("EPA: Particle mass exceeds Qmax") case (ZERO_XMIN) call msg_fatal ("EPA: x_min must be larger than zero") case (MASS_MIX) call msg_fatal ("EPA: incoming particle masses must be uniform") end select end subroutine epa_data_check @ %def epa_data_check @ Output <>= procedure :: write => epa_data_write <>= subroutine epa_data_write (data, unit, verbose) class(epa_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "EPA data:" if (allocated (data%flv_in)) then write (u, "(3x,A)", advance="no") " flavor = " do i = 1, size (data%flv_in) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_in(i)%write (u) end do write (u, *) write (u, "(3x,A," // FMT_19 // ")") " alpha = ", data%alpha write (u, "(3x,A," // FMT_19 // ")") " x_min = ", data%x_min write (u, "(3x,A," // FMT_19 // ")") " x_max = ", data%x_max write (u, "(3x,A," // FMT_19 // ")") " q_min = ", data%q_min write (u, "(3x,A," // FMT_19 // ")") " q_max = ", data%q_max write (u, "(3x,A," // FMT_19 // ")") " E_max = ", data%e_max write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass write (u, "(3x,A," // FMT_19 // ")") " a = ", data%a write (u, "(3x,A," // FMT_19 // ")") " c0 = ", data%c0 write (u, "(3x,A," // FMT_19 // ")") " c1 = ", data%c1 write (u, "(3x,A," // FMT_19 // ")") " log = ", data%log write (u, "(3x,A,L2)") " recoil = ", data%recoil write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy else write (u, "(3x,A)") "[undefined]" end if end subroutine epa_data_write @ %def epa_data_write @ The number of kinematic parameters. <>= procedure :: get_n_par => epa_data_get_n_par <>= function epa_data_get_n_par (data) result (n) class(epa_data_t), intent(in) :: data integer :: n if (data%recoil) then n = 3 else n = 1 end if end function epa_data_get_n_par @ %def epa_data_get_n_par @ Return the outgoing particles PDG codes. The outgoing particle is always the photon while the radiated particle is identical to the incoming one. <>= procedure :: get_pdg_out => epa_data_get_pdg_out <>= subroutine epa_data_get_pdg_out (data, pdg_out) class(epa_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = PHOTON end subroutine epa_data_get_pdg_out @ %def epa_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => epa_data_allocate_sf_int <>= subroutine epa_data_allocate_sf_int (data, sf_int) class(epa_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (epa_t :: sf_int) end subroutine epa_data_allocate_sf_int @ %def epa_data_allocate_sf_int @ \subsection{The EPA object} The [[epa_t]] data type is a $1\to 2$ interaction. We should be able to handle several flavors in parallel, since EPA is not necessarily applied immediately after beam collision: Photons may be radiated from quarks. In that case, the partons are massless and $q_{\rm min}$ applies instead, so we do not need to generate several kinematical configurations in parallel. The squared charge values multiply the matrix elements, depending on the flavour. We scan the interaction after building it, so we have the correct assignments. The particles are ordered as (incoming, radiated, photon), where the photon initiates the hard interaction. We generate an unpolarized photon and transfer initial polarization to the radiated parton. Color is transferred in the same way. <>= type, extends (sf_int_t) :: epa_t type(epa_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: xb = 0 real(default) :: E = 0 real(default), dimension(:), allocatable :: charge2 contains <> end type epa_t @ %def epa_t @ Type string: has to be here, but there is no string variable on which EPA depends. Hence, a dummy routine. <>= procedure :: type_string => epa_type_string <>= function epa_type_string (object) result (string) class(epa_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "EPA: equivalent photon approx." else string = "EPA: [undefined]" end if end function epa_type_string @ %def epa_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => epa_write <>= subroutine epa_write (object, unit, testflag) class(epa_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A," // FMT_17 // ")") "E =", object%E end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "EPA data: [undefined]" end if end subroutine epa_write @ %def epa_write @ Prepare the interaction object. We have to construct transition matrix elements for all flavor and helicity combinations. <>= procedure :: init => epa_init <>= subroutine epa_init (sf_int, data) class(epa_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask integer, dimension(3) :: hel_lock type(polarization_t), target :: pol type(quantum_numbers_t), dimension(1) :: qn_fc type(flavor_t) :: flv_photon type(color_t) :: col_photon type(quantum_numbers_t) :: qn_hel, qn_photon, qn, qn_rad type(polarization_iterator_t) :: it_hel integer :: i mask = quantum_numbers_mask (.false., .false., & mask_h = [.false., .false., .true.]) hel_lock = [2, 1, 0] select type (data) type is (epa_data_t) call sf_int%base_init (mask, [data%mass**2], & [data%mass**2], [0._default], hel_lock = hel_lock) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col_photon%init () call qn_photon%init (flv_photon, col_photon) do i = 1, size (data%flv_in) call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) qn_rad = qn call qn_rad%tag_radiated () call sf_int%add_state ([qn, qn_rad, qn_photon]) call it_hel%advance () end do ! call pol%final () end do call sf_int%freeze () if (data%keep_energy) then sf_int%on_shell_mode = KEEP_ENERGY else sf_int%on_shell_mode = KEEP_MOMENTUM end if call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) end select end subroutine epa_init @ %def epa_init @ Prepare the charge array. This is separate from the previous routine since the state matrix may be helicity-contracted. <>= procedure :: setup_constants => epa_setup_constants <>= subroutine epa_setup_constants (sf_int) class(epa_t), intent(inout), target :: sf_int type(state_iterator_t) :: it type(flavor_t) :: flv integer :: i, n_me n_me = sf_int%get_n_matrix_elements () allocate (sf_int%charge2 (n_me)) call it%init (sf_int%interaction_t%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () flv = it%get_flavor (1) sf_int%charge2(i) = flv%get_charge () ** 2 call it%advance () end do sf_int%status = SF_INITIAL end subroutine epa_setup_constants @ %def epa_setup_constants @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. The EPA structure function allows for a straightforward mapping of the unit interval. The $x$ value is transformed, and the mapped structure function becomes unity at its upper boundary. The structure function implementation applies the above mapping to the input (random) number [[r]] to generate the momentum fraction [[x]] and the function value [[f]]. For numerical stability reasons, we also output [[xb]], which is $\bar x=1-x$. <>= procedure :: complete_kinematics => epa_complete_kinematics <>= subroutine epa_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default) :: delta, sqrt_delta, lx if (map) then associate (data => sf_int%data) delta = data%log ** 2 - 4 * (r(1) * data%c1 + rb(1) * data%c0) if (delta > 0) then sqrt_delta = sqrt (delta) lx = (data%log - sqrt_delta) / 2 else sf_int%status = SF_FAILED_KINEMATICS f = 0 return end if x(1) = exp (lx) f = x(1) * data%dc / sqrt_delta end associate else x(1) = r(1) if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then f = 1 else sf_int%status = SF_FAILED_KINEMATICS f = 0 return end if end if xb(1) = 1 - x(1) if (size(x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) sf_int%xb= xb(1) sf_int%E = energy (sf_int%get_momentum (1)) case (SF_FAILED_KINEMATICS) sf_int%x = 0 sf_int%xb= 0 f = 0 end select end subroutine epa_complete_kinematics @ %def epa_complete_kinematics @ Overriding the default method: we compute the [[x]] array from the momentum configuration. In the specific case of EPA, we also set the internally stored $x$ and $\bar x$ values, so they can be used in the following routine. Note: the extraction of $\bar x$ is not numerically safe, but it cannot be as long as the base [[recover_x]] is not. <>= procedure :: recover_x => sf_epa_recover_x <>= subroutine sf_epa_recover_x (sf_int, x, xb, x_free) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) sf_int%xb = xb(1) end subroutine sf_epa_recover_x @ %def sf_epa_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => epa_inverse_kinematics <>= subroutine epa_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: lx, delta, sqrt_delta, c logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then associate (data => sf_int%data) lx = log (x(1)) sqrt_delta = data%log - 2 * lx delta = sqrt_delta ** 2 c = (data%log ** 2 - delta) / 4 r (1) = (c - data%c0) / data%dc rb(1) = (data%c1 - c) / data%dc f = x(1) * data%dc / sqrt_delta end associate else r (1) = x(1) rb(1) = xb(1) if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then f = 1 else f = 0 end if end if if (size(r) == 3) then r (2:3) = x(2:3) rb(2:3) = xb(2:3) end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if sf_int%E = energy (sf_int%get_momentum (1)) end subroutine epa_inverse_kinematics @ %def epa_inverse_kinematics @ \subsection{EPA application} For EPA, we can in principle compute kinematics and function value in a single step. In order to be able to reweight events, kinematics and structure function application are separated. This function works on a single beam, assuming that the input momentum has been set. We need three random numbers as input: one for $x$, and two for the polar and azimuthal angles. Alternatively, for the no-recoil case, we can skip $p_T$ generation; in this case, we only need one. For obtaining splitting kinematics, we rely on the assumption that all in-particles are mass-degenerate (or there is only one), so the generated $x$ values are identical. <>= procedure :: apply => epa_apply <>= subroutine epa_apply (sf_int, scale, rescale, i_sub, fill_sub) class(epa_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub logical, intent(in), optional :: fill_sub real(default) :: x, xb, qminsq, qmaxsq, f, E associate (data => sf_int%data) x = sf_int%x xb= sf_int%xb E = sf_int%E qminsq = max (x ** 2 / xb * data%mass ** 2, data%q_min ** 2) qmaxsq = min (4 * xb * E ** 2, data%q_max ** 2) if (qminsq < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / qminsq) & - (1 - x / 2) ** 2 & * log ((x**2 + qmaxsq / E ** 2) / (x**2 + qminsq / E ** 2)) & - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq)) else f = 0 end if call sf_int%set_matrix_element & (cmplx (f, kind=default) * sf_int%charge2) end associate sf_int%status = SF_EVALUATED end subroutine epa_apply @ %def epa_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_epa_ut.f90]]>>= <> module sf_epa_ut use unit_tests use sf_epa_uti <> <> contains <> end module sf_epa_ut @ %def sf_epa_ut @ <<[[sf_epa_uti.f90]]>>= <> module sf_epa_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use interactions, only: interaction_pacify_momenta use model_data use sf_aux use sf_base use sf_epa <> <> contains <> end module sf_epa_uti @ %def sf_epa_ut @ API: driver for the unit tests below. <>= public :: sf_epa_test <>= subroutine sf_epa_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_epa_test @ %def sf_epa_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_epa_1, "sf_epa_1", & "structure function configuration", & u, results) <>= public :: sf_epa_1 <>= subroutine sf_epa_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_epa_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_qed_test () pdg_in = ELECTRON allocate (epa_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (epa_data_t) call data%init (model, pdg_in, 1./137._default, 0.01_default, & 10._default, 50._default, 0.000511_default, recoil = .false.) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_1" end subroutine sf_epa_1 @ %def sf_epa_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the EPA structure function. <>= call test (sf_epa_2, "sf_epa_2", & "structure function instance", & u, results) <>= public :: sf_epa_2 <>= subroutine sf_epa_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, pdg_in, 1./137._default, 0.01_default, & 10._default, 50._default, 0.000511_default, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EPA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_2" end subroutine sf_epa_2 @ %def sf_epa_2 @ \subsubsection{Standard mapping} Construct and display a structure function object based on the EPA structure function, applying the standard single-particle mapping. <>= call test (sf_epa_3, "sf_epa_3", & "apply mapping", & u, results) <>= public :: sf_epa_3 <>= subroutine sf_epa_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_3" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, pdg_in, 1./137._default, 0.01_default, & 10._default, 50._default, 0.000511_default, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, with EPA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_3" end subroutine sf_epa_3 @ %def sf_epa_3 @ \subsubsection{Non-collinear case} Construct and display a structure function object based on the EPA structure function. <>= call test (sf_epa_4, "sf_epa_4", & "non-collinear", & u, results) <>= public :: sf_epa_4 <>= subroutine sf_epa_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E, m real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_4" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, pdg_in, 1./137._default, 0.01_default, & 10._default, 50._default, 5.0_default, recoil = .true.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500, me = 5 GeV" write (u, "(A)") E = 500 m = 5 k = vector4_moving (E, sqrt (E**2 - m**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.5/0.5/0.25, with EPA mapping, " write (u, "(A)") " non-coll., keeping energy, me = 5 GeV" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.5_default, 0.5_default, 0.25_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x and r from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_4" end subroutine sf_epa_4 @ %def sf_epa_4 @ \subsubsection{Structure function for multiple flavors} Construct and display a structure function object based on the EPA structure function. The incoming state has multiple particles with non-uniform charge. <>= call test (sf_epa_5, "sf_epa_5", & "multiple flavors", & u, results) <>= public :: sf_epa_5 <>= subroutine sf_epa_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_5" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (1, model) pdg_in = [1, 2, -1, -2] call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, pdg_in, 1./137._default, 0.01_default, & 10._default, 50._default, 0.000511_default, recoil = .false.) call data%check () end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EPA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_5" end subroutine sf_epa_5 @ %def sf_epa_5 @ \clearpage %------------------------------------------------------------------------ \section{EWA} <<[[sf_ewa.f90]]>>= <> module sf_ewa <> <> use io_units use constants, only: pi use format_defs, only: FMT_17, FMT_19 use numeric_utils use diagnostics use physics_defs, only: W_BOSON, Z_BOSON use lorentz use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use interactions use sf_aux use sf_base <> <> <> <> contains <> end module sf_ewa @ %def sf_ewa @ \subsection{Physics} The EWA structure function for a $Z$ or $W$ inside a fermion (lepton or quark) depends on the vector-boson polarization. We distinguish transversal ($\pm$) and longitudinal ($0$) polarization. \begin{align} F_{+}(x) &= \frac{1}{16\pi^2}\,\frac{(v-a)^2 + (v+a)^2\bar x^2}{x} \left[ \ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right) - \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2} \right] \\ F_{-}(x) &= \frac{1}{16\pi^2}\,\frac{(v+a)^2 + (v-a)^2\bar x^2}{x} \left[ \ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right) - \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2} \right] \\ F_0(x) &= \frac{v^2+a^2}{8\pi^2}\,\frac{2\bar x}{x}\, \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2} \end{align} where $p_{\perp,\textrm{max}}$ is the cutoff in transversal momentum, $M$ is the vector-boson mass, $v$ and $a$ are the vector and axial-vector couplings, and $\bar x\equiv 1-x$. Note that the longitudinal structure function is finite for large cutoff, while the transversal structure function is logarithmically divergent. The maximal transverse momentum is given by the kinematical limit, it is \begin{equation} p_{\perp,\textrm{max}} = \bar x \sqrt{s}/2. \end{equation} The vector and axial couplings for a fermion branching into a $W$ are \begin{align} v_W &= \frac{g}{2\sqrt 2}, & a_W &= \frac{g}{2\sqrt 2}. \end{align} For $Z$ emission, this is replaced by \begin{align} v_Z &= \frac{g}{2\cos\theta_w}\left(t_3 - 2q\sin^2\theta_w\right), & a_Z &= \frac{g}{2\cos\theta_w}t_3, \end{align} where $t_3=\pm\frac12$ is the fermion isospin, and $q$ its charge. For an initial antifermion, the signs of the axial couplings are inverted. Note that a common sign change of $v$ and $a$ is irrelevant. %% Differentiating with respect to the cutoff, we get structure functions %% \begin{align} %% f_{W,\pm}(x,p_T) &= \frac{g^2}{16\pi^2}\, %% \frac{1+\bar x^2}{x} %% \frac{p_\perp}{p_\perp^2 + \bar x M^2} %% \\ %% f_{W,0}(x,p_T) &= \frac{g^2}{16\pi^2}\, %% \frac{2\bar x}{x}\, %% \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2} %% \\ %% F_{Z,\pm}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2} %% \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\, %% \frac{1+\bar x^2}{x} %% \frac{p_\perp}{p_\perp^2 + \bar x M^2} %% \\ %% F_{Z,0}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2}\, %% \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\, %% \frac{2\bar x}{x}\, %% \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2} %% \end{align} %% Here, $t_3^f$ is the $SU(2)_L$ quantum number of the fermion %% $(\pm\frac12)$, and $q^f$ is the fermion charge in units of the %% positron charge. The EWA depends on the parameters $g$, $\sin^2\theta_w$, $M_W$, and $M_Z$. These can all be taken from the SM input, and the prefactors are calculated from those and the incoming particle type. Since these structure functions have a $1/x$ singularity (which is not really relevant in practice, however, since the vector boson mass is finite), we map this singularity allowing for nontrivial $x$ bounds: \begin{equation} x = \exp(\bar r\ln x_0 + r\ln x_1) \end{equation} such that \begin{equation} \int_{x_0}^{x_1}\frac{dx}{x} = (\ln x_1 - \ln x_0)\int_0^1 dr. \end{equation} As a user parameter, we have the cutoff $p_{\perp,\textrm{max}}$. The divergence $1/x$ also requires a $x_0$ cutoff; and for completeness we introduce a corresponding $x_1$. Physically, the minimal sensible value of $x$ is $M^2/s$, although the approximation loses its value already at higher $x$ values. \subsection{The EWA data block} The EWA parameters are: $p_{T,\rm max}$, $c_V$, $c_A$, and $m$. Instead of $m$ we can use the incoming particle PDG code as input; from this we can deduce the mass and charges. In the initialization phase it is not yet determined whether a $W$ or a $Z$ is radiated, hence we set the vector and axial-vector couplings equal to the common prefactors $g/2 = e/2/\sin\theta_W$. In principle, for EWA it would make sense to allow the user to also set the upper bound for $x$, $x_{\rm max}$, but we fix it to one here. <>= public :: ewa_data_t <>= type, extends(sf_data_t) :: ewa_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:), allocatable :: flv_in type(flavor_t), dimension(:), allocatable :: flv_out real(default) :: pt_max real(default) :: sqrts real(default) :: x_min real(default) :: x_max real(default) :: mass real(default) :: m_out real(default) :: q_min real(default) :: cv real(default) :: ca real(default) :: costhw real(default) :: sinthw real(default) :: mW real(default) :: mZ real(default) :: coeff logical :: mass_set = .false. logical :: recoil = .false. logical :: keep_energy = .false. integer :: id = 0 integer :: error = NONE contains <> end type ewa_data_t @ %def ewa_data_t @ Error codes <>= integer, parameter :: NONE = 0 integer, parameter :: ZERO_QMIN = 1 integer, parameter :: Q_MAX_TOO_SMALL = 2 integer, parameter :: ZERO_XMIN = 3 integer, parameter :: MASS_MIX = 4 integer, parameter :: ZERO_SW = 5 integer, parameter :: ISOSPIN_MIX = 6 integer, parameter :: WRONG_PRT = 7 integer, parameter :: MASS_MIX_OUT = 8 integer, parameter :: NO_EWA = 9 <>= procedure :: init => ewa_data_init <>= subroutine ewa_data_init (data, model, pdg_in, x_min, pt_max, & sqrts, recoil, keep_energy, mass) class(ewa_data_t), intent(inout) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in real(default), intent(in) :: x_min, pt_max, sqrts logical, intent(in) :: recoil, keep_energy real(default), intent(in), optional :: mass real(default) :: g, ee integer :: n_flv, i data%model => model if (.not. any (pdg_in .match. & [1,2,3,4,5,6,11,13,15,-1,-2,-3,-4,-5,-6,-11,-13,-15])) then data%error = WRONG_PRT; return end if n_flv = pdg_array_get_length (pdg_in) allocate (data%flv_in (n_flv)) allocate (data%flv_out(n_flv)) do i = 1, n_flv call data%flv_in(i)%init (pdg_array_get (pdg_in, i), model) end do data%pt_max = pt_max data%sqrts = sqrts data%x_min = x_min data%x_max = 1 if (vanishes (data%x_min)) then data%error = ZERO_XMIN; return end if select case (char (data%model%get_name ())) case ("QCD","QED","Test") data%error = NO_EWA; return end select ee = data%model%get_real (var_str ("ee")) data%sinthw = data%model%get_real (var_str ("sw")) data%costhw = data%model%get_real (var_str ("cw")) data%mZ = data%model%get_real (var_str ("mZ")) data%mW = data%model%get_real (var_str ("mW")) if (data%sinthw /= 0) then g = ee / data%sinthw else data%error = ZERO_SW; return end if data%cv = g / 2._default data%ca = g / 2._default data%coeff = 1._default / (8._default * PI**2) data%recoil = recoil data%keep_energy = keep_energy if (present (mass)) then data%mass = mass data%m_out = mass data%mass_set = .true. else data%mass = data%flv_in(1)%get_mass () if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if end subroutine ewa_data_init @ %def ewa_data_init @ Set the vector boson ID for distinguishing $W$ and $Z$ bosons. <>= procedure :: set_id => ewa_set_id <>= subroutine ewa_set_id (data, id) class(ewa_data_t), intent(inout) :: data integer, intent(in) :: id integer :: i, isospin, pdg if (.not. allocated (data%flv_in)) & call msg_bug ("EWA: incoming particles not set") data%id = id select case (data%id) case (23) data%m_out = data%mass data%flv_out = data%flv_in case (24) do i = 1, size (data%flv_in) pdg = data%flv_in(i)%get_pdg () isospin = data%flv_in(i)%get_isospin_type () if (isospin > 0) then !!! up-type quark or neutrinos if (data%flv_in(i)%is_antiparticle ()) then call data%flv_out(i)%init (pdg + 1, data%model) else call data%flv_out(i)%init (pdg - 1, data%model) end if else !!! down-type quark or lepton if (data%flv_in(i)%is_antiparticle ()) then call data%flv_out(i)%init (pdg - 1, data%model) else call data%flv_out(i)%init (pdg + 1, data%model) end if end if end do if (.not. data%mass_set) then data%m_out = data%flv_out(1)%get_mass () if (any (data%flv_out%get_mass () /= data%m_out)) then data%error = MASS_MIX_OUT; return end if end if end select end subroutine ewa_set_id @ %def ewa_set_id @ Handle error conditions. Should always be done after initialization, unless we are sure everything is ok. <>= procedure :: check => ewa_data_check <>= subroutine ewa_data_check (data) class(ewa_data_t), intent(in) :: data select case (data%error) case (WRONG_PRT) call msg_fatal ("EWA structure function only accessible for " & // "SM quarks and leptons.") case (NO_EWA) call msg_fatal ("EWA structure function not available for model " & // char (data%model%get_name ())) case (ZERO_SW) call msg_fatal ("EWA: Vanishing value of sin(theta_w)") case (ZERO_QMIN) call msg_fatal ("EWA: Particle mass is zero") case (Q_MAX_TOO_SMALL) call msg_fatal ("EWA: Particle mass exceeds Qmax") case (ZERO_XMIN) call msg_fatal ("EWA: x_min must be larger than zero") case (MASS_MIX) call msg_fatal ("EWA: incoming particle masses must be uniform") case (MASS_MIX_OUT) call msg_fatal ("EWA: outgoing particle masses must be uniform") case (ISOSPIN_MIX) call msg_fatal ("EWA: incoming particle isospins must be uniform") end select end subroutine ewa_data_check @ %def ewa_data_check @ Output <>= procedure :: write => ewa_data_write <>= subroutine ewa_data_write (data, unit, verbose) class(ewa_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "EWA data:" if (allocated (data%flv_in) .and. allocated (data%flv_out)) then write (u, "(3x,A)", advance="no") " flavor(in) = " do i = 1, size (data%flv_in) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_in(i)%write (u) end do write (u, *) write (u, "(3x,A)", advance="no") " flavor(out) = " do i = 1, size (data%flv_out) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_out(i)%write (u) end do write (u, *) write (u, "(3x,A," // FMT_19 // ")") " x_min = ", data%x_min write (u, "(3x,A," // FMT_19 // ")") " x_max = ", data%x_max write (u, "(3x,A," // FMT_19 // ")") " pt_max = ", data%pt_max write (u, "(3x,A," // FMT_19 // ")") " sqrts = ", data%sqrts write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass write (u, "(3x,A," // FMT_19 // ")") " cv = ", data%cv write (u, "(3x,A," // FMT_19 // ")") " ca = ", data%ca write (u, "(3x,A," // FMT_19 // ")") " coeff = ", data%coeff write (u, "(3x,A," // FMT_19 // ")") " costhw = ", data%costhw write (u, "(3x,A," // FMT_19 // ")") " sinthw = ", data%sinthw write (u, "(3x,A," // FMT_19 // ")") " mZ = ", data%mZ write (u, "(3x,A," // FMT_19 // ")") " mW = ", data%mW write (u, "(3x,A,L2)") " recoil = ", data%recoil write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy write (u, "(3x,A,I2)") " PDG (VB) = ", data%id else write (u, "(3x,A)") "[undefined]" end if end subroutine ewa_data_write @ %def ewa_data_write @ The number of parameters is one for collinear splitting, in case the [[recoil]] option is set, we take the recoil into account. <>= procedure :: get_n_par => ewa_data_get_n_par <>= function ewa_data_get_n_par (data) result (n) class(ewa_data_t), intent(in) :: data integer :: n if (data%recoil) then n = 3 else n = 1 end if end function ewa_data_get_n_par @ %def ewa_data_get_n_par @ Return the outgoing particles PDG codes. This depends, whether this is a charged-current or neutral-current interaction. <>= procedure :: get_pdg_out => ewa_data_get_pdg_out <>= subroutine ewa_data_get_pdg_out (data, pdg_out) class(ewa_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer, dimension(:), allocatable :: pdg1 integer :: i, n_flv if (allocated (data%flv_out)) then n_flv = size (data%flv_out) else n_flv = 0 end if allocate (pdg1 (n_flv)) do i = 1, n_flv pdg1(i) = data%flv_out(i)%get_pdg () end do pdg_out(1) = pdg1 end subroutine ewa_data_get_pdg_out @ %def ewa_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => ewa_data_allocate_sf_int <>= subroutine ewa_data_allocate_sf_int (data, sf_int) class(ewa_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (ewa_t :: sf_int) end subroutine ewa_data_allocate_sf_int @ %def ewa_data_allocate_sf_int @ \subsection{The EWA object} The [[ewa_t]] data type is a $1\to 2$ interaction. We should be able to handle several flavors in parallel, since EWA is not necessarily applied immediately after beam collision: $W/Z$ bosons may be radiated from quarks. In that case, the partons are massless and $q_{\rm min}$ applies instead, so we do not need to generate several kinematical configurations in parallel. The particles are ordered as (incoming, radiated, W/Z), where the W/Z initiates the hard interaction. In the case of EPA, we generated an unpolarized photon and transferred initial polarization to the radiated parton. Color is transferred in the same way. I do not know whether the same can/should be done for EWA, as the structure functions depend on the W/Z polarization. If we are having $Z$ bosons, both up- and down-type fermions can participate. Otherwise, with a $W^+$ an up-type fermion is transferred to a down-type fermion, and the other way round. <>= type, extends (sf_int_t) :: ewa_t type(ewa_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: xb = 0 integer :: n_me = 0 real(default), dimension(:), allocatable :: cv real(default), dimension(:), allocatable :: ca contains <> end type ewa_t @ %def ewa_t @ Type string: has to be here, but there is no string variable on which EWA depends. Hence, a dummy routine. <>= procedure :: type_string => ewa_type_string <>= function ewa_type_string (object) result (string) class(ewa_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "EWA: equivalent W/Z approx." else string = "EWA: [undefined]" end if end function ewa_type_string @ %def ewa_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => ewa_write <>= subroutine ewa_write (object, unit, testflag) class(ewa_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x write (u, "(3x,A," // FMT_17 // ")") "xb=", object%xb end if call object%base_write (u, testflag) else write (u, "(1x,A)") "EWA data: [undefined]" end if end subroutine ewa_write @ %def ewa_write @ The current implementation requires uniform isospin for all incoming particles, therefore we need to probe only the first one. <>= procedure :: init => ewa_init <>= subroutine ewa_init (sf_int, data) class(ewa_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask integer, dimension(3) :: hel_lock type(polarization_t), target :: pol type(quantum_numbers_t), dimension(1) :: qn_fc, qn_fc_fin type(flavor_t) :: flv_z, flv_wp, flv_wm type(color_t) :: col0 type(quantum_numbers_t) :: qn_hel, qn_z, qn_wp, qn_wm, qn, qn_rad, qn_w type(polarization_iterator_t) :: it_hel integer :: i, isospin select type (data) type is (ewa_data_t) mask = quantum_numbers_mask (.false., .false., & mask_h = [.false., .false., .true.]) hel_lock = [2, 1, 0] call col0%init () select case (data%id) case (23) !!! Z boson, flavor is not changing call sf_int%base_init (mask, [data%mass**2], [data%mass**2], & [data%mZ**2], hel_lock = hel_lock) sf_int%data => data call flv_z%init (Z_BOSON, data%model) call qn_z%init (flv_z, col0) do i = 1, size (data%flv_in) call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) qn_rad = qn call qn_rad%tag_radiated () call sf_int%add_state ([qn, qn_rad, qn_z]) call it_hel%advance () end do ! call pol%final () end do case (24) call sf_int%base_init (mask, [data%mass**2], [data%m_out**2], & [data%mW**2], hel_lock = hel_lock) sf_int%data => data call flv_wp%init (W_BOSON, data%model) call flv_wm%init (- W_BOSON, data%model) call qn_wp%init (flv_wp, col0) call qn_wm%init (flv_wm, col0) do i = 1, size (data%flv_in) isospin = data%flv_in(i)%get_isospin_type () if (isospin > 0) then !!! up-type quark or neutrinos if (data%flv_in(i)%is_antiparticle ()) then qn_w = qn_wm else qn_w = qn_wp end if else !!! down-type quark or lepton if (data%flv_in(i)%is_antiparticle ()) then qn_w = qn_wp else qn_w = qn_wm end if end if call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call qn_fc_fin(1)%init ( & flv = data%flv_out(i), & col = color_from_flavor (data%flv_out(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) qn_rad = qn_hel .merge. qn_fc_fin(1) call qn_rad%tag_radiated () call sf_int%add_state ([qn, qn_rad, qn_w]) call it_hel%advance () end do ! call pol%final () end do case default call msg_fatal ("EWA initialization failed: wrong particle type.") end select call sf_int%freeze () if (data%keep_energy) then sf_int%on_shell_mode = KEEP_ENERGY else sf_int%on_shell_mode = KEEP_MOMENTUM end if call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) end select end subroutine ewa_init @ %def ewa_init @ Prepare the coupling arrays. This is separate from the previous routine since the state matrix may be helicity-contracted. <>= procedure :: setup_constants => ewa_setup_constants <>= subroutine ewa_setup_constants (sf_int) class(ewa_t), intent(inout), target :: sf_int type(state_iterator_t) :: it type(flavor_t) :: flv real(default) :: q, t3 integer :: i sf_int%n_me = sf_int%get_n_matrix_elements () allocate (sf_int%cv (sf_int%n_me)) allocate (sf_int%ca (sf_int%n_me)) associate (data => sf_int%data) select case (data%id) case (23) call it%init (sf_int%interaction_t%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () flv = it%get_flavor (1) q = flv%get_charge () t3 = flv%get_isospin () if (flv%is_antiparticle ()) then sf_int%cv(i) = - data%cv & * (t3 - 2._default * q * data%sinthw**2) / data%costhw sf_int%ca(i) = data%ca * t3 / data%costhw else sf_int%cv(i) = data%cv & * (t3 - 2._default * q * data%sinthw**2) / data%costhw sf_int%ca(i) = data%ca * t3 / data%costhw end if call it%advance () end do case (24) call it%init (sf_int%interaction_t%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () flv = it%get_flavor (1) if (flv%is_antiparticle ()) then sf_int%cv(i) = data%cv / sqrt(2._default) sf_int%ca(i) = - data%ca / sqrt(2._default) else sf_int%cv(i) = data%cv / sqrt(2._default) sf_int%ca(i) = data%ca / sqrt(2._default) end if call it%advance () end do end select end associate sf_int%status = SF_INITIAL end subroutine ewa_setup_constants @ %def ewa_setup_constants @ \subsection{Kinematics} Set kinematics. The EWA structure function allows for a straightforward mapping of the unit interval. So, to leading order, the structure function value is unity, but the $x$ value is transformed. Higher orders affect the function value. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, the exponential mapping for the $1/x$ singularity discussed above is applied. <>= procedure :: complete_kinematics => ewa_complete_kinematics <>= subroutine ewa_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default) :: e_1 real(default) :: x0, x1, lx0, lx1, lx e_1 = energy (sf_int%get_momentum (1)) if (sf_int%data%recoil) then select case (sf_int%data%id) case (23) x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1) case (24) x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1) end select else x0 = sf_int%data%x_min end if x1 = sf_int%data%x_max if ( x0 >= x1) then f = 0 sf_int%status = SF_FAILED_KINEMATICS return end if if (map) then lx0 = log (x0) lx1 = log (x1) lx = lx1 * r(1) + lx0 * rb(1) x(1) = exp(lx) f = x(1) * (lx1 - lx0) else x(1) = r(1) if (x0 < x(1) .and. x(1) < x1) then f = 1 else sf_int%status = SF_FAILED_KINEMATICS f = 0 return end if end if xb(1) = 1 - x(1) if (size(x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) sf_int%xb = xb(1) case (SF_FAILED_KINEMATICS) sf_int%x = 0 sf_int%xb = 0 f = 0 end select end subroutine ewa_complete_kinematics @ %def ewa_complete_kinematics @ Overriding the default method: we compute the [[x]] array from the momentum configuration. In the specific case of EWA, we also set the internally stored $x$ and $\bar x$ values, so they can be used in the following routine. <>= procedure :: recover_x => sf_ewa_recover_x <>= subroutine sf_ewa_recover_x (sf_int, x, xb, x_free) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) sf_int%xb = xb(1) end subroutine sf_ewa_recover_x @ %def sf_ewa_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => ewa_inverse_kinematics <>= subroutine ewa_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: x0, x1, lx0, lx1, lx, e_1 logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta e_1 = energy (sf_int%get_momentum (1)) if (sf_int%data%recoil) then select case (sf_int%data%id) case (23) x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1) case (24) x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1) end select else x0 = sf_int%data%x_min end if x1 = sf_int%data%x_max if (map) then lx0 = log (x0) lx1 = log (x1) lx = log (x(1)) r(1) = (lx - lx0) / (lx1 - lx0) rb(1) = (lx1 - lx) / (lx1 - lx0) f = x(1) * (lx1 - lx0) else r (1) = x(1) rb(1) = 1 - x(1) if (x0 < x(1) .and. x(1) < x1) then f = 1 else f = 0 end if end if if (size(r) == 3) then r (2:3) = x(2:3) rb(2:3) = xb(2:3) end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine ewa_inverse_kinematics @ %def ewa_inverse_kinematics @ \subsection{EWA application} For EWA, we can compute kinematics and function value in a single step. This function works on a single beam, assuming that the input momentum has been set. We need four random numbers as input: one for $x$, one for $Q^2$, and two for the polar and azimuthal angles. Alternatively, we can skip $p_T$ generation; in this case, we only need one. For obtaining splitting kinematics, we rely on the assumption that all in-particles are mass-degenerate (or there is only one), so the generated $x$ values are identical. <>= procedure :: apply => ewa_apply <>= subroutine ewa_apply (sf_int, scale, rescale, i_sub, fill_sub) class(ewa_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub logical, intent(in), optional :: fill_sub real(default) :: x, xb, pt2, c1, c2 real(default) :: cv, ca real(default) :: f, fm, fp, fL integer :: i associate (data => sf_int%data) x = sf_int%x xb = sf_int%xb pt2 = min ((data%pt_max)**2, (xb * data%sqrts / 2)**2) select case (data%id) case (23) !!! Z boson structure function c1 = log (1 + pt2 / (xb * (data%mZ)**2)) c2 = 1 / (1 + (xb * (data%mZ)**2) / pt2) case (24) !!! W boson structure function c1 = log (1 + pt2 / (xb * (data%mW)**2)) c2 = 1 / (1 + (xb * (data%mW)**2) / pt2) end select do i = 1, sf_int%n_me cv = sf_int%cv(i) ca = sf_int%ca(i) fm = data%coeff * & ((cv + ca)**2 + ((cv - ca) * xb)**2) * (c1 - c2) / (2 * x) fp = data%coeff * & ((cv - ca)**2 + ((cv + ca) * xb)**2) * (c1 - c2) / (2 * x) fL = data%coeff * & (cv**2 + ca**2) * (2 * xb / x) * c2 f = fp + fm + fL if (.not. vanishes (f)) then fp = fp / f fm = fm / f fL = fL / f end if call sf_int%set_matrix_element (i, cmplx (f, kind=default)) end do end associate sf_int%status = SF_EVALUATED end subroutine ewa_apply @ %def ewa_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_ewa_ut.f90]]>>= <> module sf_ewa_ut use unit_tests use sf_ewa_uti <> <> contains <> end module sf_ewa_ut @ %def sf_ewa_ut @ <<[[sf_ewa_uti.f90]]>>= <> module sf_ewa_uti <> use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use interactions, only: interaction_pacify_momenta use model_data use sf_aux use sf_base use sf_ewa <> <> contains <> end module sf_ewa_uti @ %def sf_ewa_ut @ API: driver for the unit tests below. <>= public :: sf_ewa_test <>= subroutine sf_ewa_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_ewa_test @ %def sf_ewa_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_ewa_1, "sf_ewa_1", & "structure function configuration", & u, results) <>= public :: sf_ewa_1 <>= subroutine sf_ewa_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_ewa_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_sm_test () pdg_in = 2 allocate (ewa_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize for Z boson" write (u, "(A)") select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 5000._default, .false., .false.) call data%set_id (23) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 write (u, "(A)") write (u, "(A)") "* Initialize for W boson" write (u, "(A)") deallocate (data) allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 5000._default, .false., .false.) call data%set_id (24) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_1" end subroutine sf_ewa_1 @ %def sf_ewa_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the EWA structure function. <>= call test (sf_ewa_2, "sf_ewa_2", & "structure function instance", & u, results) <>= public :: sf_ewa_2 <>= subroutine sf_ewa_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (2, model) pdg_in = 2 call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000._default, .false., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EWA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_2" end subroutine sf_ewa_2 @ %def sf_ewa_2 @ \subsubsection{Standard mapping} Construct and display a structure function object based on the EWA structure function, applying the standard single-particle mapping. <>= call test (sf_ewa_3, "sf_ewa_3", & "apply mapping", & u, results) <>= public :: sf_ewa_3 <>= subroutine sf_ewa_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_3" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (2, model) pdg_in = 2 call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000._default, .false., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, with EWA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_3" end subroutine sf_ewa_3 @ %def sf_ewa_3 @ \subsubsection{Non-collinear case} Construct and display a structure function object based on the EPA structure function. <>= call test (sf_ewa_4, "sf_ewa_4", & "non-collinear", & u, results) <>= public :: sf_ewa_4 <>= subroutine sf_ewa_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_4" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call modeL%init_sm_test () call flv%init (2, model) pdg_in = 2 call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000.0_default, .true., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.5/0.5/0.25, with EWA mapping, " write (u, "(A)") " non-coll., keeping energy" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.5_default, 0.5_default, 0.25_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x and r from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 1500._default) call sf_int%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_4" end subroutine sf_ewa_4 @ %def sf_ewa_4 @ \subsubsection{Structure function for multiple flavors} Construct and display a structure function object based on the EWA structure function. The incoming state has multiple particles with non-uniform quantum numbers. <>= call test (sf_ewa_5, "sf_ewa_5", & "structure function instance", & u, results) <>= public :: sf_ewa_5 <>= subroutine sf_ewa_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_5" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (2, model) pdg_in = [1, 2, -1, -2] call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000._default, .false., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EWA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_5" end subroutine sf_ewa_5 @ %def sf_ewa_5 @ \clearpage %------------------------------------------------------------------------ \section{Energy-scan spectrum} This spectrum is actually a trick that allows us to plot the c.m.\ energy dependence of a cross section without scanning the input energy. We start with the observation that a spectrum $f(x)$, applied to one of the incoming beams only, results in a cross section \begin{equation} \sigma = \int dx\,f(x)\,\hat\sigma(xs). \end{equation} We want to compute the distribution of $E=\sqrt{\hat s}=\sqrt{xs}$, i.e., \begin{equation} \frac{d\sigma}{dE} = \frac{2\sqrt{x}}{\sqrt{s}}\,\frac{d\sigma}{dx} = \frac{2\sqrt{x}}{\sqrt{s}}\,f(x)\,\hat\sigma(xs), \end{equation} so if we set \begin{equation} f(x) = \frac{\sqrt{s}}{2\sqrt{x}}, \end{equation} we get the distribution \begin{equation} \frac{d\sigma}{dE} = \hat\sigma(\hat s=E^2). \end{equation} We implement this as a spectrum with a single parameter $x$. The parameters for the individual beams are computed as $x_i=\sqrt{x}$, so they are equal and the kinematics is always symmetric. <<[[sf_escan.f90]]>>= <> module sf_escan <> <> use io_units use format_defs, only: FMT_12 use numeric_utils use diagnostics use lorentz use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use sf_base <> <> <> contains <> end module sf_escan @ %def sf_escan @ \subsection{Data type} The [[norm]] is unity if the total cross section should be normalized to one, and $\sqrt{s}$ if it should be normalized to the total energy. In the latter case, the differential distribution $d\sigma/d\sqrt{\hat s}$ coincides with the partonic cross section $\hat\sigma$ as a function of $\sqrt{\hat s}$. <>= public :: escan_data_t <>= type, extends(sf_data_t) :: escan_data_t private type(flavor_t), dimension(:,:), allocatable :: flv_in integer, dimension(2) :: n_flv = 0 real(default) :: norm = 1 contains <> end type escan_data_t @ %def escan_data_t <>= procedure :: init => escan_data_init <>= subroutine escan_data_init (data, model, pdg_in, norm) class(escan_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in), optional :: norm real(default), dimension(2) :: m2 integer :: i, j data%n_flv = pdg_array_get_length (pdg_in) allocate (data%flv_in (maxval (data%n_flv), 2)) do i = 1, 2 do j = 1, data%n_flv(i) call data%flv_in(j, i)%init (pdg_array_get (pdg_in(i), j), model) end do end do m2 = data%flv_in(1,:)%get_mass () do i = 1, 2 if (.not. any (nearly_equal (data%flv_in(1:data%n_flv(i),i)%get_mass (), m2(i)))) then call msg_fatal ("Energy scan: incoming particle mass must be uniform") end if end do if (present (norm)) data%norm = norm end subroutine escan_data_init @ %def escan_data_init @ Output <>= procedure :: write => escan_data_write <>= subroutine escan_data_write (data, unit, verbose) class(escan_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i, j u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Energy-scan data:" write (u, "(3x,A)", advance="no") "prt_in = " do i = 1, 2 if (i > 1) write (u, "(',',1x)", advance="no") do j = 1, data%n_flv(i) if (j > 1) write (u, "(':')", advance="no") write (u, "(A)", advance="no") char (data%flv_in(j,i)%get_name ()) end do end do write (u, *) write (u, "(3x,A," // FMT_12 // ")") "norm =", data%norm end subroutine escan_data_write @ %def escan_data_write @ Kinematics is completely collinear, hence there is only one parameter for a pair spectrum. <>= procedure :: get_n_par => escan_data_get_n_par <>= function escan_data_get_n_par (data) result (n) class(escan_data_t), intent(in) :: data integer :: n n = 1 end function escan_data_get_n_par @ %def escan_data_get_n_par @ Return the outgoing particles PDG codes. This is always the same as the incoming particle, where we use two indices for the two beams. <>= procedure :: get_pdg_out => escan_data_get_pdg_out <>= subroutine escan_data_get_pdg_out (data, pdg_out) class(escan_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%flv_in(1:data%n_flv(i),i)%get_pdg () end do end subroutine escan_data_get_pdg_out @ %def escan_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => escan_data_allocate_sf_int <>= subroutine escan_data_allocate_sf_int (data, sf_int) class(escan_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (escan_t :: sf_int) end subroutine escan_data_allocate_sf_int @ %def escan_data_allocate_sf_int @ \subsection{The Energy-scan object} This is a spectrum, not a radiation. We create an interaction with two incoming and two outgoing particles, flavor, color, and helicity being carried through. $x$ nevertheless is only one-dimensional, as we are always using only one beam parameter. <>= type, extends (sf_int_t) :: escan_t type(escan_data_t), pointer :: data => null () contains <> end type escan_t @ %def escan_t @ Type string: for the energy scan this is just a dummy function. <>= procedure :: type_string => escan_type_string <>= function escan_type_string (object) result (string) class(escan_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "Escan: energy scan" else string = "Escan: [undefined]" end if end function escan_type_string @ %def escan_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => escan_write <>= subroutine escan_write (object, unit, testflag) class(escan_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "Energy scan data: [undefined]" end if end subroutine escan_write @ %def escan_write @ <>= procedure :: init => escan_init <>= subroutine escan_init (sf_int, data) class(escan_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(4) :: mask integer, dimension(4) :: hel_lock real(default), dimension(2) :: m2 real(default), dimension(0) :: mr2 type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn type(polarization_t), target :: pol1, pol2 type(polarization_iterator_t) :: it_hel1, it_hel2 integer :: j1, j2 select type (data) type is (escan_data_t) hel_lock = [3, 4, 1, 2] m2 = data%flv_in(1,:)%get_mass () call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock) sf_int%data => data do j1 = 1, data%n_flv(1) call qn_fc(1)%init ( & flv = data%flv_in(j1,1), & col = color_from_flavor (data%flv_in(j1,1))) call qn_fc(3)%init ( & flv = data%flv_in(j1,1), & col = color_from_flavor (data%flv_in(j1,1))) call pol1%init_generic (data%flv_in(j1,1)) do j2 = 1, data%n_flv(2) call qn_fc(2)%init ( & flv = data%flv_in(j2,2), & col = color_from_flavor (data%flv_in(j2,2))) call qn_fc(4)%init ( & flv = data%flv_in(j2,2), & col = color_from_flavor (data%flv_in(j2,2))) call pol2%init_generic (data%flv_in(j2,2)) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel(1) = it_hel1%get_quantum_numbers () qn_hel(3) = it_hel1%get_quantum_numbers () call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel(2) = it_hel2%get_quantum_numbers () qn_hel(4) = it_hel2%get_quantum_numbers () qn = qn_hel .merge. qn_fc call sf_int%add_state (qn) call it_hel2%advance () end do call it_hel1%advance () end do ! call pol2%final () end do ! call pol1%final () end do call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%freeze () sf_int%status = SF_INITIAL end select end subroutine escan_init @ %def escan_init @ \subsection{Kinematics} Set kinematics. We have a single parameter, but reduce both beams. The [[map]] flag is ignored. <>= procedure :: complete_kinematics => escan_complete_kinematics <>= subroutine escan_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default) :: sqrt_x real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map x = r xb= rb sqrt_x = sqrt (x(1)) if (sqrt_x > 0) then f = 1 / (2 * sqrt_x) else f = 0 sf_int%status = SF_FAILED_KINEMATICS return end if call sf_int%reduce_momenta ([sqrt_x, sqrt_x]) end subroutine escan_complete_kinematics @ %def escan_complete_kinematics @ Recover $x$. The base procedure should return two momentum fractions for the two beams, while we have only one parameter. This is the product of the extracted momentum fractions. <>= procedure :: recover_x => escan_recover_x <>= subroutine escan_recover_x (sf_int, x, xb, x_free) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: xi, xib call sf_int%base_recover_x (xi, xib, x_free) x = product (xi) xb= 1 - x end subroutine escan_recover_x @ %def escan_recover_x @ Compute inverse kinematics. <>= procedure :: inverse_kinematics => escan_inverse_kinematics <>= subroutine escan_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: sqrt_x logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta sqrt_x = sqrt (x(1)) if (sqrt_x > 0) then f = 1 / (2 * sqrt_x) else f = 0 sf_int%status = SF_FAILED_KINEMATICS return end if r = x rb = xb if (set_mom) then call sf_int%reduce_momenta ([sqrt_x, sqrt_x]) end if end subroutine escan_inverse_kinematics @ %def escan_inverse_kinematics @ \subsection{Energy scan application} Here, we insert the predefined norm. <>= procedure :: apply => escan_apply <>= subroutine escan_apply (sf_int, scale, rescale, i_sub, fill_sub) class(escan_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub logical, intent(in), optional :: fill_sub real(default) :: f associate (data => sf_int%data) f = data%norm end associate call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine escan_apply @ %def escan_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_escan_ut.f90]]>>= <> module sf_escan_ut use unit_tests use sf_escan_uti <> <> contains <> end module sf_escan_ut @ %def sf_escan_ut @ <<[[sf_escan_uti.f90]]>>= <> module sf_escan_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_aux use sf_base use sf_escan <> <> contains <> end module sf_escan_uti @ %def sf_escan_ut @ API: driver for the unit tests below. <>= public :: sf_escan_test <>= subroutine sf_escan_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_escan_test @ %def sf_escan_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_escan_1, "sf_escan_1", & "structure function configuration", & u, results) <>= public :: sf_escan_1 <>= subroutine sf_escan_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_escan_1" write (u, "(A)") "* Purpose: initialize and display & &energy-scan structure function data" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (escan_data_t :: data) select type (data) type is (escan_data_t) call data%init (model, pdg_in, norm = 2._default) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_escan_1" end subroutine sf_escan_1 @ %def sf_escan_1 g@ \subsubsection{Probe the structure-function object} Active the beam event reader, generate an event. <>= call test (sf_escan_2, "sf_escan_2", & "generate event", & u, results) <>= public :: sf_escan_2 <>= subroutine sf_escan_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: x_free, f write (u, "(A)") "* Test output: sf_escan_2" write (u, "(A)") "* Purpose: initialize and display & &beam-events structure function data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (escan_data_t :: data) select type (data) type is (escan_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set dummy parameters and generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.8 rb = 1 - r x_free = 1 call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call sf_int%recover_x (x, xb, x_free) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_escan_2" end subroutine sf_escan_2 @ %def sf_escan_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Gaussian beam spread} Instead of an analytic beam description, beam data may be provided in form of an event file. In its most simple form, the event file contains pairs of $x$ values, relative to nominal beam energies. More advanced formats may include polarization, etc. The current implementation carries beam polarization through, if specified. The code is very similar to the energy scan described above. However, we must include a file-handle manager for the beam-event files. Two different processes may access a given beam-event file at the same time (i.e., serially but alternating). Accessing an open file from two different units is non-standard and not supported by all compilers. Therefore, we keep a global registry of open files, associated units, and reference counts. The [[gaussian_t]] objects act as proxies to this registry. <<[[sf_gaussian.f90]]>>= <> module sf_gaussian <> <> use io_units use format_defs, only: FMT_12 use file_registries use diagnostics use lorentz use rng_base use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use sf_base <> <> <> contains <> end module sf_gaussian @ %def sf_gaussian @ \subsection{The beam-data file registry} We manage data files via the [[file_registries]] module. To this end, we keep the registry as a private module variable here. <>= type(file_registry_t), save :: beam_file_registry @ %def beam_file_registry @ \subsection{Data type} We store the spread for each beam, as a relative number related to the beam energy. For the actual generation, we include an (abstract) random-number generator factory. <>= public :: gaussian_data_t <>= type, extends(sf_data_t) :: gaussian_data_t private type(flavor_t), dimension(2) :: flv_in real(default), dimension(2) :: spread class(rng_factory_t), allocatable :: rng_factory contains <> end type gaussian_data_t @ %def gaussian_data_t <>= procedure :: init => gaussian_data_init <>= subroutine gaussian_data_init (data, model, pdg_in, spread, rng_factory) class(gaussian_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), dimension(2), intent(in) :: spread class(rng_factory_t), intent(inout), allocatable :: rng_factory if (any (spread < 0)) then call msg_fatal ("Gaussian beam spread: must not be negative") end if call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model) call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model) data%spread = spread call move_alloc (from = rng_factory, to = data%rng_factory) end subroutine gaussian_data_init @ %def gaussian_data_init @ Return true since this spectrum is always in generator mode. <>= procedure :: is_generator => gaussian_data_is_generator <>= function gaussian_data_is_generator (data) result (flag) class(gaussian_data_t), intent(in) :: data logical :: flag flag = .true. end function gaussian_data_is_generator @ %def gaussian_data_is_generator @ The number of parameters is two. They are free parameters. <>= procedure :: get_n_par => gaussian_data_get_n_par <>= function gaussian_data_get_n_par (data) result (n) class(gaussian_data_t), intent(in) :: data integer :: n n = 2 end function gaussian_data_get_n_par @ %def gaussian_data_get_n_par <>= procedure :: get_pdg_out => gaussian_data_get_pdg_out <>= subroutine gaussian_data_get_pdg_out (data, pdg_out) class(gaussian_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%flv_in(i)%get_pdg () end do end subroutine gaussian_data_get_pdg_out @ %def gaussian_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => gaussian_data_allocate_sf_int <>= subroutine gaussian_data_allocate_sf_int (data, sf_int) class(gaussian_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (gaussian_t :: sf_int) end subroutine gaussian_data_allocate_sf_int @ %def gaussian_data_allocate_sf_int @ Output <>= procedure :: write => gaussian_data_write <>= subroutine gaussian_data_write (data, unit, verbose) class(gaussian_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Gaussian beam spread data:" write (u, "(3x,A,A,A,A)") "prt_in = ", & char (data%flv_in(1)%get_name ()), & ", ", char (data%flv_in(2)%get_name ()) write (u, "(3x,A,2(1x," // FMT_12 // "))") "spread =", data%spread call data%rng_factory%write (u) end subroutine gaussian_data_write @ %def gaussian_data_write @ \subsection{The gaussian object} Flavor and polarization carried through, no radiated particles. The generator needs a random-number generator, obviously. <>= public :: gaussian_t <>= type, extends (sf_int_t) :: gaussian_t type(gaussian_data_t), pointer :: data => null () class(rng_t), allocatable :: rng contains <> end type gaussian_t @ %def gaussian_t @ Type string: show gaussian file. <>= procedure :: type_string => gaussian_type_string <>= function gaussian_type_string (object) result (string) class(gaussian_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "Gaussian: gaussian beam-energy spread" else string = "Gaussian: [undefined]" end if end function gaussian_type_string @ %def gaussian_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => gaussian_write <>= subroutine gaussian_write (object, unit, testflag) class(gaussian_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%rng%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "gaussian data: [undefined]" end if end subroutine gaussian_write @ %def gaussian_write @ <>= procedure :: init => gaussian_init <>= subroutine gaussian_init (sf_int, data) class(gaussian_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data real(default), dimension(2) :: m2 real(default), dimension(0) :: mr2 type(quantum_numbers_mask_t), dimension(4) :: mask integer, dimension(4) :: hel_lock type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn type(polarization_t), target :: pol1, pol2 type(polarization_iterator_t) :: it_hel1, it_hel2 integer :: i select type (data) type is (gaussian_data_t) m2 = data%flv_in%get_mass () ** 2 hel_lock = [3, 4, 1, 2] mask = quantum_numbers_mask (.false., .false., .false.) call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock) sf_int%data => data do i = 1, 2 call qn_fc(i)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) call qn_fc(i+2)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) end do call pol1%init_generic (data%flv_in(1)) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel(1) = it_hel1%get_quantum_numbers () qn_hel(3) = it_hel1%get_quantum_numbers () call pol2%init_generic (data%flv_in(2)) call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel(2) = it_hel2%get_quantum_numbers () qn_hel(4) = it_hel2%get_quantum_numbers () qn = qn_hel .merge. qn_fc call sf_int%add_state (qn) call it_hel2%advance () end do ! call pol2%final () call it_hel1%advance () end do ! call pol1%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) sf_int%status = SF_INITIAL end select call sf_int%data%rng_factory%make (sf_int%rng) end subroutine gaussian_init @ %def gaussian_init @ This spectrum type needs a finalizer, which closes the data file. <>= procedure :: final => sf_gaussian_final <>= subroutine sf_gaussian_final (object) class(gaussian_t), intent(inout) :: object call object%interaction_t%final () end subroutine sf_gaussian_final @ %def sf_gaussian_final @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => gaussian_is_generator <>= function gaussian_is_generator (sf_int) result (flag) class(gaussian_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function gaussian_is_generator @ %def gaussian_is_generator @ Generate free parameters. The $x$ value should be distributed with mean $1$ and $\sigma$ given by the spread. We reject negative $x$ values. (This cut slightly biases the distribution, but for reasonable (small) spreads negative $r$ should not occur. <>= procedure :: generate_free => gaussian_generate_free <>= subroutine gaussian_generate_free (sf_int, r, rb, x_free) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free real(default), dimension(size(r)) :: z associate (data => sf_int%data) do call sf_int%rng%generate_gaussian (z) rb = z * data%spread r = 1 - rb x_free = x_free * product (r) if (all (r > 0)) exit end do end associate end subroutine gaussian_generate_free @ %def gaussian_generate_free @ Set kinematics. Trivial transfer since this is a pure generator. The [[map]] flag doesn't apply. <>= procedure :: complete_kinematics => gaussian_complete_kinematics <>= subroutine gaussian_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("gaussian: map flag not supported") else x = r xb= rb f = 1 end if call sf_int%reduce_momenta (x) end subroutine gaussian_complete_kinematics @ %def gaussian_complete_kinematics @ Compute inverse kinematics. Trivial in this case. <>= procedure :: inverse_kinematics => gaussian_inverse_kinematics <>= subroutine gaussian_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("gaussian: map flag not supported") else r = x rb= xb f = 1 end if if (set_mom) then call sf_int%reduce_momenta (x) end if end subroutine gaussian_inverse_kinematics @ %def gaussian_inverse_kinematics @ \subsection{gaussian application} Trivial, just set the unit weight. <>= procedure :: apply => gaussian_apply <>= subroutine gaussian_apply (sf_int, scale, rescale, i_sub, fill_sub) class(gaussian_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub logical, intent(in), optional :: fill_sub real(default) :: f f = 1 call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine gaussian_apply @ %def gaussian_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_gaussian_ut.f90]]>>= <> module sf_gaussian_ut use unit_tests use sf_gaussian_uti <> <> contains <> end module sf_gaussian_ut @ %def sf_gaussian_ut @ <<[[sf_gaussian_uti.f90]]>>= <> module sf_gaussian_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use rng_base use sf_aux use sf_base use sf_gaussian use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module sf_gaussian_uti @ %def sf_gaussian_ut @ API: driver for the unit tests below. <>= public :: sf_gaussian_test <>= subroutine sf_gaussian_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_gaussian_test @ %def sf_gaussian_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_gaussian_1, "sf_gaussian_1", & "structure function configuration", & u, results) <>= public :: sf_gaussian_1 <>= subroutine sf_gaussian_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data class(rng_factory_t), allocatable :: rng_factory write (u, "(A)") "* Test output: sf_gaussian_1" write (u, "(A)") "* Purpose: initialize and display & &gaussian-spread structure function data" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (gaussian_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (gaussian_data_t) call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_gaussian_1" end subroutine sf_gaussian_1 @ %def sf_gaussian_1 @ \subsubsection{Probe the structure-function object} Active the beam event reader, generate an event. <>= call test (sf_gaussian_2, "sf_gaussian_2", & "generate event", & u, results) <>= public :: sf_gaussian_2 <>= subroutine sf_gaussian_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: x_free, f integer :: i write (u, "(A)") "* Test output: sf_gaussian_2" write (u, "(A)") "* Purpose: initialize and display & &gaussian-spread structure function data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (gaussian_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (gaussian_data_t) call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set dummy parameters and generate x." write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call pacify (rb, 1.e-8_default) call pacify (xb, 1.e-8_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Generate more events" write (u, "(A)") select type (sf_int) type is (gaussian_t) do i = 1, 3 call sf_int%generate_free (r, rb, x_free) write (u, "(A,9(1x,F10.7))") "r =", r end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_gaussian_2" end subroutine sf_gaussian_2 @ %def sf_gaussian_2 @ \clearpage @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Using beam event data} Instead of an analytic beam description, beam data may be provided in form of an event file. In its most simple form, the event file contains pairs of $x$ values, relative to nominal beam energies. More advanced formats may include polarization, etc. The current implementation carries beam polarization through, if specified. The code is very similar to the energy scan described above. However, we must include a file-handle manager for the beam-event files. Two different processes may access a given beam-event file at the same time (i.e., serially but alternating). Accessing an open file from two different units is non-standard and not supported by all compilers. Therefore, we keep a global registry of open files, associated units, and reference counts. The [[beam_events_t]] objects act as proxies to this registry. <<[[sf_beam_events.f90]]>>= <> module sf_beam_events <> <> use io_units use file_registries use diagnostics use lorentz use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use sf_base <> <> <> <> contains <> end module sf_beam_events @ %def sf_beam_events @ \subsection{The beam-data file registry} We manage data files via the [[file_registries]] module. To this end, we keep the registry as a private module variable here. This is public only for the unit tests. <>= public :: beam_file_registry <>= type(file_registry_t), save :: beam_file_registry @ %def beam_file_registry @ \subsection{Data type} <>= public :: beam_events_data_t <>= type, extends(sf_data_t) :: beam_events_data_t private type(flavor_t), dimension(2) :: flv_in type(string_t) :: dir type(string_t) :: file type(string_t) :: fqn integer :: unit = 0 logical :: warn_eof = .true. contains <> end type beam_events_data_t @ %def beam_events_data_t <>= procedure :: init => beam_events_data_init <>= subroutine beam_events_data_init (data, model, pdg_in, dir, file, warn_eof) class(beam_events_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in type(string_t), intent(in) :: dir type(string_t), intent(in) :: file logical, intent(in), optional :: warn_eof if (any (pdg_array_get_length (pdg_in) /= 1)) then call msg_fatal ("Beam events: incoming beam particles must be unique") end if call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model) call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model) data%dir = dir data%file = file if (present (warn_eof)) data%warn_eof = warn_eof end subroutine beam_events_data_init @ %def beam_events_data_init @ Return true since this spectrum is always in generator mode. <>= procedure :: is_generator => beam_events_data_is_generator <>= function beam_events_data_is_generator (data) result (flag) class(beam_events_data_t), intent(in) :: data logical :: flag flag = .true. end function beam_events_data_is_generator @ %def beam_events_data_is_generator @ The number of parameters is two. They are free parameters. <>= procedure :: get_n_par => beam_events_data_get_n_par <>= function beam_events_data_get_n_par (data) result (n) class(beam_events_data_t), intent(in) :: data integer :: n n = 2 end function beam_events_data_get_n_par @ %def beam_events_data_get_n_par <>= procedure :: get_pdg_out => beam_events_data_get_pdg_out <>= subroutine beam_events_data_get_pdg_out (data, pdg_out) class(beam_events_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%flv_in(i)%get_pdg () end do end subroutine beam_events_data_get_pdg_out @ %def beam_events_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => beam_events_data_allocate_sf_int <>= subroutine beam_events_data_allocate_sf_int (data, sf_int) class(beam_events_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (beam_events_t :: sf_int) end subroutine beam_events_data_allocate_sf_int @ %def beam_events_data_allocate_sf_int @ Output <>= procedure :: write => beam_events_data_write <>= subroutine beam_events_data_write (data, unit, verbose) class(beam_events_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Beam-event file data:" write (u, "(3x,A,A,A,A)") "prt_in = ", & char (data%flv_in(1)%get_name ()), & ", ", char (data%flv_in(2)%get_name ()) write (u, "(3x,A,A,A)") "file = '", char (data%file), "'" write (u, "(3x,A,I0)") "unit = ", data%unit write (u, "(3x,A,L1)") "warn = ", data%warn_eof end subroutine beam_events_data_write @ %def beam_events_data_write @ The data file needs to be opened and closed explicitly. The open/close message is communicated to the file handle registry, which does the actual work. We determine first whether to look in the local directory or in the given system directory. <>= procedure :: open => beam_events_data_open procedure :: close => beam_events_data_close <>= subroutine beam_events_data_open (data) class(beam_events_data_t), intent(inout) :: data logical :: exist if (data%unit == 0) then data%fqn = data%file if (data%fqn == "") & call msg_fatal ("Beam events: $beam_events_file is not set") inquire (file = char (data%fqn), exist = exist) if (.not. exist) then data%fqn = data%dir // "/" // data%file inquire (file = char (data%fqn), exist = exist) if (.not. exist) then data%fqn = "" call msg_fatal ("Beam events: file '" & // char (data%file) // "' not found") return end if end if call msg_message ("Beam events: reading from file '" & // char (data%file) // "'") call beam_file_registry%open (data%fqn, data%unit) else call msg_bug ("Beam events: file '" & // char (data%file) // "' is already open") end if end subroutine beam_events_data_open subroutine beam_events_data_close (data) class(beam_events_data_t), intent(inout) :: data if (data%unit /= 0) then call beam_file_registry%close (data%fqn) call msg_message ("Beam events: closed file '" & // char (data%file) // "'") data%unit = 0 end if end subroutine beam_events_data_close @ %def beam_events_data_close @ Return the beam event file. <>= procedure :: get_beam_file => beam_events_data_get_beam_file <>= function beam_events_data_get_beam_file (data) result (file) class(beam_events_data_t), intent(in) :: data type(string_t) :: file file = "Beam events: " // data%file end function beam_events_data_get_beam_file @ %def beam_events_data_get_beam_file @ \subsection{The beam events object} Flavor and polarization carried through, no radiated particles. <>= public :: beam_events_t <>= type, extends (sf_int_t) :: beam_events_t type(beam_events_data_t), pointer :: data => null () integer :: count = 0 contains <> end type beam_events_t @ %def beam_events_t @ Type string: show beam events file. <>= procedure :: type_string => beam_events_type_string <>= function beam_events_type_string (object) result (string) class(beam_events_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "Beam events: " // object%data%file else string = "Beam events: [undefined]" end if end function beam_events_type_string @ %def beam_events_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => beam_events_write <>= subroutine beam_events_write (object, unit, testflag) class(beam_events_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "Beam events data: [undefined]" end if end subroutine beam_events_write @ %def beam_events_write @ <>= procedure :: init => beam_events_init <>= subroutine beam_events_init (sf_int, data) class(beam_events_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data real(default), dimension(2) :: m2 real(default), dimension(0) :: mr2 type(quantum_numbers_mask_t), dimension(4) :: mask integer, dimension(4) :: hel_lock type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn type(polarization_t), target :: pol1, pol2 type(polarization_iterator_t) :: it_hel1, it_hel2 integer :: i select type (data) type is (beam_events_data_t) m2 = data%flv_in%get_mass () ** 2 hel_lock = [3, 4, 1, 2] mask = quantum_numbers_mask (.false., .false., .false.) call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock) sf_int%data => data do i = 1, 2 call qn_fc(i)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) call qn_fc(i+2)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) end do call pol1%init_generic (data%flv_in(1)) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel(1) = it_hel1%get_quantum_numbers () qn_hel(3) = it_hel1%get_quantum_numbers () call pol2%init_generic (data%flv_in(2)) call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel(2) = it_hel2%get_quantum_numbers () qn_hel(4) = it_hel2%get_quantum_numbers () qn = qn_hel .merge. qn_fc call sf_int%add_state (qn) call it_hel2%advance () end do ! call pol2%final () call it_hel1%advance () end do ! call pol1%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%data%open () sf_int%status = SF_INITIAL end select end subroutine beam_events_init @ %def beam_events_init @ This spectrum type needs a finalizer, which closes the data file. <>= procedure :: final => sf_beam_events_final <>= subroutine sf_beam_events_final (object) class(beam_events_t), intent(inout) :: object call object%data%close () call object%interaction_t%final () end subroutine sf_beam_events_final @ %def sf_beam_events_final @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => beam_events_is_generator <>= function beam_events_is_generator (sf_int) result (flag) class(beam_events_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function beam_events_is_generator @ %def beam_events_is_generator @ Generate free parameters. We read them from file. <>= procedure :: generate_free => beam_events_generate_free <>= recursive subroutine beam_events_generate_free (sf_int, r, rb, x_free) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free integer :: iostat associate (data => sf_int%data) if (data%unit /= 0) then read (data%unit, fmt=*, iostat=iostat) r if (iostat > 0) then write (msg_buffer, "(A,I0,A)") & "Beam events: I/O error after reading ", sf_int%count, & " events" call msg_fatal () else if (iostat < 0) then if (sf_int%count == 0) then call msg_fatal ("Beam events: file is empty") else if (sf_int%data%warn_eof) then write (msg_buffer, "(A,I0,A)") & "Beam events: End of file after reading ", sf_int%count, & " events, rewinding" call msg_warning () end if rewind (data%unit) sf_int%count = 0 call sf_int%generate_free (r, rb, x_free) else sf_int%count = sf_int%count + 1 rb = 1 - r x_free = x_free * product (r) end if else call msg_bug ("Beam events: file is not open for reading") end if end associate end subroutine beam_events_generate_free @ %def beam_events_generate_free @ Set kinematics. Trivial transfer since this is a pure generator. The [[map]] flag doesn't apply. <>= procedure :: complete_kinematics => beam_events_complete_kinematics <>= subroutine beam_events_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("Beam events: map flag not supported") else x = r xb= rb f = 1 end if call sf_int%reduce_momenta (x) end subroutine beam_events_complete_kinematics @ %def beam_events_complete_kinematics @ Compute inverse kinematics. Trivial in this case. <>= procedure :: inverse_kinematics => beam_events_inverse_kinematics <>= subroutine beam_events_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("Beam events: map flag not supported") else r = x rb= xb f = 1 end if if (set_mom) then call sf_int%reduce_momenta (x) end if end subroutine beam_events_inverse_kinematics @ %def beam_events_inverse_kinematics @ \subsection{Beam events application} Trivial, just set the unit weight. <>= procedure :: apply => beam_events_apply <>= subroutine beam_events_apply (sf_int, scale, rescale, i_sub, fill_sub) class(beam_events_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub logical, intent(in), optional :: fill_sub real(default) :: f f = 1 call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine beam_events_apply @ %def beam_events_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_beam_events_ut.f90]]>>= <> module sf_beam_events_ut use unit_tests use sf_beam_events_uti <> <> contains <> end module sf_beam_events_ut @ %def sf_beam_events_ut @ <<[[sf_beam_events_uti.f90]]>>= <> module sf_beam_events_uti <> <> use io_units use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_aux use sf_base use sf_beam_events <> <> contains <> end module sf_beam_events_uti @ %def sf_beam_events_ut @ API: driver for the unit tests below. <>= public :: sf_beam_events_test <>= subroutine sf_beam_events_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_beam_events_test @ %def sf_beam_events_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_beam_events_1, "sf_beam_events_1", & "structure function configuration", & u, results) <>= public :: sf_beam_events_1 <>= subroutine sf_beam_events_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_beam_events_1" write (u, "(A)") "* Purpose: initialize and display & &beam-events structure function data" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (beam_events_data_t :: data) select type (data) type is (beam_events_data_t) call data%init (model, pdg_in, var_str (""), var_str ("beam_events.dat")) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_beam_events_1" end subroutine sf_beam_events_1 @ %def sf_beam_events_1 @ \subsubsection{Probe the structure-function object} Active the beam event reader, generate an event. <>= call test (sf_beam_events_2, "sf_beam_events_2", & "generate event", & u, results) <>= public :: sf_beam_events_2 <>= subroutine sf_beam_events_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: x_free, f integer :: i write (u, "(A)") "* Test output: sf_beam_events_2" write (u, "(A)") "* Purpose: initialize and display & &beam-events structure function data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (beam_events_data_t :: data) select type (data) type is (beam_events_data_t) call data%init (model, pdg_in, & var_str (""), var_str ("test_beam_events.dat")) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set dummy parameters and generate x." write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free select type (sf_int) type is (beam_events_t) write (u, "(A,1x,I0)") "count =", sf_int%count end select write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Generate more events, rewind" write (u, "(A)") select type (sf_int) type is (beam_events_t) do i = 1, 3 call sf_int%generate_free (r, rb, x_free) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,1x,I0)") "count =", sf_int%count end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_beam_events_2" end subroutine sf_beam_events_2 @ %def sf_beam_events_2 @ \subsubsection{Check the file handle registry} Open and close some files, checking the registry contents. <>= call test (sf_beam_events_3, "sf_beam_events_3", & "check registry", & u, results) <>= public :: sf_beam_events_3 <>= subroutine sf_beam_events_3 (u) integer, intent(in) :: u integer :: u1 write (u, "(A)") "* Test output: sf_beam_events_2" write (u, "(A)") "* Purpose: check file handle registry" write (u, "(A)") write (u, "(A)") "* Create some empty files" write (u, "(A)") u1 = free_unit () open (u1, file = "sf_beam_events_f1.tmp", action="write", status="new") close (u1) open (u1, file = "sf_beam_events_f2.tmp", action="write", status="new") close (u1) open (u1, file = "sf_beam_events_f3.tmp", action="write", status="new") close (u1) write (u, "(A)") "* Empty registry" write (u, "(A)") call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Insert three entries" write (u, "(A)") call beam_file_registry%open (var_str ("sf_beam_events_f3.tmp")) call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%open (var_str ("sf_beam_events_f1.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Open a second channel" write (u, "(A)") call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Close second entry twice" write (u, "(A)") call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Close last entry" write (u, "(A)") call beam_file_registry%close (var_str ("sf_beam_events_f3.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Close remaining entry" write (u, "(A)") call beam_file_registry%close (var_str ("sf_beam_events_f1.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" open (u1, file = "sf_beam_events_f1.tmp", action="write") close (u1, status = "delete") open (u1, file = "sf_beam_events_f2.tmp", action="write") close (u1, status = "delete") open (u1, file = "sf_beam_events_f3.tmp", action="write") close (u1, status = "delete") write (u, "(A)") write (u, "(A)") "* Test output end: sf_beam_events_3" end subroutine sf_beam_events_3 @ %def sf_beam_events_3 @ \clearpage %------------------------------------------------------------------------ \section{Lepton collider beamstrahlung: CIRCE1} <<[[sf_circe1.f90]]>>= <> module sf_circe1 <> use kinds, only: double <> use io_units use format_defs, only: FMT_17, FMT_19 use diagnostics use physics_defs, only: ELECTRON, PHOTON use lorentz use rng_base use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use sf_mappings use sf_base use circe1, circe1_rng_t => rng_type !NODEP! <> <> <> contains <> end module sf_circe1 @ %def sf_circe1 @ \subsection{Physics} Beamstrahlung is applied before ISR. The [[CIRCE1]] implementation has a single structure function for both beams (which makes sense since it has to be switched on or off for both beams simultaneously). Nevertheless it is factorized: The functional form in the [[CIRCE1]] parameterization is defined for electrons or photons \begin{equation} f(x) = \alpha\,x^\beta\,(1-x)^\gamma \end{equation} for $x<1-\epsilon$ (resp.\ $x>\epsilon$ in the photon case). In the remaining interval, the standard form is zero, with a delta singularity at $x=1$ (resp.\ $x=0$). Equivalently, the delta part may be distributed uniformly among this interval. This latter form is implemented in the [[kirke]] version of the [[CIRCE1]] subroutines, and is used here. The parameter [[circe1\_eps]] sets the peak mapping of the [[CIRCE1]] structure function. Its default value is $10^{-5}$. The other parameters are the parameterization version and revision number, the accelerator type, and the $\sqrt{s}$ value used by [[CIRCE1]]. The chattiness can also be set. Since the energy is distributed in a narrow region around unity (for electrons) or zero (for photons), it is advantageous to map the interval first. The mapping is controlled by the parameter [[circe1\_epsilon]] which is taken from the [[CIRCE1]] internal data structure. The $\sqrt{s}$ value, if not explicitly set, is taken from the process data. Note that interpolating $\sqrt{s}$ is not recommended; one should rather choose one of the distinct values known to [[CIRCE1]]. \subsection{The CIRCE1 data block} The CIRCE1 parameters are: The incoming flavors, the flags whether the photon or the lepton is the parton in the hard interaction, the flags for the generation mode (generator/mapping/no mapping), the mapping parameter $\epsilon$, $\sqrt{s}$ and several steering parameters: [[ver]], [[rev]], [[acc]], [[chat]]. In generator mode, the $x$ values are actually discarded and a random number generator is used instead. <>= public :: circe1_data_t <>= type, extends (sf_data_t) :: circe1_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(2) :: flv_in integer, dimension(2) :: pdg_in real(default), dimension(2) :: m_in = 0 logical, dimension(2) :: photon = .false. logical :: generate = .false. class(rng_factory_t), allocatable :: rng_factory real(default) :: sqrts = 0 real(default) :: eps = 0 integer :: ver = 0 integer :: rev = 0 character(6) :: acc = "?" integer :: chat = 0 logical :: with_radiation = .false. contains <> end type circe1_data_t @ %def circe1_data_t @ <>= procedure :: init => circe1_data_init <>= subroutine circe1_data_init & (data, model, pdg_in, sqrts, eps, out_photon, & ver, rev, acc, chat, with_radiation) class(circe1_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in) :: sqrts real(default), intent(in) :: eps logical, dimension(2), intent(in) :: out_photon character(*), intent(in) :: acc integer, intent(in) :: ver, rev, chat logical, intent(in) :: with_radiation data%model => model if (any (pdg_array_get_length (pdg_in) /= 1)) then call msg_fatal ("CIRCE1: incoming beam particles must be unique") end if call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model) call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model) data%pdg_in = data%flv_in%get_pdg () data%m_in = data%flv_in%get_mass () data%sqrts = sqrts data%eps = eps data%photon = out_photon data%ver = ver data%rev = rev data%acc = acc data%chat = chat data%with_radiation = with_radiation call data%check () call circex (0.d0, 0.d0, dble (data%sqrts), & data%acc, data%ver, data%rev, data%chat) end subroutine circe1_data_init @ %def circe1_data_init @ Activate the generator mode. We import a RNG factory into the data type, which can then spawn RNG generator objects. <>= procedure :: set_generator_mode => circe1_data_set_generator_mode <>= subroutine circe1_data_set_generator_mode (data, rng_factory) class(circe1_data_t), intent(inout) :: data class(rng_factory_t), intent(inout), allocatable :: rng_factory data%generate = .true. call move_alloc (from = rng_factory, to = data%rng_factory) end subroutine circe1_data_set_generator_mode @ %def circe1_data_set_generator_mode @ Handle error conditions. <>= procedure :: check => circe1_data_check <>= subroutine circe1_data_check (data) class(circe1_data_t), intent(in) :: data type(flavor_t) :: flv_electron, flv_photon call flv_electron%init (ELECTRON, data%model) call flv_photon%init (PHOTON, data%model) if (.not. flv_electron%is_defined () & .or. .not. flv_photon%is_defined ()) then call msg_fatal ("CIRCE1: model must contain photon and electron") end if if (any (abs (data%pdg_in) /= ELECTRON) & .or. (data%pdg_in(1) /= - data%pdg_in(2))) then call msg_fatal ("CIRCE1: applicable only for e+e- or e-e+ collisions") end if if (data%eps <= 0) then call msg_error ("CIRCE1: circe1_eps = 0: integration will & &miss x=1 peak") end if end subroutine circe1_data_check @ %def circe1_data_check @ Output <>= procedure :: write => circe1_data_write <>= subroutine circe1_data_write (data, unit, verbose) class(circe1_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "CIRCE1 data:" write (u, "(3x,A,2(1x,A))") "prt_in =", & char (data%flv_in(1)%get_name ()), & char (data%flv_in(2)%get_name ()) write (u, "(3x,A,2(1x,L1))") "photon =", data%photon write (u, "(3x,A,L1)") "generate = ", data%generate write (u, "(3x,A,2(1x," // FMT_19 // "))") "m_in =", data%m_in write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", data%sqrts write (u, "(3x,A," // FMT_19 // ")") "eps = ", data%eps write (u, "(3x,A,I0)") "ver = ", data%ver write (u, "(3x,A,I0)") "rev = ", data%rev write (u, "(3x,A,A)") "acc = ", data%acc write (u, "(3x,A,I0)") "chat = ", data%chat write (u, "(3x,A,L1)") "with rad.= ", data%with_radiation if (data%generate) call data%rng_factory%write (u) end subroutine circe1_data_write @ %def circe1_data_write @ Return true if this structure function is in generator mode. In that case, all parameters are free, otherwise bound. (We do not support mixed cases.) Default is: no generator. <>= procedure :: is_generator => circe1_data_is_generator <>= function circe1_data_is_generator (data) result (flag) class(circe1_data_t), intent(in) :: data logical :: flag flag = data%generate end function circe1_data_is_generator @ %def circe1_data_is_generator @ The number of parameters is two, collinear splitting for the two beams. <>= procedure :: get_n_par => circe1_data_get_n_par <>= function circe1_data_get_n_par (data) result (n) class(circe1_data_t), intent(in) :: data integer :: n n = 2 end function circe1_data_get_n_par @ %def circe1_data_get_n_par @ Return the outgoing particles PDG codes. This is either the incoming particle (if a photon is radiated), or the photon if that is the particle of the hard interaction. The latter is determined via the [[photon]] flag. There are two entries for the two beams. <>= procedure :: get_pdg_out => circe1_data_get_pdg_out <>= subroutine circe1_data_get_pdg_out (data, pdg_out) class(circe1_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n if (data%photon(i)) then pdg_out(i) = PHOTON else pdg_out(i) = data%pdg_in(i) end if end do end subroutine circe1_data_get_pdg_out @ %def circe1_data_get_pdg_out @ This variant is not inherited, it returns integers. <>= procedure :: get_pdg_int => circe1_data_get_pdg_int <>= function circe1_data_get_pdg_int (data) result (pdg) class(circe1_data_t), intent(in) :: data integer, dimension(2) :: pdg integer :: i do i = 1, 2 if (data%photon(i)) then pdg(i) = PHOTON else pdg(i) = data%pdg_in(i) end if end do end function circe1_data_get_pdg_int @ %def circe1_data_get_pdg_int @ Allocate the interaction record. <>= procedure :: allocate_sf_int => circe1_data_allocate_sf_int <>= subroutine circe1_data_allocate_sf_int (data, sf_int) class(circe1_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (circe1_t :: sf_int) end subroutine circe1_data_allocate_sf_int @ %def circe1_data_allocate_sf_int @ Return the accelerator type. <>= procedure :: get_beam_file => circe1_data_get_beam_file <>= function circe1_data_get_beam_file (data) result (file) class(circe1_data_t), intent(in) :: data type(string_t) :: file file = "CIRCE1: " // data%acc end function circe1_data_get_beam_file @ %def circe1_data_get_beam_file @ \subsection{Random Number Generator for CIRCE} The CIRCE implementation now supports a generic random-number generator object that allows for a local state as a component. To support this, we must extend the abstract type provided by CIRCE and delegate the generator call to the (also abstract) RNG used by WHIZARD. <>= type, extends (circe1_rng_t) :: rng_obj_t class(rng_t), allocatable :: rng contains procedure :: generate => rng_obj_generate end type rng_obj_t @ %def rng_obj_t <>= subroutine rng_obj_generate (rng_obj, u) class(rng_obj_t), intent(inout) :: rng_obj real(double), intent(out) :: u real(default) :: x call rng_obj%rng%generate (x) u = x end subroutine rng_obj_generate @ %def rng_obj_generate @ \subsection{The CIRCE1 object} This is a $2\to 4$ interaction, where, depending on the parameters, any two of the four outgoing particles are connected to the hard interactions, the others are radiated. Knowing that all particles are colorless, we do not have to deal with color. The flavors are sorted such that the first two particles are the incoming leptons, the next two are the radiated particles, and the last two are the partons initiating the hard interaction. CIRCE1 does not support polarized beams explicitly. For simplicity, we nevertheless carry beam polarization through to the outgoing electrons and make the photons unpolarized. In the case that no radiated particle is kept (which actually is the default), polarization is always transferred to the electrons, too. If there is a recoil photon in the event, the radiated particles are 3 and 4, respectively, and 5 and 6 are the outgoing ones (triggering the hard scattering process), while in the case of no radiation, the outgoing particles are 3 and 4, respectively. In the case of the electron being the radiated particle, helicity is not kept. <>= public :: circe1_t <>= type, extends (sf_int_t) :: circe1_t type(circe1_data_t), pointer :: data => null () real(default), dimension(2) :: x = 0 real(default), dimension(2) :: xb= 0 real(default) :: f = 0 logical, dimension(2) :: continuum = .true. logical, dimension(2) :: peak = .true. type(rng_obj_t) :: rng_obj contains <> end type circe1_t @ %def circe1_t @ Type string: has to be here, but there is no string variable on which CIRCE1 depends. Hence, a dummy routine. <>= procedure :: type_string => circe1_type_string <>= function circe1_type_string (object) result (string) class(circe1_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "CIRCE1: beamstrahlung" else string = "CIRCE1: [undefined]" end if end function circe1_type_string @ %def circe1_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => circe1_write <>= subroutine circe1_write (object, unit, testflag) class(circe1_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%data%generate) call object%rng_obj%rng%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(3x,A,2(1x," // FMT_17 // "))") "x =", object%x write (u, "(3x,A,2(1x," // FMT_17 // "))") "xb=", object%xb if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A,1x," // FMT_17 // ")") "f =", object%f end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "CIRCE1 data: [undefined]" end if end subroutine circe1_write @ %def circe1_write @ <>= procedure :: init => circe1_init <>= subroutine circe1_init (sf_int, data) class(circe1_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data logical, dimension(6) :: mask_h type(quantum_numbers_mask_t), dimension(6) :: mask integer, dimension(6) :: hel_lock type(polarization_t), target :: pol1, pol2 type(quantum_numbers_t), dimension(1) :: qn_fc1, qn_fc2 type(flavor_t) :: flv_photon type(color_t) :: col0 real(default), dimension(2) :: mi2, mr2, mo2 type(quantum_numbers_t) :: qn_hel1, qn_hel2, qn_photon, qn1, qn2 type(quantum_numbers_t), dimension(6) :: qn type(polarization_iterator_t) :: it_hel1, it_hel2 hel_lock = 0 mask_h = .false. select type (data) type is (circe1_data_t) mi2 = data%m_in**2 if (data%with_radiation) then if (data%photon(1)) then hel_lock(1) = 3; hel_lock(3) = 1; mask_h(5) = .true. mr2(1) = mi2(1) mo2(1) = 0._default else hel_lock(1) = 5; hel_lock(5) = 1; mask_h(3) = .true. mr2(1) = 0._default mo2(1) = mi2(1) end if if (data%photon(2)) then hel_lock(2) = 4; hel_lock(4) = 2; mask_h(6) = .true. mr2(2) = mi2(2) mo2(2) = 0._default else hel_lock(2) = 6; hel_lock(6) = 2; mask_h(4) = .true. mr2(2) = 0._default mo2(2) = mi2(2) end if mask = quantum_numbers_mask (.false., .false., mask_h) call sf_int%base_init (mask, mi2, mr2, mo2, & hel_lock = hel_lock) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col0%init () call qn_photon%init (flv_photon, col0) call pol1%init_generic (data%flv_in(1)) call qn_fc1(1)%init (flv = data%flv_in(1), col = col0) call pol2%init_generic (data%flv_in(2)) call qn_fc2(1)%init (flv = data%flv_in(2), col = col0) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel1 = it_hel1%get_quantum_numbers () qn1 = qn_hel1 .merge. qn_fc1(1) qn(1) = qn1 if (data%photon(1)) then qn(3) = qn1; qn(5) = qn_photon else qn(3) = qn_photon; qn(5) = qn1 end if call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel2 = it_hel2%get_quantum_numbers () qn2 = qn_hel2 .merge. qn_fc2(1) qn(2) = qn2 if (data%photon(2)) then qn(4) = qn2; qn(6) = qn_photon else qn(4) = qn_photon; qn(6) = qn2 end if call qn(3:4)%tag_radiated () call sf_int%add_state (qn) call it_hel2%advance () end do call it_hel1%advance () end do ! call pol1%final () ! call pol2%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_radiated ([3,4]) call sf_int%set_outgoing ([5,6]) else if (data%photon(1)) then mask_h(3) = .true. mo2(1) = 0._default else hel_lock(1) = 3; hel_lock(3) = 1 mo2(1) = mi2(1) end if if (data%photon(2)) then mask_h(4) = .true. mo2(2) = 0._default else hel_lock(2) = 4; hel_lock(4) = 2 mo2(2) = mi2(2) end if mask = quantum_numbers_mask (.false., .false., mask_h) call sf_int%base_init (mask(1:4), mi2, [real(default) :: ], mo2, & hel_lock = hel_lock(1:4)) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col0%init () call qn_photon%init (flv_photon, col0) call pol1%init_generic (data%flv_in(1)) call qn_fc1(1)%init (flv = data%flv_in(1), col = col0) call pol2%init_generic (data%flv_in(2)) call qn_fc2(1)%init (flv = data%flv_in(2), col = col0) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel1 = it_hel1%get_quantum_numbers () qn1 = qn_hel1 .merge. qn_fc1(1) qn(1) = qn1 if (data%photon(1)) then qn(3) = qn_photon else qn(3) = qn1 end if call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel2 = it_hel2%get_quantum_numbers () qn2 = qn_hel2 .merge. qn_fc2(1) qn(2) = qn2 if (data%photon(2)) then qn(4) = qn_photon else qn(4) = qn2 end if call sf_int%add_state (qn(1:4)) call it_hel2%advance () end do call it_hel1%advance () end do ! call pol1%final () ! call pol2%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) end if sf_int%status = SF_INITIAL end select if (sf_int%data%generate) then call sf_int%data%rng_factory%make (sf_int%rng_obj%rng) end if end subroutine circe1_init @ %def circe1_init @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => circe1_is_generator <>= function circe1_is_generator (sf_int) result (flag) class(circe1_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function circe1_is_generator @ %def circe1_is_generator @ Generate free parameters, if generator mode is on. Otherwise, the parameters will be discarded. <>= procedure :: generate_free => circe1_generate_free <>= subroutine circe1_generate_free (sf_int, r, rb, x_free) class(circe1_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free if (sf_int%data%generate) then call circe_generate (r, sf_int%data%get_pdg_int (), sf_int%rng_obj) rb = 1 - r x_free = x_free * product (r) else r = 0 rb= 1 end if end subroutine circe1_generate_free @ %def circe1_generate_free @ Generator mode: depending on the particle codes, call one of the available [[girce]] generators. Illegal particle code combinations should have been caught during data initialization. <>= subroutine circe_generate (x, pdg, rng_obj) real(default), dimension(2), intent(out) :: x integer, dimension(2), intent(in) :: pdg class(rng_obj_t), intent(inout) :: rng_obj real(double) :: xc1, xc2 select case (abs (pdg(1))) case (ELECTRON) select case (abs (pdg(2))) case (ELECTRON) call gircee (xc1, xc2, rng_obj = rng_obj) case (PHOTON) call girceg (xc1, xc2, rng_obj = rng_obj) end select case (PHOTON) select case (abs (pdg(2))) case (ELECTRON) call girceg (xc2, xc1, rng_obj = rng_obj) case (PHOTON) call gircgg (xc1, xc2, rng_obj = rng_obj) end select end select x = [xc1, xc2] end subroutine circe_generate @ %def circe_generate @ Set kinematics. The $r$ values (either from integration or from the generator call above) are copied to $x$ unchanged, and $f$ is unity. We store the $x$ values, so we can use them for the evaluation later. <>= procedure :: complete_kinematics => circe1_complete_kinematics <>= subroutine circe1_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(circe1_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map x = r xb = rb sf_int%x = x sf_int%xb= xb f = 1 if (sf_int%data%with_radiation) then call sf_int%split_momenta (x, xb) else call sf_int%reduce_momenta (x) end if select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end subroutine circe1_complete_kinematics @ %def circe1_complete_kinematics @ Compute inverse kinematics. In generator mode, the $r$ values are meaningless, but we copy them anyway. <>= procedure :: inverse_kinematics => circe1_inverse_kinematics <>= subroutine circe1_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(circe1_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta r = x rb = xb sf_int%x = x sf_int%xb= xb f = 1 if (set_mom) then call sf_int%split_momenta (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine circe1_inverse_kinematics @ %def circe1_inverse_kinematics @ \subsection{CIRCE1 application} CIRCE is applied for the two beams at once. We can safely assume that no structure functions are applied before this, so the incoming particles are on-shell electrons/positrons. The scale is ignored. <>= procedure :: apply => circe1_apply <>= subroutine circe1_apply (sf_int, scale, rescale, i_sub, fill_sub) class(circe1_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub logical, intent(in), optional :: fill_sub real(default), dimension(2) :: xb real(double), dimension(2) :: xc real(double), parameter :: one = 1 associate (data => sf_int%data) xc = sf_int%x xb = sf_int%xb if (data%generate) then sf_int%f = 1 else sf_int%f = 0 if (all (sf_int%continuum)) then sf_int%f = circe (xc(1), xc(2), data%pdg_in(1), data%pdg_in(2)) end if if (sf_int%continuum(2) .and. sf_int%peak(1)) then sf_int%f = sf_int%f & + circe (one, xc(2), data%pdg_in(1), data%pdg_in(2)) & * peak (xb(1), data%eps) end if if (sf_int%continuum(1) .and. sf_int%peak(2)) then sf_int%f = sf_int%f & + circe (xc(1), one, data%pdg_in(1), data%pdg_in(2)) & * peak (xb(2), data%eps) end if if (all (sf_int%peak)) then sf_int%f = sf_int%f & + circe (one, one, data%pdg_in(1), data%pdg_in(2)) & * peak (xb(1), data%eps) * peak (xb(2), data%eps) end if end if end associate call sf_int%set_matrix_element (cmplx (sf_int%f, kind=default)) sf_int%status = SF_EVALUATED end subroutine circe1_apply @ %def circe1_apply @ This is a smeared delta peak at zero, as an endpoint singularity. We choose an exponentially decreasing function, starting at zero, with integral (from $0$ to $1$) $1-e^{-1/\epsilon}$. For small $\epsilon$, this reduces to one. <>= function peak (x, eps) result (f) real(default), intent(in) :: x, eps real(default) :: f f = exp (-x / eps) / eps end function peak @ %def peak @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_circe1_ut.f90]]>>= <> module sf_circe1_ut use unit_tests use sf_circe1_uti <> <> contains <> end module sf_circe1_ut @ %def sf_circe1_ut @ <<[[sf_circe1_uti.f90]]>>= <> module sf_circe1_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use rng_base use sf_aux use sf_base use sf_circe1 use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module sf_circe1_uti @ %def sf_circe1_ut @ API: driver for the unit tests below. <>= public :: sf_circe1_test <>= subroutine sf_circe1_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_circe1_test @ %def sf_circe1_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_circe1_1, "sf_circe1_1", & "structure function configuration", & u, results) <>= public :: sf_circe1_1 <>= subroutine sf_circe1_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_circe1_1" write (u, "(A)") "* Purpose: initialize and display & &CIRCE structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (circe1_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (circe1_data_t) call data%init (model, pdg_in, & sqrts = 500._default, & eps = 1e-6_default, & out_photon = [.false., .false.], & ver = 0, & rev = 0, & acc = "SBAND", & chat = 0, & with_radiation = .true.) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe1_1" end subroutine sf_circe1_1 @ %def sf_circe1_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the PDF builtin structure function. <>= call test (sf_circe1_2, "sf_circe1_2", & "structure function instance", & u, results) <>= public :: sf_circe1_2 <>= subroutine sf_circe1_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 type(vector4_t), dimension(4) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_circe1_2" write (u, "(A)") "* Purpose: initialize and fill & &circe1 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (circe1_data_t :: data) select type (data) type is (circe1_data_t) call data%init (model, pdg_in, & sqrts = 500._default, & eps = 1e-6_default, & out_photon = [.false., .false.], & ver = 0, & rev = 0, & acc = "SBAND", & chat = 0, & with_radiation = .true.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.95,0.85." write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.9_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1, 2]) call sf_int%seed_kinematics ([k1, k2]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe1_2" end subroutine sf_circe1_2 @ %def sf_circe1_2 @ \subsubsection{Generator mode} Construct and evaluate a structure function object in generator mode. <>= call test (sf_circe1_3, "sf_circe1_3", & "generator mode", & u, results) <>= public :: sf_circe1_3 <>= subroutine sf_circe1_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_circe1_3" write (u, "(A)") "* Purpose: initialize and fill & &circe1 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (circe1_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe1_data_t) call data%init (model, pdg_in, & sqrts = 500._default, & eps = 1e-6_default, & out_photon = [.false., .false.], & ver = 0, & rev = 0, & acc = "SBAND", & chat = 0, & with_radiation = .true.) call data%set_generator_mode (rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) select type (sf_int) type is (circe1_t) call sf_int%rng_obj%rng%init (3) end select write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe1_3" end subroutine sf_circe1_3 @ %def sf_circe1_3 @ \clearpage %------------------------------------------------------------------------ \section{Lepton Collider Beamstrahlung and Photon collider: CIRCE2} <<[[sf_circe2.f90]]>>= <> module sf_circe2 <> <> use io_units use format_defs, only: FMT_19 use numeric_utils use diagnostics use os_interface use physics_defs, only: PHOTON, ELECTRON use lorentz use rng_base use selectors use pdg_arrays use model_data use flavors use colors use helicities use quantum_numbers use state_matrices use polarizations use sf_base use circe2, circe2_rng_t => rng_type !NODEP! <> <> <> contains <> end module sf_circe2 @ %def sf_circe2 @ \subsection{Physics} [[CIRCE2]] describes photon spectra Beamstrahlung is applied before ISR. The [[CIRCE2]] implementation has a single structure function for both beams (which makes sense since it has to be switched on or off for both beams simultaneously). \subsection{The CIRCE2 data block} The CIRCE2 parameters are: file and collider specification, incoming (= outgoing) particles. The luminosity is returned by [[circe2_luminosity]]. <>= public :: circe2_data_t <>= type, extends (sf_data_t) :: circe2_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(2) :: flv_in integer, dimension(2) :: pdg_in real(default) :: sqrts = 0 logical :: polarized = .false. logical :: beams_polarized = .false. class(rng_factory_t), allocatable :: rng_factory type(string_t) :: filename type(string_t) :: file type(string_t) :: design real(default) :: lumi = 0 real(default), dimension(4) :: lumi_hel_frac = 0 integer, dimension(0:4) :: h1 = [0, -1, -1, 1, 1] integer, dimension(0:4) :: h2 = [0, -1, 1,-1, 1] integer :: error = 1 contains <> end type circe2_data_t @ %def circe2_data_t <>= type(circe2_state) :: circe2_global_state @ <>= procedure :: init => circe2_data_init <>= subroutine circe2_data_init (data, os_data, model, pdg_in, & sqrts, polarized, beam_pol, file, design) class(circe2_data_t), intent(out) :: data type(os_data_t), intent(in) :: os_data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in) :: sqrts logical, intent(in) :: polarized, beam_pol type(string_t), intent(in) :: file, design integer :: h data%model => model if (any (pdg_array_get_length (pdg_in) /= 1)) then call msg_fatal ("CIRCE2: incoming beam particles must be unique") end if call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model) call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model) data%pdg_in = data%flv_in%get_pdg () data%sqrts = sqrts data%polarized = polarized data%beams_polarized = beam_pol data%filename = file data%design = design call data%check_file (os_data) call circe2_load (circe2_global_state, trim (char(data%file)), & trim (char(data%design)), data%sqrts, data%error) call data%check () data%lumi = circe2_luminosity (circe2_global_state, data%pdg_in, [0, 0]) if (vanishes (data%lumi)) then call msg_fatal ("CIRCE2: luminosity vanishes for specified beams.") end if if (data%polarized) then do h = 1, 4 data%lumi_hel_frac(h) = & circe2_luminosity (circe2_global_state, data%pdg_in, & [data%h1(h), data%h2(h)]) & / data%lumi end do end if end subroutine circe2_data_init @ %def circe2_data_init @ Activate the generator mode. We import a RNG factory into the data type, which can then spawn RNG generator objects. <>= procedure :: set_generator_mode => circe2_data_set_generator_mode <>= subroutine circe2_data_set_generator_mode (data, rng_factory) class(circe2_data_t), intent(inout) :: data class(rng_factory_t), intent(inout), allocatable :: rng_factory call move_alloc (from = rng_factory, to = data%rng_factory) end subroutine circe2_data_set_generator_mode @ %def circe2_data_set_generator_mode @ Check whether the requested data file is in the system directory or in the current directory. <>= procedure :: check_file => circe2_check_file <>= subroutine circe2_check_file (data, os_data) class(circe2_data_t), intent(inout) :: data type(os_data_t), intent(in) :: os_data logical :: exist type(string_t) :: file file = data%filename if (file == "") & call msg_fatal ("CIRCE2: $circe2_file is not set") inquire (file = char (file), exist = exist) if (exist) then data%file = file else file = os_data%whizard_circe2path // "/" // data%filename inquire (file = char (file), exist = exist) if (exist) then data%file = file else call msg_fatal ("CIRCE2: data file '" // char (data%filename) & // "' not found") end if end if end subroutine circe2_check_file @ %def circe2_check_file @ Handle error conditions. <>= procedure :: check => circe2_data_check <>= subroutine circe2_data_check (data) class(circe2_data_t), intent(in) :: data type(flavor_t) :: flv_photon, flv_electron call flv_photon%init (PHOTON, data%model) if (.not. flv_photon%is_defined ()) then call msg_fatal ("CIRCE2: model must contain photon") end if call flv_electron%init (ELECTRON, data%model) if (.not. flv_electron%is_defined ()) then call msg_fatal ("CIRCE2: model must contain electron") end if if (any (abs (data%pdg_in) /= PHOTON .and. abs (data%pdg_in) /= ELECTRON)) & then call msg_fatal ("CIRCE2: applicable only for e+e- or photon collisions") end if select case (data%error) case (-1) call msg_fatal ("CIRCE2: data file not found.") case (-2) call msg_fatal ("CIRCE2: beam setup does not match data file.") case (-3) call msg_fatal ("CIRCE2: invalid format of data file.") case (-4) call msg_fatal ("CIRCE2: data file too large.") end select end subroutine circe2_data_check @ %def circe2_data_check @ Output <>= procedure :: write => circe2_data_write <>= subroutine circe2_data_write (data, unit, verbose) class(circe2_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, h u = given_output_unit (unit) write (u, "(1x,A)") "CIRCE2 data:" write (u, "(3x,A,A)") "file = ", char(data%filename) write (u, "(3x,A,A)") "design = ", char(data%design) write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", data%sqrts write (u, "(3x,A,A,A,A)") "prt_in = ", & char (data%flv_in(1)%get_name ()), & ", ", char (data%flv_in(2)%get_name ()) write (u, "(3x,A,L1)") "polarized = ", data%polarized write (u, "(3x,A,L1)") "beams pol. = ", data%beams_polarized write (u, "(3x,A," // FMT_19 // ")") "luminosity = ", data%lumi if (data%polarized) then do h = 1, 4 write (u, "(6x,'(',I2,1x,I2,')',1x,'=',1x)", advance="no") & data%h1(h), data%h2(h) write (u, "(6x, " // FMT_19 // ")") data%lumi_hel_frac(h) end do end if call data%rng_factory%write (u) end subroutine circe2_data_write @ %def circe2_data_write @ This is always in generator mode. <>= procedure :: is_generator => circe2_data_is_generator <>= function circe2_data_is_generator (data) result (flag) class(circe2_data_t), intent(in) :: data logical :: flag flag = .true. end function circe2_data_is_generator @ %def circe2_data_is_generator @ The number of parameters is two, collinear splitting for the two beams. <>= procedure :: get_n_par => circe2_data_get_n_par <>= function circe2_data_get_n_par (data) result (n) class(circe2_data_t), intent(in) :: data integer :: n n = 2 end function circe2_data_get_n_par @ %def circe2_data_get_n_par @ Return the outgoing particles PDG codes. They are equal to the incoming ones. <>= procedure :: get_pdg_out => circe2_data_get_pdg_out <>= subroutine circe2_data_get_pdg_out (data, pdg_out) class(circe2_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%pdg_in(i) end do end subroutine circe2_data_get_pdg_out @ %def circe2_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => circe2_data_allocate_sf_int <>= subroutine circe2_data_allocate_sf_int (data, sf_int) class(circe2_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (circe2_t :: sf_int) end subroutine circe2_data_allocate_sf_int @ %def circe2_data_allocate_sf_int @ Return the beam file. <>= procedure :: get_beam_file => circe2_data_get_beam_file <>= function circe2_data_get_beam_file (data) result (file) class(circe2_data_t), intent(in) :: data type(string_t) :: file file = "CIRCE2: " // data%filename end function circe2_data_get_beam_file @ %def circe2_data_get_beam_file @ \subsection{Random Number Generator for CIRCE} The CIRCE implementation now supports a generic random-number generator object that allows for a local state as a component. To support this, we must extend the abstract type provided by CIRCE and delegate the generator call to the (also abstract) RNG used by WHIZARD. <>= type, extends (circe2_rng_t) :: rng_obj_t class(rng_t), allocatable :: rng contains procedure :: generate => rng_obj_generate end type rng_obj_t @ %def rng_obj_t <>= subroutine rng_obj_generate (rng_obj, u) class(rng_obj_t), intent(inout) :: rng_obj real(default), intent(out) :: u real(default) :: x call rng_obj%rng%generate (x) u = x end subroutine rng_obj_generate @ %def rng_obj_generate @ \subsection{The CIRCE2 object} For CIRCE2 spectra it does not make sense to describe the state matrix as a radiation interaction, even if photons originate from laser backscattering. Instead, it is a $2\to 2$ interaction where the incoming particles are identical to the outgoing ones. The current implementation of CIRCE2 does support polarization and classical correlations, but no entanglement, so the density matrix of the outgoing particles is diagonal. The incoming particles are unpolarized (user-defined polarization for beams is meaningless, since polarization is described by the data file). The outgoing particles are polarized or polarization-averaged, depending on user request. When assigning matrix elements, we scan the previously initialized state matrix. For each entry, we extract helicity and call the structure function. In the unpolarized case, the helicity is undefined and replaced by value zero. In the polarized case, there are four entries. If the generator is used, only one entry is nonzero in each call. Which one, is determined by comparing with a previously (randomly, distributed by relative luminosity) selected pair of helicities. <>= public :: circe2_t <>= type, extends (sf_int_t) :: circe2_t type(circe2_data_t), pointer :: data => null () type(rng_obj_t) :: rng_obj type(selector_t) :: selector integer :: h_sel = 0 contains <> end type circe2_t @ %def circe2_t @ Type string: show file and design of [[CIRCE2]] structure function. <>= procedure :: type_string => circe2_type_string <>= function circe2_type_string (object) result (string) class(circe2_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "CIRCE2: " // object%data%design else string = "CIRCE2: [undefined]" end if end function circe2_type_string @ %def circe2_type_string @ @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => circe2_write <>= subroutine circe2_write (object, unit, testflag) class(circe2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "CIRCE2 data: [undefined]" end if end subroutine circe2_write @ %def circe2_write @ <>= procedure :: init => circe2_init <>= subroutine circe2_init (sf_int, data) class(circe2_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data logical, dimension(4) :: mask_h real(default), dimension(0) :: null_array type(quantum_numbers_mask_t), dimension(4) :: mask type(quantum_numbers_t), dimension(4) :: qn type(helicity_t) :: hel type(color_t) :: col0 integer :: h select type (data) type is (circe2_data_t) if (data%polarized .and. data%beams_polarized) then call msg_fatal ("CIRCE2: Beam polarization can't be set & &for polarized data file") else if (data%beams_polarized) then call msg_warning ("CIRCE2: User-defined beam polarization set & &for unpolarized CIRCE2 data file") end if mask_h(1:2) = .not. data%beams_polarized mask_h(3:4) = .not. (data%polarized .or. data%beams_polarized) mask = quantum_numbers_mask (.false., .false., mask_h) call sf_int%base_init (mask, [0._default, 0._default], & null_array, [0._default, 0._default]) sf_int%data => data if (data%polarized) then if (vanishes (sum (data%lumi_hel_frac)) .or. & any (data%lumi_hel_frac < 0)) then call msg_fatal ("CIRCE2: Helicity-dependent lumi " & // "fractions all vanish or", & [var_str ("are negative: Please inspect the " & // "CIRCE2 file or "), & var_str ("switch off the polarized" // & " option for CIRCE2.")]) else call sf_int%selector%init (data%lumi_hel_frac) end if end if call col0%init () if (data%beams_polarized) then do h = 1, 4 call hel%init (data%h1(h)) call qn(1)%init & (flv = data%flv_in(1), col = col0, hel = hel) call qn(3)%init & (flv = data%flv_in(1), col = col0, hel = hel) call hel%init (data%h2(h)) call qn(2)%init & (flv = data%flv_in(2), col = col0, hel = hel) call qn(4)%init & (flv = data%flv_in(2), col = col0, hel = hel) call sf_int%add_state (qn) end do else if (data%polarized) then call qn(1)%init (flv = data%flv_in(1), col = col0) call qn(2)%init (flv = data%flv_in(2), col = col0) do h = 1, 4 call hel%init (data%h1(h)) call qn(3)%init & (flv = data%flv_in(1), col = col0, hel = hel) call hel%init (data%h2(h)) call qn(4)%init & (flv = data%flv_in(2), col = col0, hel = hel) call sf_int%add_state (qn) end do else call qn(1)%init (flv = data%flv_in(1), col = col0) call qn(2)%init (flv = data%flv_in(2), col = col0) call qn(3)%init (flv = data%flv_in(1), col = col0) call qn(4)%init (flv = data%flv_in(2), col = col0) call sf_int%add_state (qn) end if call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%data%rng_factory%make (sf_int%rng_obj%rng) sf_int%status = SF_INITIAL end select end subroutine circe2_init @ %def circe2_init @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => circe2_is_generator <>= function circe2_is_generator (sf_int) result (flag) class(circe2_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function circe2_is_generator @ %def circe2_is_generator @ Generate free parameters. We first select a helicity, which we have to store, then generate $x$ values for that helicity. <>= procedure :: generate_free => circe2_generate_whizard_free <>= subroutine circe2_generate_whizard_free (sf_int, r, rb, x_free) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free integer :: h_sel if (sf_int%data%polarized) then call sf_int%selector%generate (sf_int%rng_obj%rng, h_sel) else h_sel = 0 end if sf_int%h_sel = h_sel call circe2_generate_whizard (r, sf_int%data%pdg_in, & [sf_int%data%h1(h_sel), sf_int%data%h2(h_sel)], & sf_int%rng_obj) rb = 1 - r x_free = x_free * product (r) end subroutine circe2_generate_whizard_free @ %def circe2_generate_whizard_free @ Generator mode: call the CIRCE2 generator for the given particles and helicities. (For unpolarized generation, helicities are zero.) <>= subroutine circe2_generate_whizard (x, pdg, hel, rng_obj) real(default), dimension(2), intent(out) :: x integer, dimension(2), intent(in) :: pdg integer, dimension(2), intent(in) :: hel class(rng_obj_t), intent(inout) :: rng_obj call circe2_generate (circe2_global_state, rng_obj, x, pdg, hel) end subroutine circe2_generate_whizard @ %def circe2_generate_whizard @ Set kinematics. Trivial here. <>= procedure :: complete_kinematics => circe2_complete_kinematics <>= subroutine circe2_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("CIRCE2: map flag not supported") else x = r xb= rb f = 1 end if call sf_int%reduce_momenta (x) end subroutine circe2_complete_kinematics @ %def circe2_complete_kinematics @ Compute inverse kinematics. <>= procedure :: inverse_kinematics => circe2_inverse_kinematics <>= subroutine circe2_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("CIRCE2: map flag not supported") else r = x rb= xb f = 1 end if if (set_mom) then call sf_int%reduce_momenta (x) end if end subroutine circe2_inverse_kinematics @ %def circe2_inverse_kinematics @ \subsection{CIRCE2 application} This function works on both beams. In polarized mode, we set only the selected helicity. In unpolarized mode, the interaction has only one entry, and the factor is unity. <>= procedure :: apply => circe2_apply <>= subroutine circe2_apply (sf_int, scale, rescale, i_sub, fill_sub) class(circe2_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub logical, intent(in), optional :: fill_sub complex(default) :: f associate (data => sf_int%data) f = 1 if (data%beams_polarized) then call sf_int%set_matrix_element (f) else if (data%polarized) then call sf_int%set_matrix_element (sf_int%h_sel, f) else call sf_int%set_matrix_element (1, f) end if end associate sf_int%status = SF_EVALUATED end subroutine circe2_apply @ %def circe2_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_circe2_ut.f90]]>>= <> module sf_circe2_ut use unit_tests use sf_circe2_uti <> <> contains <> end module sf_circe2_ut @ %def sf_circe2_ut @ <<[[sf_circe2_uti.f90]]>>= <> module sf_circe2_uti <> <> use os_interface use physics_defs, only: PHOTON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use rng_base use sf_aux use sf_base use sf_circe2 use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module sf_circe2_uti @ %def sf_circe2_ut @ API: driver for the unit tests below. <>= public :: sf_circe2_test <>= subroutine sf_circe2_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_circe2_test @ %def sf_circe2_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_circe2_1, "sf_circe2_1", & "structure function configuration", & u, results) <>= public :: sf_circe2_1 <>= subroutine sf_circe2_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data class(rng_factory_t), allocatable :: rng_factory write (u, "(A)") "* Test output: sf_circe2_1" write (u, "(A)") "* Purpose: initialize and display & &CIRCE structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call os_data%init () call model%init_qed_test () pdg_in(1) = PHOTON pdg_in(2) = PHOTON allocate (circe2_data_t :: data) allocate (rng_test_factory_t :: rng_factory) write (u, "(A)") write (u, "(A)") "* Initialize (unpolarized)" write (u, "(A)") select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .false., & beam_pol = .false., & file = var_str ("teslagg_500_polavg.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 write (u, "(A)") write (u, "(A)") "* Initialize (polarized)" write (u, "(A)") allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .true., & beam_pol = .false., & file = var_str ("teslagg_500.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select call data%write (u) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe2_1" end subroutine sf_circe2_1 @ %def sf_circe2_1 @ \subsubsection{Generator mode, unpolarized} Construct and evaluate a structure function object in generator mode. <>= call test (sf_circe2_2, "sf_circe2_2", & "generator, unpolarized", & u, results) <>= public :: sf_circe2_2 <>= subroutine sf_circe2_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_circe2_2" write (u, "(A)") "* Purpose: initialize and fill & &circe2 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () call model%init_qed_test () call flv(1)%init (PHOTON, model) call flv(2)%init (PHOTON, model) pdg_in(1) = PHOTON pdg_in(2) = PHOTON call reset_interaction_counter () allocate (circe2_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .false., & beam_pol = .false., & file = var_str ("teslagg_500_polavg.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) select type (sf_int) type is (circe2_t) call sf_int%rng_obj%rng%init (3) end select write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe2_2" end subroutine sf_circe2_2 @ %def sf_circe2_2 @ \subsubsection{Generator mode, polarized} Construct and evaluate a structure function object in generator mode. <>= call test (sf_circe2_3, "sf_circe2_3", & "generator, polarized", & u, results) <>= public :: sf_circe2_3 <>= subroutine sf_circe2_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_circe2_3" write (u, "(A)") "* Purpose: initialize and fill & &circe2 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () call model%init_qed_test () call flv(1)%init (PHOTON, model) call flv(2)%init (PHOTON, model) pdg_in(1) = PHOTON pdg_in(2) = PHOTON call reset_interaction_counter () allocate (circe2_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .true., & beam_pol = .false., & file = var_str ("teslagg_500.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) select type (sf_int) type is (circe2_t) call sf_int%rng_obj%rng%init (3) end select write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe2_3" end subroutine sf_circe2_3 @ %def sf_circe2_3 @ \clearpage %------------------------------------------------------------------------ \section{HOPPET interface} Interface to the HOPPET wrapper necessary to perform the LO vs. NLO matching of processes containing an initial b quark. <<[[hoppet_interface.f90]]>>= <> module hoppet_interface use lhapdf !NODEP! <> public :: hoppet_init, hoppet_eval contains subroutine hoppet_init (pdf_builtin, pdf, pdf_id) logical, intent(in) :: pdf_builtin type(lhapdf_pdf_t), intent(inout), optional :: pdf integer, intent(in), optional :: pdf_id external InitForWhizard call InitForWhizard (pdf_builtin, pdf, pdf_id) end subroutine hoppet_init subroutine hoppet_eval (x, q, f) double precision, intent(in) :: x, q double precision, intent(out) :: f(-6:6) external EvalForWhizard call EvalForWhizard (x, q, f) end subroutine hoppet_eval end module hoppet_interface @ %def hoppet_interface @ \clearpage %------------------------------------------------------------------------ \section{Builtin PDF sets} For convenience in order not to depend on the external package LHAPDF, we ship some PDFs with WHIZARD. @ \subsection{The module} <<[[sf_pdf_builtin.f90]]>>= <> module sf_pdf_builtin <> use kinds, only: double <> use io_units use format_defs, only: FMT_17 use diagnostics use os_interface use physics_defs, only: n_beam_gluon_offset use physics_defs, only: PROTON, PHOTON, GLUON use physics_defs, only: HADRON_REMNANT_SINGLET use physics_defs, only: HADRON_REMNANT_TRIPLET use physics_defs, only: HADRON_REMNANT_OCTET use sm_qcd use lorentz use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use sf_base use pdf_builtin !NODEP! use hoppet_interface <> <> <> <> contains <> end module sf_pdf_builtin @ %def sf_pdf_builtin @ \subsection{Codes for default PDF sets} <>= character(*), parameter :: PDF_BUILTIN_DEFAULT_PROTON = "CTEQ6L" ! character(*), parameter :: PDF_BUILTIN_DEFAULT_PION = "NONE" ! character(*), parameter :: PDF_BUILTIN_DEFAULT_PHOTON = "MRST2004QEDp" @ %def PDF_BUILTIN_DEFAULT_SET @ \subsection{The PDF builtin data block} The data block holds the incoming flavor (which has to be proton, pion, or photon), the corresponding pointer to the global access data (1, 2, or 3), the flag [[invert]] which is set for an antiproton, the bounds as returned by LHAPDF for the specified set, and a mask that determines which partons will be actually in use. <>= public :: pdf_builtin_data_t <>= type, extends (sf_data_t) :: pdf_builtin_data_t private integer :: id = -1 type (string_t) :: name class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in logical :: invert logical :: has_photon logical :: photon logical, dimension(-6:6) :: mask logical :: mask_photon logical :: hoppet_b_matching = .false. contains <> end type pdf_builtin_data_t @ %def pdf_builtin_data_t @ Generate PDF data and initialize the requested set. Pion and photon PDFs are disabled at the moment until we ship appropiate structure functions. needed. <>= procedure :: init => pdf_builtin_data_init <>= subroutine pdf_builtin_data_init (data, & model, pdg_in, name, path, hoppet_b_matching) class(pdf_builtin_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in type(string_t), intent(in) :: name type(string_t), intent(in) :: path logical, intent(in), optional :: hoppet_b_matching data%model => model if (pdg_array_get_length (pdg_in) /= 1) & call msg_fatal ("PDF: incoming particle must be unique") call data%flv_in%init (pdg_array_get (pdg_in, 1), model) data%mask = .true. data%mask_photon = .true. select case (pdg_array_get (pdg_in, 1)) case (PROTON) data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON) data%invert = .false. data%photon = .false. case (-PROTON) data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON) data%invert = .true. data%photon = .false. ! case (PIPLUS) ! data%name = var_str (PDF_BUILTIN_DEFAULT_PION) ! data%invert = .false. ! data%photon = .false. ! case (-PIPLUS) ! data%name = var_str (PDF_BUILTIN_DEFAULT_PION) ! data%invert = .true. ! data%photon = .false. ! case (PHOTON) ! data%name = var_str (PDF_BUILTIN_DEFAULT_PHOTON) ! data%invert = .false. ! data%photon = .true. case default call msg_fatal ("PDF: " & // "incoming particle must either proton or antiproton.") return end select data%name = name data%id = pdf_get_id (data%name) if (data%id < 0) call msg_fatal ("unknown PDF set " // char (data%name)) data%has_photon = pdf_provides_photon (data%id) if (present (hoppet_b_matching)) data%hoppet_b_matching = hoppet_b_matching call pdf_init (data%id, path) if (data%hoppet_b_matching) call hoppet_init (.true., pdf_id = data%id) end subroutine pdf_builtin_data_init @ %def pdf_builtin_data_init @ Enable/disable partons explicitly. If a mask entry is true, applying the PDF will generate the corresponding flavor on output. <>= procedure :: set_mask => pdf_builtin_data_set_mask <>= subroutine pdf_builtin_data_set_mask (data, mask) class(pdf_builtin_data_t), intent(inout) :: data logical, dimension(-6:6), intent(in) :: mask data%mask = mask end subroutine pdf_builtin_data_set_mask @ %def pdf_builtin_data_set_mask @ Output. <>= procedure :: write => pdf_builtin_data_write <>= subroutine pdf_builtin_data_write (data, unit, verbose) class(pdf_builtin_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "PDF builtin data:" if (data%id < 0) then write (u, "(3x,A)") "[undefined]" return end if write (u, "(3x,A)", advance="no") "flavor = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A,A)") "name = ", char (data%name) write (u, "(3x,A,L1)") "invert = ", data%invert write (u, "(3x,A,L1)") "has photon = ", data%has_photon write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") & "mask =", & data%mask(-6:-1), "*", data%mask(0), "*", data%mask(1:6) write (u, "(3x,A,L1)") "photon mask = ", data%mask_photon write (u, "(3x,A,L1)") "hoppet_b = ", data%hoppet_b_matching end subroutine pdf_builtin_data_write @ %def pdf_builtin_data_write @ The number of parameters is one. We do not generate transverse momentum. <>= procedure :: get_n_par => pdf_builtin_data_get_n_par <>= function pdf_builtin_data_get_n_par (data) result (n) class(pdf_builtin_data_t), intent(in) :: data integer :: n n = 1 end function pdf_builtin_data_get_n_par @ %def pdf_builtin_data_get_n_par @ Return the outgoing particle PDG codes. This is based on the mask. <>= procedure :: get_pdg_out => pdf_builtin_data_get_pdg_out <>= subroutine pdf_builtin_data_get_pdg_out (data, pdg_out) class(pdf_builtin_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer, dimension(:), allocatable :: pdg1 integer :: n, np, i n = count (data%mask) np = 0; if (data%has_photon .and. data%mask_photon) np = 1 allocate (pdg1 (n + np)) pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask) if (np == 1) pdg1(n+np) = PHOTON pdg_out(1) = pdg1 end subroutine pdf_builtin_data_get_pdg_out @ %def pdf_builtin_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => pdf_builtin_data_allocate_sf_int <>= subroutine pdf_builtin_data_allocate_sf_int (data, sf_int) class(pdf_builtin_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (pdf_builtin_t :: sf_int) end subroutine pdf_builtin_data_allocate_sf_int @ %def pdf_builtin_data_allocate_sf_int @ Return the numerical PDF set index. <>= procedure :: get_pdf_set => pdf_builtin_data_get_pdf_set <>= elemental function pdf_builtin_data_get_pdf_set (data) result (pdf_set) class(pdf_builtin_data_t), intent(in) :: data integer :: pdf_set pdf_set = data%id end function pdf_builtin_data_get_pdf_set @ %def pdf_builtin_data_get_pdf_set @ \subsection{The PDF object} The PDF $1\to 2$ interaction which describes the splitting of an (anti)proton into a parton and a beam remnant. We stay in the strict forward-splitting limit, but allow some invariant mass for the beam remnant such that the outgoing parton is exactly massless. For a real event, we would replace this by a parton cascade, where the outgoing partons have virtuality as dictated by parton-shower kinematics, and transverse momentum is generated. The PDF application is a $1\to 2$ splitting process, where the particles are ordered as (hadron, remnant, parton). Polarization is ignored completely. The beam particle is colorless, while partons and beam remnant carry color. The remnant gets a special flavor code. <>= public :: pdf_builtin_t <>= type, extends (sf_int_t) :: pdf_builtin_t type(pdf_builtin_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: q = 0 contains <> end type pdf_builtin_t @ %def pdf_builtin_t @ Type string: display the chosen PDF set. <>= procedure :: type_string => pdf_builtin_type_string <>= function pdf_builtin_type_string (object) result (string) class(pdf_builtin_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "PDF builtin: " // object%data%name else string = "PDF builtin: [undefined]" end if end function pdf_builtin_type_string @ %def pdf_builtin_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => pdf_builtin_write <>= subroutine pdf_builtin_write (object, unit, testflag) class(pdf_builtin_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A," // FMT_17 // ")") "Q =", object%q end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "PDF builtin data: [undefined]" end if end subroutine pdf_builtin_write @ %def pdf_builtin_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. Optionally, we can provide minimum and maximum values for the momentum transfer. <>= procedure :: init => pdf_builtin_init <>= subroutine pdf_builtin_init (sf_int, data) class(pdf_builtin_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask type(flavor_t) :: flv, flv_remnant type(color_t) :: col0 type(quantum_numbers_t), dimension(3) :: qn integer :: i select type (data) type is (pdf_builtin_data_t) mask = quantum_numbers_mask (.false., .false., .true.) call col0%init () call sf_int%base_init (mask, [0._default], [0._default], [0._default]) sf_int%data => data do i = -6, 6 if (data%mask(i)) then call qn(1)%init (data%flv_in, col = col0) if (i == 0) then call flv%init (GLUON, data%model) call flv_remnant%init (HADRON_REMNANT_OCTET, data%model) else call flv%init (i, data%model) call flv_remnant%init & (sign (HADRON_REMNANT_TRIPLET, -i), data%model) end if call qn(2)%init ( & flv = flv_remnant, col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init ( & flv = flv, col = color_from_flavor (flv, 1, reverse=.true.)) call sf_int%add_state (qn) end if end do if (data%has_photon .and. data%mask_photon) then call flv%init (PHOTON, data%model) call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model) call qn(2)%init (flv = flv_remnant, & col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init (flv = flv, & col = color_from_flavor (flv, 1, reverse = .true.)) call sf_int%add_state (qn) end if call sf_int%freeze () call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) sf_int%status = SF_INITIAL end select end subroutine pdf_builtin_init @ %def pdf_builtin_init @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ and consequently $f(r)=2r$. <>= procedure :: complete_kinematics => pdf_builtin_complete_kinematics <>= subroutine pdf_builtin_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("PDF builtin: map flag not supported") else x(1) = r(1) xb(1)= rb(1) f = 1 end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) case (SF_FAILED_KINEMATICS) sf_int%x = 0 f = 0 end select end subroutine pdf_builtin_complete_kinematics @ %def pdf_builtin_complete_kinematics @ Overriding the default method: we compute the [[x]] value from the momentum configuration. In this specific case, we also set the internally stored $x$ value, so it can be used in the following routine. <>= procedure :: recover_x => pdf_builtin_recover_x <>= subroutine pdf_builtin_recover_x (sf_int, x, xb, x_free) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) end subroutine pdf_builtin_recover_x @ %def sf_pdf_builtin_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => pdf_builtin_inverse_kinematics <>= subroutine pdf_builtin_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("PDF builtin: map flag not supported") else r(1) = x(1) rb(1)= xb(1) f = 1 end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine pdf_builtin_inverse_kinematics @ %def pdf_builtin_inverse_kinematics @ \subsection{Structure function} Once the scale is also known, we can actually call the PDF and set the values. Contrary to LHAPDF, the wrapper already takes care of adjusting to the $x$ and $Q$ bounds. Account for the Jacobian. [[fill_sub]] allows us to the fill all matrix-elements with [[sub > 0]]. Whereas [[rescale]] gives rescaling prescription for NLO convolution of the structure function in combination with [[i_sub]]. [[fill_sub]] and [[rescale]] with [[i_sub]] are mutually exclusive. <>= procedure :: apply => pdf_builtin_apply <>= subroutine pdf_builtin_apply (sf_int, scale, rescale, i_sub, fill_sub) class(pdf_builtin_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub logical, intent(in), optional :: fill_sub real(default), dimension(-6:6) :: ff real(double), dimension(-6:6) :: ff_dbl real(default) :: x, fph real(double) :: xx, qq complex(default), dimension(:), allocatable :: fc integer :: i, j_sub, i_sub_opt logical :: fill_sub_opt i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub fill_sub_opt = .false.; if (present (fill_sub)) fill_sub_opt = fill_sub if (present (rescale) .and. fill_sub_opt) then call msg_bug ("[pdf_builtin_apply] & & sf_rescale and fill_sub option are mutually exclusive.") end if if (i_sub_opt > 0 .and. fill_sub_opt) then call msg_bug ("[pdf_builtin_apply] & & i_sub and fill_sub options are mutually exclusive.") end if associate (data => sf_int%data) sf_int%q = scale x = sf_int%x if (present (rescale)) call rescale%apply (x) if (debug2_active (D_BEAMS)) then call msg_debug2 (D_BEAMS, "pdf_builtin_apply") call msg_debug2 (D_BEAMS, "rescale: ", present(rescale)) call msg_debug2 (D_BEAMS, "i_sub: ", i_sub_opt) call msg_debug2 (D_BEAMS, "fill_sub: ", fill_sub_opt) call msg_debug2 (D_BEAMS, "x: ", x) end if xx = x qq = scale if (data%invert) then if (data%has_photon) then call pdf_evolve (data%id, x, scale, ff(6:-6:-1), fph) else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff_dbl(6:-6:-1)) ff = ff_dbl else call pdf_evolve (data%id, x, scale, ff(6:-6:-1)) end if end if else if (data%has_photon) then call pdf_evolve (data%id, x, scale, ff, fph) else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff_dbl) ff = ff_dbl else call pdf_evolve (data%id, x, scale, ff) end if end if end if if (data%has_photon) then allocate (fc (count ([data%mask, data%mask_photon]))) fc = max (pack ([ff, fph], & [data%mask, data%mask_photon]), 0._default) else allocate (fc (count (data%mask))) fc = max (pack (ff, data%mask), 0._default) end if end associate if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc) if (present (rescale) .and. i_sub_opt > 0) then call sf_int%set_matrix_element (fc, [(i_sub_opt * size(fc) + i, i = 1, size(fc))]) if (rescale%has_gluons ()) then j_sub = i_sub_opt + n_beam_gluon_offset call sf_int%set_matrix_element (& spread (fc(7), 1, size(fc)), [(j_sub * size(fc) + i, i = 1, size(fc))]) end if else call sf_int%set_matrix_element (fc, [(i, i = 1, size(fc))]) end if if(fill_sub_opt) then do j_sub = 1, sf_int%get_n_sub () call sf_int%set_matrix_element (fc, [(j_sub * size(fc) + i, i = 1, size(fc))]) end do end if sf_int%status = SF_EVALUATED end subroutine pdf_builtin_apply @ %def pdf_builtin_apply @ \subsection{Strong Coupling} Since the PDF codes provide a function for computing the running $\alpha_s$ value, we make this available as an implementation of the abstract [[alpha_qcd_t]] type, which is used for matrix element evaluation. <>= public :: alpha_qcd_pdf_builtin_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_pdf_builtin_t type(string_t) :: pdfset_name integer :: pdfset_id = -1 contains <> end type alpha_qcd_pdf_builtin_t @ %def alpha_qcd_pdf_builtin_t @ Output. <>= procedure :: write => alpha_qcd_pdf_builtin_write <>= subroutine alpha_qcd_pdf_builtin_write (object, unit) class(alpha_qcd_pdf_builtin_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A)") "QCD parameters (pdf_builtin):" write (u, "(5x,A,A)") "PDF set = ", char (object%pdfset_name) write (u, "(5x,A,I0)") "PDF ID = ", object%pdfset_id end subroutine alpha_qcd_pdf_builtin_write @ %def alpha_qcd_pdf_builtin_write @ Calculation: the numeric ID selects the correct PDF set, which must be properly initialized. <>= procedure :: get => alpha_qcd_pdf_builtin_get <>= function alpha_qcd_pdf_builtin_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_pdf_builtin_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha alpha = pdf_alphas (alpha_qcd%pdfset_id, scale) end function alpha_qcd_pdf_builtin_get @ %def alpha_qcd_pdf_builtin_get @ Initialization. We need to access the global initialization status. <>= procedure :: init => alpha_qcd_pdf_builtin_init <>= subroutine alpha_qcd_pdf_builtin_init (alpha_qcd, name, path) class(alpha_qcd_pdf_builtin_t), intent(out) :: alpha_qcd type(string_t), intent(in) :: name type(string_t), intent(in) :: path alpha_qcd%pdfset_name = name alpha_qcd%pdfset_id = pdf_get_id (name) if (alpha_qcd%pdfset_id < 0) & call msg_fatal ("QCD parameter initialization: PDF set " & // char (name) // " is unknown") call pdf_init (alpha_qcd%pdfset_id, path) end subroutine alpha_qcd_pdf_builtin_init @ %def alpha_qcd_pdf_builtin_init @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_pdf_builtin_ut.f90]]>>= <> module sf_pdf_builtin_ut use unit_tests use sf_pdf_builtin_uti <> <> contains <> end module sf_pdf_builtin_ut @ %def sf_pdf_builtin_ut @ <<[[sf_pdf_builtin_uti.f90]]>>= <> module sf_pdf_builtin_uti <> <> use os_interface use physics_defs, only: PROTON use sm_qcd use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_base use sf_pdf_builtin <> <> contains <> end module sf_pdf_builtin_uti @ %def sf_pdf_builtin_ut @ API: driver for the unit tests below. <>= public :: sf_pdf_builtin_test <>= subroutine sf_pdf_builtin_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_pdf_builtin_test @ %def sf_pdf_builtin_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_pdf_builtin_1, "sf_pdf_builtin_1", & "structure function configuration", & u, results) <>= public :: sf_pdf_builtin_1 <>= subroutine sf_pdf_builtin_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data type(string_t) :: name write (u, "(A)") "* Test output: sf_pdf_builtin_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call os_data%init () call model%init_sm_test () pdg_in = PROTON allocate (pdf_builtin_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") name = "CTEQ6L" select type (data) type is (pdf_builtin_data_t) call data%init (model, pdg_in, name, & os_data%pdf_builtin_datapath) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_pdf_builtin_1" end subroutine sf_pdf_builtin_1 @ %def sf_pdf_builtin_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the PDF builtin structure function. <>= call test (sf_pdf_builtin_2, "sf_pdf_builtin_2", & "structure function instance", & u, results) <>= public :: sf_pdf_builtin_2 <>= subroutine sf_pdf_builtin_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(string_t) :: name type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_pdf_builtin_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () call model%init_sm_test () call flv%init (PROTON, model) pdg_in = PROTON call reset_interaction_counter () name = "CTEQ6L" allocate (pdf_builtin_data_t :: data) select type (data) type is (pdf_builtin_data_t) call data%init (model, pdg_in, name, & os_data%pdf_builtin_datapath) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.5_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100 GeV" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_pdf_builtin_2" end subroutine sf_pdf_builtin_2 @ %def sf_pdf_builtin_2 @ \subsubsection{Strong Coupling} Test $\alpha_s$ as an implementation of the [[alpha_qcd_t]] abstract type. <>= call test (sf_pdf_builtin_3, "sf_pdf_builtin_3", & "running alpha_s", & u, results) <>= public :: sf_pdf_builtin_3 <>= subroutine sf_pdf_builtin_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(qcd_t) :: qcd type(string_t) :: name write (u, "(A)") "* Test output: sf_pdf_builtin_3" write (u, "(A)") "* Purpose: initialize and evaluate alpha_s" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () name = "CTEQ6L" write (u, "(A)") "* Initialize qcd object" write (u, "(A)") allocate (alpha_qcd_pdf_builtin_t :: qcd%alpha) select type (alpha => qcd%alpha) type is (alpha_qcd_pdf_builtin_t) call alpha%init (name, os_data%pdf_builtin_datapath) end select call qcd%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100" write (u, "(A)") write (u, "(1x,A,F8.5)") "alpha = ", qcd%alpha%get (100._default) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") write (u, "(A)") "* Test output end: sf_pdf_builtin_3" end subroutine sf_pdf_builtin_3 @ %def sf_pdf_builtin_3 @ \clearpage %------------------------------------------------------------------------ \section{LHAPDF} Parton distribution functions (PDFs) are available via an interface to the LHAPDF standard library. @ \subsection{The module} <<[[sf_lhapdf.f90]]>>= <> module sf_lhapdf <> <> use format_defs, only: FMT_17, FMT_19 use io_units use system_dependencies, only: LHAPDF_PDFSETS_PATH use system_dependencies, only: LHAPDF5_AVAILABLE use system_dependencies, only: LHAPDF6_AVAILABLE use diagnostics use physics_defs, only: n_beam_gluon_offset use physics_defs, only: PROTON, PHOTON, PIPLUS, GLUON use physics_defs, only: HADRON_REMNANT_SINGLET use physics_defs, only: HADRON_REMNANT_TRIPLET use physics_defs, only: HADRON_REMNANT_OCTET use lorentz use sm_qcd use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use sf_base use lhapdf !NODEP! use hoppet_interface <> <> <> <> <> <> contains <> end module sf_lhapdf @ %def sf_lhapdf @ \subsection{Codes for default PDF sets} The default PDF for protons set is chosen to be CTEQ6ll (LO fit with LO $\alpha_s$). <>= character(*), parameter :: LHAPDF5_DEFAULT_PROTON = "cteq6ll.LHpdf" character(*), parameter :: LHAPDF5_DEFAULT_PION = "ABFKWPI.LHgrid" character(*), parameter :: LHAPDF5_DEFAULT_PHOTON = "GSG960.LHgrid" character(*), parameter :: LHAPDF6_DEFAULT_PROTON = "CT10" @ %def LHAPDF5_DEFAULT_PROTON LHAPDF5_DEFAULT_PION @ %def LHAPDF5_DEFAULT_PHOTON LHAPDF6_DEFAULT_PROTON @ \subsection{LHAPDF library interface} Here we specify explicit interfaces for all LHAPDF routines that we use below. <>= interface subroutine InitPDFsetM (set, file) integer, intent(in) :: set character(*), intent(in) :: file end subroutine InitPDFsetM end interface @ %def InitPDFsetM <>= interface subroutine InitPDFM (set, mem) integer, intent(in) :: set, mem end subroutine InitPDFM end interface @ %def InitPDFM <>= interface subroutine numberPDFM (set, n_members) integer, intent(in) :: set integer, intent(out) :: n_members end subroutine numberPDFM end interface @ %def numberPDFM <>= interface subroutine evolvePDFM (set, x, q, ff) integer, intent(in) :: set double precision, intent(in) :: x, q double precision, dimension(-6:6), intent(out) :: ff end subroutine evolvePDFM end interface @ %def evolvePDFM <>= interface subroutine evolvePDFphotonM (set, x, q, ff, fphot) integer, intent(in) :: set double precision, intent(in) :: x, q double precision, dimension(-6:6), intent(out) :: ff double precision, intent(out) :: fphot end subroutine evolvePDFphotonM end interface @ %def evolvePDFphotonM <>= interface subroutine evolvePDFpM (set, x, q, s, scheme, ff) integer, intent(in) :: set double precision, intent(in) :: x, q, s integer, intent(in) :: scheme double precision, dimension(-6:6), intent(out) :: ff end subroutine evolvePDFpM end interface @ %def evolvePDFpM <>= interface subroutine GetXminM (set, mem, xmin) integer, intent(in) :: set, mem double precision, intent(out) :: xmin end subroutine GetXminM end interface @ %def GetXminM <>= interface subroutine GetXmaxM (set, mem, xmax) integer, intent(in) :: set, mem double precision, intent(out) :: xmax end subroutine GetXmaxM end interface @ %def GetXmaxM <>= interface subroutine GetQ2minM (set, mem, q2min) integer, intent(in) :: set, mem double precision, intent(out) :: q2min end subroutine GetQ2minM end interface @ %def GetQ2minM <>= interface subroutine GetQ2maxM (set, mem, q2max) integer, intent(in) :: set, mem double precision, intent(out) :: q2max end subroutine GetQ2maxM end interface @ %def GetQ2maxM <>= interface function has_photon () result(flag) logical :: flag end function has_photon end interface @ %def has_photon @ \subsection{The LHAPDF status} This type holds the initialization status of the LHAPDF system. Entry 1 is for proton PDFs, entry 2 for pion PDFs, entry 3 for photon PDFs. Since it is connected to the external LHAPDF library, this is a truly global object. We implement it as a a private module variable. To access it from elsewhere, the caller has to create and initialize an object of type [[lhapdf_status_t]], which acts as a proxy. <>= type :: lhapdf_global_status_t private logical, dimension(3) :: initialized = .false. end type lhapdf_global_status_t @ %def lhapdf_global_status_t <>= type(lhapdf_global_status_t), save :: lhapdf_global_status @ %def lhapdf_global_status <>= function lhapdf_global_status_is_initialized (set) result (flag) logical :: flag integer, intent(in), optional :: set if (present (set)) then select case (set) case (1:3); flag = lhapdf_global_status%initialized(set) case default; flag = .false. end select else flag = any (lhapdf_global_status%initialized) end if end function lhapdf_global_status_is_initialized @ %def lhapdf_global_status_is_initialized <>= subroutine lhapdf_global_status_set_initialized (set) integer, intent(in) :: set lhapdf_global_status%initialized(set) = .true. end subroutine lhapdf_global_status_set_initialized @ %def lhapdf_global_status_set_initialized @ This is the only public procedure, it tells the system to forget about previous initialization, allowing for changing the chosen PDF set. Note that such a feature works only if the global program flow is serial, so no two distinct sets are accessed simultaneously. But this applies to LHAPDF anyway. <>= public :: lhapdf_global_reset <>= subroutine lhapdf_global_reset () lhapdf_global_status%initialized = .false. end subroutine lhapdf_global_reset @ %def lhapdf_global_status_reset @ \subsection{LHAPDF initialization} Before using LHAPDF, we have to initialize it with a particular data set and member. This applies not just if we use structure functions, but also if we just use an $\alpha_s$ formula. The integer [[set]] should be $1$ for proton, $2$ for pion, and $3$ for photon, but this is just convention. It appears as if LHAPDF does not allow for multiple data sets being used concurrently (?), so multi-threaded usage with different sets (e.g., a scan) is excluded. The current setup with a global flag that indicates initialization is fine as long as Whizard itself is run in serial mode at the Sindarin level. If we introduce multithreading in any form from Sindarin, we have to rethink the implementation of the LHAPDF interface. (The same considerations apply to builtin PDFs.) If the particular set has already been initialized, do nothing. This implies that whenever we want to change the setup for a particular set, we have to reset the LHAPDF status. [[lhapdf_initialize]] has an obvious name clash with [[lhapdf_init]], the reason it works for [[pdf_builtin]] is that there things are outsourced to a separate module (inc. [[lhapdf_status]] etc.). <>= public :: lhapdf_initialize <>= subroutine lhapdf_initialize (set, prefix, file, member, pdf, b_match) integer, intent(in) :: set type(string_t), intent(inout) :: prefix type(string_t), intent(inout) :: file type(lhapdf_pdf_t), intent(inout), optional :: pdf integer, intent(inout) :: member logical, intent(in), optional :: b_match if (prefix == "") prefix = LHAPDF_PDFSETS_PATH if (LHAPDF5_AVAILABLE) then if (lhapdf_global_status_is_initialized (set)) return if (file == "") then select case (set) case (1); file = LHAPDF5_DEFAULT_PROTON case (2); file = LHAPDF5_DEFAULT_PION case (3); file = LHAPDF5_DEFAULT_PHOTON end select end if if (data_file_exists (prefix // "/" // file)) then call InitPDFsetM (set, char (prefix // "/" // file)) else call msg_fatal ("LHAPDF: Data file '" & // char (file) // "' not found in '" // char (prefix) // "'.") return end if if (.not. dataset_member_exists (set, member)) then call msg_error (" LHAPDF: Chosen member does not exist for set '" & // char (file) // "', using default.") member = 0 end if call InitPDFM (set, member) else if (LHAPDF6_AVAILABLE) then ! TODO: (bcn 2015-07-07) we should have a closer look why this global ! check must not be executed ! if (lhapdf_global_status_is_initialized (set) .and. & ! pdf%is_associated ()) return if (file == "") then select case (set) case (1); file = LHAPDF6_DEFAULT_PROTON case (2); call msg_fatal ("LHAPDF6: no pion PDFs supported") case (3); call msg_fatal ("LHAPDF6: no photon PDFs supported") end select end if if (data_file_exists (prefix // "/" // file // "/" // file // ".info")) then call pdf%init (char (file), member) else call msg_fatal ("LHAPDF: Data file '" & // char (file) // "' not found in '" // char (prefix) // "'.") return end if end if if (present (b_match)) then if (b_match) then if (LHAPDF5_AVAILABLE) then call hoppet_init (.false.) else if (LHAPDF6_AVAILABLE) then call hoppet_init (.false., pdf) end if end if end if call lhapdf_global_status_set_initialized (set) contains function data_file_exists (fq_name) result (exist) type(string_t), intent(in) :: fq_name logical :: exist inquire (file = char(fq_name), exist = exist) end function data_file_exists function dataset_member_exists (set, member) result (exist) integer, intent(in) :: set, member logical :: exist integer :: n_members call numberPDFM (set, n_members) exist = member >= 0 .and. member <= n_members end function dataset_member_exists end subroutine lhapdf_initialize @ %def lhapdf_initialize @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ and consequently $f(r)=2r$. <>= procedure :: complete_kinematics => lhapdf_complete_kinematics <>= subroutine lhapdf_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(lhapdf_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("LHAPDF: map flag not supported") else x(1) = r(1) xb(1)= rb(1) f = 1 end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) case (SF_FAILED_KINEMATICS) sf_int%x = 0 f = 0 end select end subroutine lhapdf_complete_kinematics @ %def lhapdf_complete_kinematics @ Overriding the default method: we compute the [[x]] value from the momentum configuration. In this specific case, we also set the internally stored $x$ value, so it can be used in the following routine. <>= procedure :: recover_x => lhapdf_recover_x <>= subroutine lhapdf_recover_x (sf_int, x, xb, x_free) class(lhapdf_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) end subroutine lhapdf_recover_x @ %def lhapdf_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => lhapdf_inverse_kinematics <>= subroutine lhapdf_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(lhapdf_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("LHAPDF: map flag not supported") else r(1) = x(1) rb(1)= xb(1) f = 1 end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine lhapdf_inverse_kinematics @ %def lhapdf_inverse_kinematics @ \subsection{The LHAPDF data block} The data block holds the incoming flavor (which has to be proton, pion, or photon), the corresponding pointer to the global access data (1, 2, or 3), the flag [[invert]] which is set for an antiproton, the bounds as returned by LHAPDF for the specified set, and a mask that determines which partons will be actually in use. <>= public :: lhapdf_data_t <>= type, extends (sf_data_t) :: lhapdf_data_t private type(string_t) :: prefix type(string_t) :: file type(lhapdf_pdf_t) :: pdf integer :: member = 0 class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in integer :: set = 0 logical :: invert = .false. logical :: photon = .false. logical :: has_photon = .false. integer :: photon_scheme = 0 real(default) :: xmin = 0, xmax = 0 real(default) :: qmin = 0, qmax = 0 logical, dimension(-6:6) :: mask = .true. logical :: mask_photon = .true. logical :: hoppet_b_matching = .false. contains <> end type lhapdf_data_t @ %def lhapdf_data_t @ Generate PDF data. This is provided as a function, but it has the side-effect of initializing the requested PDF set. A finalizer is not needed. The library uses double precision, so since the default precision may be extended or quadruple, we use auxiliary variables for type casting. <>= procedure :: init => lhapdf_data_init <>= subroutine lhapdf_data_init & (data, model, pdg_in, prefix, file, member, photon_scheme, & hoppet_b_matching) class(lhapdf_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in type(string_t), intent(in), optional :: prefix, file integer, intent(in), optional :: member integer, intent(in), optional :: photon_scheme logical, intent(in), optional :: hoppet_b_matching double precision :: xmin, xmax, q2min, q2max external :: InitPDFsetM, InitPDFM, numberPDFM external :: GetXminM, GetXmaxM, GetQ2minM, GetQ2maxM if (.not. LHAPDF5_AVAILABLE .and. .not. LHAPDF6_AVAILABLE) then call msg_fatal ("LHAPDF requested but library is not linked") return end if data%model => model if (pdg_array_get_length (pdg_in) /= 1) & call msg_fatal ("PDF: incoming particle must be unique") call data%flv_in%init (pdg_array_get (pdg_in, 1), model) select case (pdg_array_get (pdg_in, 1)) case (PROTON) data%set = 1 case (-PROTON) data%set = 1 data%invert = .true. case (PIPLUS) data%set = 2 case (-PIPLUS) data%set = 2 data%invert = .true. case (PHOTON) data%set = 3 data%photon = .true. if (present (photon_scheme)) data%photon_scheme = photon_scheme case default call msg_fatal (" LHAPDF: " & // "incoming particle must be (anti)proton, pion, or photon.") return end select if (present (prefix)) then data%prefix = prefix else data%prefix = "" end if if (present (file)) then data%file = file else data%file = "" end if if (present (hoppet_b_matching)) data%hoppet_b_matching = hoppet_b_matching if (LHAPDF5_AVAILABLE) then call lhapdf_initialize & (data%set, data%prefix, data%file, data%member, & b_match = data%hoppet_b_matching) call GetXminM (data%set, data%member, xmin) call GetXmaxM (data%set, data%member, xmax) call GetQ2minM (data%set, data%member, q2min) call GetQ2maxM (data%set, data%member, q2max) data%xmin = xmin data%xmax = xmax data%qmin = sqrt (q2min) data%qmax = sqrt (q2max) data%has_photon = has_photon () else if (LHAPDF6_AVAILABLE) then call lhapdf_initialize & (data%set, data%prefix, data%file, data%member, & data%pdf, data%hoppet_b_matching) data%xmin = data%pdf%getxmin () data%xmax = data%pdf%getxmax () data%qmin = sqrt(data%pdf%getq2min ()) data%qmax = sqrt(data%pdf%getq2max ()) data%has_photon = data%pdf%has_photon () end if end subroutine lhapdf_data_init @ %def lhapdf_data_init @ Enable/disable partons explicitly. If a mask entry is true, applying the PDF will generate the corresponding flavor on output. <>= procedure :: set_mask => lhapdf_data_set_mask <>= subroutine lhapdf_data_set_mask (data, mask) class(lhapdf_data_t), intent(inout) :: data logical, dimension(-6:6), intent(in) :: mask data%mask = mask end subroutine lhapdf_data_set_mask @ %def lhapdf_data_set_mask @ Return the public part of the data set. <>= public :: lhapdf_data_get_public_info <>= subroutine lhapdf_data_get_public_info & (data, lhapdf_dir, lhapdf_file, lhapdf_member) type(lhapdf_data_t), intent(in) :: data type(string_t), intent(out) :: lhapdf_dir, lhapdf_file integer, intent(out) :: lhapdf_member lhapdf_dir = data%prefix lhapdf_file = data%file lhapdf_member = data%member end subroutine lhapdf_data_get_public_info @ %def lhapdf_data_get_public_info @ Return the number of the member of the data set. <>= public :: lhapdf_data_get_set <>= function lhapdf_data_get_set(data) result(set) type(lhapdf_data_t), intent(in) :: data integer :: set set = data%set end function lhapdf_data_get_set @ %def lhapdf_data_get_set @ Output <>= procedure :: write => lhapdf_data_write <>= subroutine lhapdf_data_write (data, unit, verbose) class(lhapdf_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical :: verb integer :: u if (present (verbose)) then verb = verbose else verb = .false. end if u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "LHAPDF data:" if (data%set /= 0) then write (u, "(3x,A)", advance="no") "flavor = " call data%flv_in%write (u); write (u, *) if (verb) then write (u, "(3x,A,A)") " prefix = ", char (data%prefix) else write (u, "(3x,A,A)") " prefix = ", & " " end if write (u, "(3x,A,A)") " file = ", char (data%file) write (u, "(3x,A,I3)") " member = ", data%member write (u, "(3x,A," // FMT_19 // ")") " x(min) = ", data%xmin write (u, "(3x,A," // FMT_19 // ")") " x(max) = ", data%xmax write (u, "(3x,A," // FMT_19 // ")") " Q(min) = ", data%qmin write (u, "(3x,A," // FMT_19 // ")") " Q(max) = ", data%qmax write (u, "(3x,A,L1)") " invert = ", data%invert if (data%photon) write (u, "(3x,A,I3)") & " IP2 (scheme) = ", data%photon_scheme write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") & " mask = ", & data%mask(-6:-1), "*", data%mask(0), "*", data%mask(1:6) write (u, "(3x,A,L1)") " photon mask = ", data%mask_photon if (data%set == 1) write (u, "(3x,A,L1)") & " hoppet_b = ", data%hoppet_b_matching else write (u, "(3x,A)") "[undefined]" end if end subroutine lhapdf_data_write @ %def lhapdf_data_write @ The number of parameters is one. We do not generate transverse momentum. <>= procedure :: get_n_par => lhapdf_data_get_n_par <>= function lhapdf_data_get_n_par (data) result (n) class(lhapdf_data_t), intent(in) :: data integer :: n n = 1 end function lhapdf_data_get_n_par @ %def lhapdf_data_get_n_par @ Return the outgoing particle PDG codes. This is based on the mask. <>= procedure :: get_pdg_out => lhapdf_data_get_pdg_out <>= subroutine lhapdf_data_get_pdg_out (data, pdg_out) class(lhapdf_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer, dimension(:), allocatable :: pdg1 integer :: n, np, i n = count (data%mask) np = 0; if (data%has_photon .and. data%mask_photon) np = 1 allocate (pdg1 (n + np)) pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask) if (np == 1) pdg1(n+np) = PHOTON pdg_out(1) = pdg1 end subroutine lhapdf_data_get_pdg_out @ %def lhapdf_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => lhapdf_data_allocate_sf_int <>= subroutine lhapdf_data_allocate_sf_int (data, sf_int) class(lhapdf_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (lhapdf_t :: sf_int) end subroutine lhapdf_data_allocate_sf_int @ %def lhapdf_data_allocate_sf_int @ Return the numerical PDF set index. <>= procedure :: get_pdf_set => lhapdf_data_get_pdf_set <>= elemental function lhapdf_data_get_pdf_set (data) result (pdf_set) class(lhapdf_data_t), intent(in) :: data integer :: pdf_set pdf_set = data%set end function lhapdf_data_get_pdf_set @ %def lhapdf_data_get_pdf_set @ \subsection{The LHAPDF object} The [[lhapdf_t]] data type is a $1\to 2$ interaction which describes the splitting of an (anti)proton into a parton and a beam remnant. We stay in the strict forward-splitting limit, but allow some invariant mass for the beam remnant such that the outgoing parton is exactly massless. For a real event, we would replace this by a parton cascade, where the outgoing partons have virtuality as dictated by parton-shower kinematics, and transverse momentum is generated. This is the LHAPDF object which holds input data together with the interaction. We also store the $x$ momentum fraction and the scale, since kinematics and function value are requested at different times. The PDF application is a $1\to 2$ splitting process, where the particles are ordered as (hadron, remnant, parton). Polarization is ignored completely. The beam particle is colorless, while partons and beam remnant carry color. The remnant gets a special flavor code. <>= public :: lhapdf_t <>= type, extends (sf_int_t) :: lhapdf_t type(lhapdf_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: q = 0 real(default) :: s = 0 contains <> end type lhapdf_t @ %def lhapdf_t @ Type string: display the chosen PDF set. <>= procedure :: type_string => lhapdf_type_string <>= function lhapdf_type_string (object) result (string) class(lhapdf_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "LHAPDF: " // object%data%file else string = "LHAPDF: [undefined]" end if end function lhapdf_type_string @ %def lhapdf_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => lhapdf_write <>= subroutine lhapdf_write (object, unit, testflag) class(lhapdf_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A," // FMT_17 // ")") "Q =", object%q end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "LHAPDF data: [undefined]" end if end subroutine lhapdf_write @ %def lhapdf_write @ Initialize. We know that [[data]] will be of concrete type [[sf_lhapdf_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. <>= procedure :: init => lhapdf_init <>= subroutine lhapdf_init (sf_int, data) class(lhapdf_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask type(flavor_t) :: flv, flv_remnant type(color_t) :: col0 type(quantum_numbers_t), dimension(3) :: qn integer :: i select type (data) type is (lhapdf_data_t) mask = quantum_numbers_mask (.false., .false., .true.) call col0%init () call sf_int%base_init (mask, [0._default], [0._default], [0._default]) sf_int%data => data do i = -6, 6 if (data%mask(i)) then call qn(1)%init (data%flv_in, col = col0) if (i == 0) then call flv%init (GLUON, data%model) call flv_remnant%init (HADRON_REMNANT_OCTET, data%model) else call flv%init (i, data%model) call flv_remnant%init & (sign (HADRON_REMNANT_TRIPLET, -i), data%model) end if call qn(2)%init ( & flv = flv_remnant, col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init ( & flv = flv, col = color_from_flavor (flv, 1, reverse=.true.)) call sf_int%add_state (qn) end if end do if (data%has_photon .and. data%mask_photon) then call flv%init (PHOTON, data%model) call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model) call qn(2)%init (flv = flv_remnant, & col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init (flv = flv, & col = color_from_flavor (flv, 1, reverse=.true.)) call sf_int%add_state (qn) end if call sf_int%freeze () call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) sf_int%status = SF_INITIAL end select end subroutine lhapdf_init @ %def lhapdf_init @ \subsection{Structure function} We have to cast the LHAPDF arguments to/from double precision (possibly from/to extended/quadruple precision), if necessary. Furthermore, some structure functions can yield negative results (sea quarks close to $x=1$). We set these unphysical values to zero. <>= procedure :: apply => lhapdf_apply <>= subroutine lhapdf_apply (sf_int, scale, rescale, i_sub, fill_sub) class(lhapdf_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub logical, intent(in), optional :: fill_sub real(default) :: x, s double precision :: xx, qq, ss double precision, dimension(-6:6) :: ff double precision :: fphot complex(default), dimension(:), allocatable :: fc integer :: i, i_sub_opt, j_sub logical :: fill_sub_opt external :: evolvePDFM, evolvePDFpM i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub fill_sub_opt = .false.; if (present (fill_sub)) fill_sub_opt = fill_sub if (present (rescale) .and. fill_sub_opt) then call msg_bug ("[lhapdf_apply] & & sf_rescale and fill_sub option are mutually exclusive.") end if if (i_sub_opt > 0 .and. fill_sub_opt) then call msg_bug ("[lhapdf_apply] & & i_sub and fill_sub options are mutually exclusive.") end if associate (data => sf_int%data) sf_int%q = scale x = sf_int%x if (present (rescale)) call rescale%apply (x) s = sf_int%s xx = x if (debug2_active (D_BEAMS)) then call msg_debug2 (D_BEAMS, "lhapdf_apply") call msg_debug2 (D_BEAMS, "rescale: ", present(rescale)) call msg_debug2 (D_BEAMS, "i_sub: ", i_sub_opt) call msg_debug2 (D_BEAMS, "fill_sub: ", fill_sub_opt) call msg_debug2 (D_BEAMS, "x: ", x) end if qq = min (data%qmax, scale) qq = max (data%qmin, qq) if (.not. data% photon) then if (data%invert) then if (data%has_photon) then if (LHAPDF5_AVAILABLE) then call evolvePDFphotonM & (data% set, xx, qq, ff(6:-6:-1), fphot) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfphotonm & (xx, qq, ff(6:-6:-1), fphot) end if else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff(6:-6:-1)) else if (LHAPDF5_AVAILABLE) then call evolvePDFM (data% set, xx, qq, ff(6:-6:-1)) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfm (xx, qq, ff(6:-6:-1)) end if end if end if else if (data%has_photon) then if (LHAPDF5_AVAILABLE) then call evolvePDFphotonM (data% set, xx, qq, ff, fphot) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfphotonm (xx, qq, ff, fphot) end if else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff) else if (LHAPDF5_AVAILABLE) then call evolvePDFM (data% set, xx, qq, ff) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfm (xx, qq, ff) end if end if end if end if else ss = s if (LHAPDF5_AVAILABLE) then call evolvePDFpM (data% set, xx, qq, & ss, data% photon_scheme, ff) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfpm (xx, qq, ss, & data%photon_scheme, ff) end if end if if (data%has_photon) then allocate (fc (count ([data%mask, data%mask_photon]))) fc = max (pack ([ff, fphot] / x, & [data% mask, data%mask_photon]), 0._default) else allocate (fc (count (data%mask))) fc = max (pack (ff / x, data%mask), 0._default) end if end associate if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc) if (present (rescale) .and. i_sub_opt > 0) then call sf_int%set_matrix_element (fc, [(i_sub_opt * size(fc) + i, i = 1, size(fc))]) if (rescale%has_gluons ()) then j_sub = i_sub_opt + n_beam_gluon_offset call sf_int%set_matrix_element (& spread (fc(7), 1, size(fc)), [(j_sub * size(fc) + i, i = 1, size(fc))]) end if else call sf_int%set_matrix_element (fc, [(i, i = 1, size(fc))]) end if if(fill_sub_opt) then do j_sub = 1, sf_int%get_n_sub () call sf_int%set_matrix_element (fc, [(j_sub * size(fc) + i, i = 1, size(fc))]) end do end if sf_int%status = SF_EVALUATED end subroutine lhapdf_apply @ %def apply_lhapdf @ \subsection{Strong Coupling} Since the PDF codes provide a function for computing the running $\alpha_s$ value, we make this available as an implementation of the abstract [[alpha_qcd_t]] type, which is used for matrix element evaluation. <>= public :: alpha_qcd_lhapdf_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_lhapdf_t type(string_t) :: pdfset_dir type(string_t) :: pdfset_file integer :: pdfset_member = -1 type(lhapdf_pdf_t) :: pdf contains <> end type alpha_qcd_lhapdf_t @ %def alpha_qcd_lhapdf_t @ Output. As in earlier versions we leave the LHAPDF path out. <>= procedure :: write => alpha_qcd_lhapdf_write <>= subroutine alpha_qcd_lhapdf_write (object, unit) class(alpha_qcd_lhapdf_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A)") "QCD parameters (lhapdf):" write (u, "(5x,A,A)") "PDF set = ", char (object%pdfset_file) write (u, "(5x,A,I0)") "PDF member = ", object%pdfset_member end subroutine alpha_qcd_lhapdf_write @ %def alpha_qcd_lhapdf_write @ Calculation: the numeric member ID selects the correct PDF set, which must be properly initialized. <>= interface double precision function alphasPDF (Q) double precision, intent(in) :: Q end function alphasPDF end interface @ %def alphasPDF @ <>= procedure :: get => alpha_qcd_lhapdf_get <>= function alpha_qcd_lhapdf_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha if (LHAPDF5_AVAILABLE) then alpha = alphasPDF (dble (scale)) else if (LHAPDF6_AVAILABLE) then alpha = alpha_qcd%pdf%alphas_pdf (dble (scale)) end if end function alpha_qcd_lhapdf_get @ %def alpha_qcd_lhapdf_get @ Initialization. We need to access the (quasi-global) initialization status. <>= procedure :: init => alpha_qcd_lhapdf_init <>= subroutine alpha_qcd_lhapdf_init (alpha_qcd, file, member, path) class(alpha_qcd_lhapdf_t), intent(out) :: alpha_qcd type(string_t), intent(inout) :: file integer, intent(inout) :: member type(string_t), intent(inout) :: path alpha_qcd%pdfset_file = file alpha_qcd%pdfset_member = member if (alpha_qcd%pdfset_member < 0) & call msg_fatal ("QCD parameter initialization: PDF set " & // char (file) // " is unknown") if (LHAPDF5_AVAILABLE) then call lhapdf_initialize (1, path, file, member) else if (LHAPDF6_AVAILABLE) then call lhapdf_initialize & (1, path, file, member, alpha_qcd%pdf) end if end subroutine alpha_qcd_lhapdf_init @ %def alpha_qcd_lhapdf_init @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_lhapdf_ut.f90]]>>= <> module sf_lhapdf_ut use unit_tests use system_dependencies, only: LHAPDF5_AVAILABLE use system_dependencies, only: LHAPDF6_AVAILABLE use sf_lhapdf_uti <> <> contains <> end module sf_lhapdf_ut @ %def sf_lhapdf_ut @ <<[[sf_lhapdf_uti.f90]]>>= <> module sf_lhapdf_uti <> <> use system_dependencies, only: LHAPDF5_AVAILABLE use system_dependencies, only: LHAPDF6_AVAILABLE use os_interface use physics_defs, only: PROTON use sm_qcd use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_base use sf_lhapdf <> <> contains <> end module sf_lhapdf_uti @ %def sf_lhapdf_ut @ API: driver for the unit tests below. <>= public :: sf_lhapdf_test <>= subroutine sf_lhapdf_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_lhapdf_test @ %def sf_lhapdf_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= if (LHAPDF5_AVAILABLE) then call test (sf_lhapdf_1, "sf_lhapdf5_1", & "structure function configuration", & u, results) else if (LHAPDF6_AVAILABLE) then call test (sf_lhapdf_1, "sf_lhapdf6_1", & "structure function configuration", & u, results) end if <>= public :: sf_lhapdf_1 <>= subroutine sf_lhapdf_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_lhapdf_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_sm_test () pdg_in = PROTON allocate (lhapdf_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (lhapdf_data_t) call data%init (model, pdg_in) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_lhapdf_1" end subroutine sf_lhapdf_1 @ %def sf_lhapdf_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the PDF builtin structure function. <>= if (LHAPDF5_AVAILABLE) then call test (sf_lhapdf_2, "sf_lhapdf5_2", & "structure function instance", & u, results) else if (LHAPDF6_AVAILABLE) then call test (sf_lhapdf_2, "sf_lhapdf6_2", & "structure function instance", & u, results) end if <>= public :: sf_lhapdf_2 <>= subroutine sf_lhapdf_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_lhapdf_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (PROTON, model) pdg_in = PROTON call lhapdf_global_reset () call reset_interaction_counter () allocate (lhapdf_data_t :: data) select type (data) type is (lhapdf_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.5_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100 GeV" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale = 100._default) call sf_int%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_lhapdf_2" end subroutine sf_lhapdf_2 @ %def sf_lhapdf_2 @ \subsubsection{Strong Coupling} Test $\alpha_s$ as an implementation of the [[alpha_qcd_t]] abstract type. <>= if (LHAPDF5_AVAILABLE) then call test (sf_lhapdf_3, "sf_lhapdf5_3", & "running alpha_s", & u, results) else if (LHAPDF6_AVAILABLE) then call test (sf_lhapdf_3, "sf_lhapdf6_3", & "running alpha_s", & u, results) end if <>= public :: sf_lhapdf_3 <>= subroutine sf_lhapdf_3 (u) integer, intent(in) :: u type(qcd_t) :: qcd type(string_t) :: name, path integer :: member write (u, "(A)") "* Test output: sf_lhapdf_3" write (u, "(A)") "* Purpose: initialize and evaluate alpha_s" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call lhapdf_global_reset () if (LHAPDF5_AVAILABLE) then name = "cteq6ll.LHpdf" member = 1 path = "" else if (LHAPDF6_AVAILABLE) then name = "CT10" member = 1 path = "" end if write (u, "(A)") "* Initialize qcd object" write (u, "(A)") allocate (alpha_qcd_lhapdf_t :: qcd%alpha) select type (alpha => qcd%alpha) type is (alpha_qcd_lhapdf_t) call alpha%init (name, member, path) end select call qcd%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100" write (u, "(A)") write (u, "(1x,A,F8.5)") "alpha = ", qcd%alpha%get (100._default) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") write (u, "(A)") "* Test output end: sf_lhapdf_3" end subroutine sf_lhapdf_3 @ %def sf_lhapdf_3 @ \section{Easy PDF Access} For the shower, subtraction and matching, it is very useful to have direct access to $f(x,Q)$ independently of the used library. <<[[pdf.f90]]>>= <> module pdf <> use io_units use system_dependencies, only: LHAPDF5_AVAILABLE, LHAPDF6_AVAILABLE use diagnostics use beam_structures use lhapdf !NODEP! use pdf_builtin !NODEP! <> <> <> <> contains <> end module pdf @ %def pdf We support the following implementations: <>= integer, parameter, public :: STRF_NONE = 0 integer, parameter, public :: STRF_LHAPDF6 = 1 integer, parameter, public :: STRF_LHAPDF5 = 2 integer, parameter, public :: STRF_PDF_BUILTIN = 3 @ %def STRF_NONE STRF_LHAPDF6 STRF_LHAPDF5 STRF_PDF_BUILTIN @ A container to bundle all necessary PDF data. Could be moved to a more central location. <>= public :: pdf_data_t <>= type :: pdf_data_t type(lhapdf_pdf_t) :: pdf real(default) :: xmin, xmax, qmin, qmax integer :: type = STRF_NONE integer :: set = 0 contains <> end type pdf_data_t @ %def pdf_data @ <>= procedure :: init => pdf_data_init <>= subroutine pdf_data_init (pdf_data, pdf_data_in) class(pdf_data_t), intent(out) :: pdf_data type(pdf_data_t), target, intent(in) :: pdf_data_in pdf_data%xmin = pdf_data_in%xmin pdf_data%xmax = pdf_data_in%xmax pdf_data%qmin = pdf_data_in%qmin pdf_data%qmax = pdf_data_in%qmax pdf_data%set = pdf_data_in%set pdf_data%type = pdf_data_in%type if (pdf_data%type == STRF_LHAPDF6) then if (pdf_data_in%pdf%is_associated ()) then call lhapdf_copy_pointer (pdf_data_in%pdf, pdf_data%pdf) else call msg_bug ('pdf_data_init: pdf_data%pdf was not associated!') end if end if end subroutine pdf_data_init @ %def pdf_data_init @ <>= procedure :: write => pdf_data_write <>= subroutine pdf_data_write (pdf_data, unit) class(pdf_data_t), intent(in) :: pdf_data integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A,I0)") "PDF set = ", pdf_data%set write (u, "(3x,A,I0)") "PDF type = ", pdf_data%type end subroutine pdf_data_write @ %def pdf_data_write @ <>= procedure :: setup => pdf_data_setup <>= subroutine pdf_data_setup (pdf_data, caller, beam_structure, lhapdf_member, set) class(pdf_data_t), intent(inout) :: pdf_data character(len=*), intent(in) :: caller type(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: lhapdf_member, set real(default) :: xmin, xmax, q2min, q2max pdf_data%set = set if (beam_structure%contains ("lhapdf")) then if (LHAPDF6_AVAILABLE) then pdf_data%type = STRF_LHAPDF6 else if (LHAPDF5_AVAILABLE) then pdf_data%type = STRF_LHAPDF5 end if write (msg_buffer, "(A,I0)") caller & // ": interfacing LHAPDF set #", pdf_data%set call msg_message () else if (beam_structure%contains ("pdf_builtin")) then pdf_data%type = STRF_PDF_BUILTIN write (msg_buffer, "(A,I0)") caller & // ": interfacing PDF builtin set #", pdf_data%set call msg_message () end if select case (pdf_data%type) case (STRF_LHAPDF6) pdf_data%xmin = pdf_data%pdf%getxmin () pdf_data%xmax = pdf_data%pdf%getxmax () pdf_data%qmin = sqrt(pdf_data%pdf%getq2min ()) pdf_data%qmax = sqrt(pdf_data%pdf%getq2max ()) case (STRF_LHAPDF5) call GetXminM (1, lhapdf_member, xmin) call GetXmaxM (1, lhapdf_member, xmax) call GetQ2minM (1, lhapdf_member, q2min) call GetQ2maxM (1, lhapdf_member, q2max) pdf_data%xmin = xmin pdf_data%xmax = xmax pdf_data%qmin = sqrt(q2min) pdf_data%qmax = sqrt(q2max) end select end subroutine pdf_data_setup @ %def pdf_data_setup @ This could be overloaded with a version that only asks for a specific flavor as it is supported by LHAPDF6. <>= procedure :: evolve => pdf_data_evolve <>= subroutine pdf_data_evolve (pdf_data, x, q_in, f) class(pdf_data_t), intent(inout) :: pdf_data real(double), intent(in) :: x, q_in real(double), dimension(-6:6), intent(out) :: f real(double) :: q select case (pdf_data%type) case (STRF_PDF_BUILTIN) call pdf_evolve_LHAPDF (pdf_data%set, x, q_in, f) case (STRF_LHAPDF6) q = min (pdf_data%qmax, q_in) q = max (pdf_data%qmin, q) call pdf_data%pdf%evolve_pdfm (x, q, f) case (STRF_LHAPDF5) q = min (pdf_data%qmax, q_in) q = max (pdf_data%qmin, q) call evolvePDFM (pdf_data%set, x, q, f) case default call msg_fatal ("PDF function: unknown PDF method.") end select end subroutine pdf_data_evolve @ %def pdf_data_evolve @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Dispatch} @ <<[[dispatch_beams.f90]]>>= <> module dispatch_beams <> <> use diagnostics use os_interface, only: os_data_t use variables, only: var_list_t use constants, only: PI use numeric_utils, only: vanishes use physics_defs, only: PHOTON use rng_base, only: rng_factory_t use pdg_arrays use model_data, only: model_data_t use dispatch_rng, only: dispatch_rng_factory use dispatch_rng, only: update_rng_seed_in_var_list use flavors, only: flavor_t use sm_qcd, only: qcd_t, alpha_qcd_fixed_t, alpha_qcd_from_scale_t use sm_qcd, only: alpha_qcd_from_lambda_t use physics_defs, only: MZ_REF, ALPHA_QCD_MZ_REF use beam_structures use sf_base use sf_mappings use sf_isr use sf_epa use sf_ewa use sf_escan use sf_gaussian use sf_beam_events use sf_circe1 use sf_circe2 use sf_pdf_builtin use sf_lhapdf <> <> <> <> contains <> end module dispatch_beams @ %def dispatch_beams @ This data type is a container for transferring structure-function specific data from the [[dispatch_sf_data]] to the [[dispatch_sf_channels]] subroutine. <>= public :: sf_prop_t <>= type :: sf_prop_t real(default), dimension(2) :: isr_eps = 1 end type sf_prop_t @ %def sf_prop_t @ Allocate a structure-function configuration object according to the [[sf_method]] string. The [[sf_prop]] object can be used to transfer structure-function specific data up and to the [[dispatch_sf_channels]] subroutine below, so they can be used for particular mappings. The [[var_list_global]] object is used for the RNG generator seed. It is intent(inout) because the RNG generator seed may change during initialization. The [[pdg_in]] array is the array of incoming flavors, corresponding to the upstream structure function or the beam array. This will be checked for the structure function in question and replaced by the outgoing flavors. The [[pdg_prc]] array is the array of incoming flavors (beam index, component index) for the hard process. <>= public :: dispatch_sf_data <>= subroutine dispatch_sf_data (data, sf_method, i_beam, sf_prop, & var_list, var_list_global, model, & os_data, sqrts, pdg_in, pdg_prc, polarized) class(sf_data_t), allocatable, intent(inout) :: data type(string_t), intent(in) :: sf_method integer, dimension(:), intent(in) :: i_beam type(pdg_array_t), dimension(:), intent(inout) :: pdg_in type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc type(sf_prop_t), intent(inout) :: sf_prop type(var_list_t), intent(in) :: var_list type(var_list_t), intent(inout) :: var_list_global integer :: next_rng_seed class(model_data_t), target, intent(in) :: model type(os_data_t), intent(in) :: os_data real(default), intent(in) :: sqrts logical, intent(in) :: polarized type(pdg_array_t), dimension(:), allocatable :: pdg_out real(default) :: isr_alpha, isr_q_max, isr_mass integer :: isr_order logical :: isr_recoil, isr_keep_energy real(default) :: epa_alpha, epa_x_min, epa_q_min, epa_e_max, epa_mass logical :: epa_recoil, epa_keep_energy real(default) :: ewa_x_min, ewa_pt_max, ewa_mass logical :: ewa_recoil, ewa_keep_energy type(pdg_array_t), dimension(:), allocatable :: pdg_prc1 integer :: ewa_id type(string_t) :: pdf_name type(string_t) :: lhapdf_dir, lhapdf_file type(string_t), dimension(13) :: lhapdf_photon_sets integer :: lhapdf_member, lhapdf_photon_scheme logical :: hoppet_b_matching class(rng_factory_t), allocatable :: rng_factory logical :: circe1_photon1, circe1_photon2, circe1_generate, & circe1_with_radiation real(default) :: circe1_sqrts, circe1_eps integer :: circe1_version, circe1_chattiness, & circe1_revision character(6) :: circe1_accelerator logical :: circe2_polarized type(string_t) :: circe2_design, circe2_file real(default), dimension(2) :: gaussian_spread logical :: beam_events_warn_eof type(string_t) :: beam_events_dir, beam_events_file logical :: escan_normalize integer :: i lhapdf_photon_sets = [var_str ("DOG0.LHgrid"), var_str ("DOG1.LHgrid"), & var_str ("DGG.LHgrid"), var_str ("LACG.LHgrid"), & var_str ("GSG0.LHgrid"), var_str ("GSG1.LHgrid"), & var_str ("GSG960.LHgrid"), var_str ("GSG961.LHgrid"), & var_str ("GRVG0.LHgrid"), var_str ("GRVG1.LHgrid"), & var_str ("ACFGPG.LHgrid"), var_str ("WHITG.LHgrid"), & var_str ("SASG.LHgrid")] select case (char (sf_method)) case ("pdf_builtin") allocate (pdf_builtin_data_t :: data) select type (data) type is (pdf_builtin_data_t) pdf_name = & var_list%get_sval (var_str ("$pdf_builtin_set")) hoppet_b_matching = & var_list%get_lval (var_str ("?hoppet_b_matching")) call data%init ( & model, pdg_in(i_beam(1)), & name = pdf_name, & path = os_data%pdf_builtin_datapath, & hoppet_b_matching = hoppet_b_matching) end select case ("pdf_builtin_photon") call msg_fatal ("Currently, there are no photon PDFs built into WHIZARD,", & [var_str ("for the photon content inside a proton or neutron use"), & var_str ("the 'lhapdf_photon' structure function.")]) case ("lhapdf") allocate (lhapdf_data_t :: data) if (pdg_array_get (pdg_in(i_beam(1)), 1) == PHOTON) then call msg_fatal ("The 'lhapdf' structure is intended only for protons and", & [var_str ("pions, please use 'lhapdf_photon' for photon beams.")]) end if lhapdf_dir = & var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = & var_list%get_sval (var_str ("$lhapdf_file")) lhapdf_member = & var_list%get_ival (var_str ("lhapdf_member")) lhapdf_photon_scheme = & var_list%get_ival (var_str ("lhapdf_photon_scheme")) hoppet_b_matching = & var_list%get_lval (var_str ("?hoppet_b_matching")) select type (data) type is (lhapdf_data_t) call data%init & (model, pdg_in(i_beam(1)), & lhapdf_dir, lhapdf_file, lhapdf_member, & lhapdf_photon_scheme, hoppet_b_matching) end select case ("lhapdf_photon") allocate (lhapdf_data_t :: data) if (pdg_array_get_length (pdg_in(i_beam(1))) /= 1 .or. & pdg_array_get (pdg_in(i_beam(1)), 1) /= PHOTON) then call msg_fatal ("The 'lhapdf_photon' structure function is exclusively for", & [var_str ("photon PDFs, i.e. for photons as beam particles")]) end if lhapdf_dir = & var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = & var_list%get_sval (var_str ("$lhapdf_photon_file")) lhapdf_member = & var_list%get_ival (var_str ("lhapdf_member")) lhapdf_photon_scheme = & var_list%get_ival (var_str ("lhapdf_photon_scheme")) if (.not. any (lhapdf_photon_sets == lhapdf_file)) then call msg_fatal ("This PDF set is not supported or not " // & "intended for photon beams.") end if select type (data) type is (lhapdf_data_t) call data%init & (model, pdg_in(i_beam(1)), & lhapdf_dir, lhapdf_file, lhapdf_member, & lhapdf_photon_scheme) end select case ("isr") allocate (isr_data_t :: data) isr_alpha = & var_list%get_rval (var_str ("isr_alpha")) if (vanishes (isr_alpha)) then isr_alpha = (var_list%get_rval (var_str ("ee"))) & ** 2 / (4 * PI) end if isr_q_max = & var_list%get_rval (var_str ("isr_q_max")) if (vanishes (isr_q_max)) then isr_q_max = sqrts end if isr_mass = var_list%get_rval (var_str ("isr_mass")) isr_order = var_list%get_ival (var_str ("isr_order")) isr_recoil = var_list%get_lval (var_str ("?isr_recoil")) isr_keep_energy = var_list%get_lval (var_str ("?isr_keep_energy")) select type (data) type is (isr_data_t) call data%init & (model, pdg_in (i_beam(1)), isr_alpha, isr_q_max, & isr_mass, isr_order, recoil = isr_recoil, keep_energy = & isr_keep_energy) call data%check () sf_prop%isr_eps(i_beam(1)) = data%get_eps () end select case ("epa") allocate (epa_data_t :: data) epa_alpha = var_list%get_rval (var_str ("epa_alpha")) if (vanishes (epa_alpha)) then epa_alpha = (var_list%get_rval (var_str ("ee"))) & ** 2 / (4 * PI) end if epa_x_min = var_list%get_rval (var_str ("epa_x_min")) epa_q_min = var_list%get_rval (var_str ("epa_q_min")) epa_e_max = var_list%get_rval (var_str ("epa_e_max")) if (vanishes (epa_e_max)) then epa_e_max = sqrts end if epa_mass = var_list%get_rval (var_str ("epa_mass")) epa_recoil = var_list%get_lval (var_str ("?epa_recoil")) epa_keep_energy = var_list%get_lval (var_str ("?epa_keep_energy")) select type (data) type is (epa_data_t) call data%init & (model, pdg_in (i_beam(1)), epa_alpha, epa_x_min, & epa_q_min, epa_e_max, epa_mass, recoil = epa_recoil, & keep_energy = epa_keep_energy) call data%check () end select case ("ewa") allocate (ewa_data_t :: data) allocate (pdg_prc1 (size (pdg_prc, 2))) pdg_prc1 = pdg_prc(i_beam(1),:) if (any (pdg_array_get_length (pdg_prc1) /= 1) & .or. any (pdg_prc1 /= pdg_prc1(1))) then call msg_fatal & ("EWA: process incoming particle (W/Z) must be unique") end if ewa_id = abs (pdg_array_get (pdg_prc1(1), 1)) ewa_x_min = var_list%get_rval (var_str ("ewa_x_min")) ewa_pt_max = var_list%get_rval (var_str ("ewa_pt_max")) if (vanishes (ewa_pt_max)) then ewa_pt_max = sqrts end if ewa_mass = var_list%get_rval (var_str ("ewa_mass")) ewa_recoil = var_list%get_lval (& var_str ("?ewa_recoil")) ewa_keep_energy = var_list%get_lval (& var_str ("?ewa_keep_energy")) select type (data) type is (ewa_data_t) call data%init & (model, pdg_in (i_beam(1)), ewa_x_min, & ewa_pt_max, sqrts, ewa_recoil, & ewa_keep_energy, ewa_mass) call data%set_id (ewa_id) call data%check () end select case ("circe1") allocate (circe1_data_t :: data) select type (data) type is (circe1_data_t) circe1_photon1 = & var_list%get_lval (var_str ("?circe1_photon1")) circe1_photon2 = & var_list%get_lval (var_str ("?circe1_photon2")) circe1_sqrts = & var_list%get_rval (var_str ("circe1_sqrts")) circe1_eps = & var_list%get_rval (var_str ("circe1_eps")) if (circe1_sqrts <= 0) circe1_sqrts = sqrts circe1_generate = & var_list%get_lval (var_str ("?circe1_generate")) circe1_version = & var_list%get_ival (var_str ("circe1_ver")) circe1_revision = & var_list%get_ival (var_str ("circe1_rev")) circe1_accelerator = & char (var_list%get_sval (var_str ("$circe1_acc"))) circe1_chattiness = & var_list%get_ival (var_str ("circe1_chat")) circe1_with_radiation = & var_list%get_lval (var_str ("?circe1_with_radiation")) call data%init (model, pdg_in, circe1_sqrts, circe1_eps, & [circe1_photon1, circe1_photon2], & circe1_version, circe1_revision, circe1_accelerator, & circe1_chattiness, circe1_with_radiation) if (circe1_generate) then call msg_message ("CIRCE1: activating generator mode") call dispatch_rng_factory & (rng_factory, var_list_global, next_rng_seed) call update_rng_seed_in_var_list (var_list_global, next_rng_seed) call data%set_generator_mode (rng_factory) end if end select case ("circe2") allocate (circe2_data_t :: data) select type (data) type is (circe2_data_t) circe2_polarized = & var_list%get_lval (var_str ("?circe2_polarized")) circe2_file = & var_list%get_sval (var_str ("$circe2_file")) circe2_design = & var_list%get_sval (var_str ("$circe2_design")) call data%init (os_data, model, pdg_in, sqrts, & circe2_polarized, polarized, circe2_file, circe2_design) call msg_message ("CIRCE2: activating generator mode") call dispatch_rng_factory & (rng_factory, var_list_global, next_rng_seed) call update_rng_seed_in_var_list (var_list_global, next_rng_seed) call data%set_generator_mode (rng_factory) end select case ("gaussian") allocate (gaussian_data_t :: data) select type (data) type is (gaussian_data_t) gaussian_spread = & [var_list%get_rval (var_str ("gaussian_spread1")), & var_list%get_rval (var_str ("gaussian_spread2"))] call dispatch_rng_factory & (rng_factory, var_list_global, next_rng_seed) call update_rng_seed_in_var_list (var_list_global, next_rng_seed) call data%init (model, pdg_in, gaussian_spread, rng_factory) end select case ("beam_events") allocate (beam_events_data_t :: data) select type (data) type is (beam_events_data_t) beam_events_dir = os_data%whizard_beamsimpath beam_events_file = var_list%get_sval (& var_str ("$beam_events_file")) beam_events_warn_eof = var_list%get_lval (& var_str ("?beam_events_warn_eof")) call data%init (model, pdg_in, & beam_events_dir, beam_events_file, beam_events_warn_eof) end select case ("energy_scan") escan_normalize = & var_list%get_lval (var_str ("?energy_scan_normalize")) allocate (escan_data_t :: data) select type (data) type is (escan_data_t) if (escan_normalize) then call data%init (model, pdg_in) else call data%init (model, pdg_in, sqrts) end if end select case default if (associated (dispatch_sf_data_extra)) then call dispatch_sf_data_extra (data, sf_method, i_beam, & sf_prop, var_list, var_list_global, model, os_data, sqrts, pdg_in, & pdg_prc, polarized) end if if (.not. allocated (data)) then call msg_fatal ("Structure function '" & // char (sf_method) // "' not implemented") end if end select if (allocated (data)) then allocate (pdg_out (size (pdg_prc, 1))) call data%get_pdg_out (pdg_out) do i = 1, size (i_beam) pdg_in(i_beam(i)) = pdg_out(i) end do end if end subroutine dispatch_sf_data @ %def dispatch_sf_data @ This is a hook that allows us to inject further handlers for structure-function objects, in particular a test structure function. <>= public :: dispatch_sf_data_extra <>= procedure (dispatch_sf_data), pointer :: & dispatch_sf_data_extra => null () @ %def dispatch_sf_data_extra @ This is an auxiliary procedure, used by the beam-structure expansion: tell for a given structure function name, whether it corresponds to a pair spectrum ($n=2$), a single-particle structure function ($n=1$), or nothing ($n=0$). Though [[energy_scan]] can in principle also be a pair spectrum, it always has only one parameter. <>= public :: strfun_mode <>= function strfun_mode (name) result (n) type(string_t), intent(in) :: name integer :: n select case (char (name)) case ("none") n = 0 case ("sf_test_0", "sf_test_1") n = 1 case ("pdf_builtin","pdf_builtin_photon", & "lhapdf","lhapdf_photon") n = 1 case ("isr","epa","ewa") n = 1 case ("circe1", "circe2") n = 2 case ("gaussian") n = 2 case ("beam_events") n = 2 case ("energy_scan") n = 2 case default n = -1 call msg_bug ("Structure function '" // char (name) & // "' not supported yet") end select end function strfun_mode @ %def strfun_mode @ Dispatch a whole structure-function chain, given beam data and beam structure data. This could be done generically, but we should look at the specific combination of structure functions in order to select appropriate mappings. The [[beam_structure]] argument gets copied because we want to expand it to canonical form (one valid structure-function entry per record) before proceeding further. The [[pdg_prc]] argument is the array of incoming flavors. The first index is the beam index, the second one the process component index. Each element is itself a PDG array, notrivial if there is a flavor sum for the incoming state of this component. The dispatcher is divided in two parts. The first part configures the structure function data themselves. After this, we can configure the phase space for the elementary process. <>= public :: dispatch_sf_config <>= subroutine dispatch_sf_config (sf_config, sf_prop, beam_structure, & var_list, var_list_global, model, os_data, sqrts, pdg_prc) type(sf_config_t), dimension(:), allocatable, intent(out) :: sf_config type(sf_prop_t), intent(out) :: sf_prop type(beam_structure_t), intent(inout) :: beam_structure type(var_list_t), intent(in) :: var_list type(var_list_t), intent(inout) :: var_list_global class(model_data_t), target, intent(in) :: model type(os_data_t), intent(in) :: os_data real(default), intent(in) :: sqrts class(sf_data_t), allocatable :: sf_data type(beam_structure_t) :: beam_structure_tmp type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc type(string_t), dimension(:), allocatable :: prt_in type(pdg_array_t), dimension(:), allocatable :: pdg_in type(flavor_t) :: flv_in integer :: n_beam, n_record, i beam_structure_tmp = beam_structure call beam_structure_tmp%expand (strfun_mode) n_record = beam_structure_tmp%get_n_record () allocate (sf_config (n_record)) n_beam = beam_structure_tmp%get_n_beam () if (n_beam > 0) then allocate (prt_in (n_beam), pdg_in (n_beam)) prt_in = beam_structure_tmp%get_prt () do i = 1, n_beam call flv_in%init (prt_in(i), model) pdg_in(i) = flv_in%get_pdg () end do else n_beam = size (pdg_prc, 1) allocate (pdg_in (n_beam)) pdg_in = pdg_prc(:,1) end if do i = 1, n_record call dispatch_sf_data (sf_data, & beam_structure_tmp%get_name (i), & beam_structure_tmp%get_i_entry (i), & sf_prop, var_list, var_list_global, model, os_data, sqrts, & pdg_in, pdg_prc, & beam_structure_tmp%polarized ()) call sf_config(i)%init (beam_structure_tmp%get_i_entry (i), sf_data) deallocate (sf_data) end do end subroutine dispatch_sf_config @ %def dispatch_sf_config @ \subsection{QCD coupling} Allocate the [[alpha]] (running coupling) component of the [[qcd]] block with a concrete implementation, depending on the variable settings in the [[global]] record. If a fixed $\alpha_s$ is requested, we do not allocate the [[qcd%alpha]] object. In this case, the matrix element code will just take the model parameter as-is, which implies fixed $\alpha_s$. If the object is allocated, the $\alpha_s$ value is computed and updated for each matrix-element call. Also fetch the [[alphas_nf]] variable from the list and store it in the QCD record. This is not used in the $\alpha_s$ calculation, but the QCD record thus becomes a messenger for this user parameter. <>= public :: dispatch_qcd <>= subroutine dispatch_qcd (qcd, var_list, os_data) type(qcd_t), intent(inout) :: qcd type(var_list_t), intent(in) :: var_list type(os_data_t), intent(in) :: os_data logical :: fixed, from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd real(default) :: mz, alpha_val, lambda integer :: nf, order, lhapdf_member type(string_t) :: pdfset, lhapdf_dir, lhapdf_file call unpack_variables () if (allocated (qcd%alpha)) deallocate (qcd%alpha) if (from_lhapdf .and. from_pdf_builtin) then call msg_fatal (" Mixing alphas evolution", & [var_str (" from LHAPDF and builtin PDF is not permitted")]) end if select case (count ([from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd])) case (0) if (fixed) then allocate (alpha_qcd_fixed_t :: qcd%alpha) else call msg_fatal ("QCD alpha: no calculation mode set") end if case (2:) call msg_fatal ("QCD alpha: calculation mode is ambiguous") case (1) if (fixed) then call msg_fatal ("QCD alpha: use '?alphas_is_fixed = false' for " // & "running alphas") else if (from_mz) then allocate (alpha_qcd_from_scale_t :: qcd%alpha) else if (from_pdf_builtin) then allocate (alpha_qcd_pdf_builtin_t :: qcd%alpha) else if (from_lhapdf) then allocate (alpha_qcd_lhapdf_t :: qcd%alpha) else if (from_lambda_qcd) then allocate (alpha_qcd_from_lambda_t :: qcd%alpha) end if call msg_message ("QCD alpha: using a running strong coupling") end select call init_alpha () qcd%n_f = var_list%get_ival (var_str ("alphas_nf")) contains <> end subroutine dispatch_qcd @ %def dispatch_qcd @ <>= subroutine unpack_variables () fixed = var_list%get_lval (var_str ("?alphas_is_fixed")) from_mz = var_list%get_lval (var_str ("?alphas_from_mz")) from_pdf_builtin = & var_list%get_lval (var_str ("?alphas_from_pdf_builtin")) from_lhapdf = & var_list%get_lval (var_str ("?alphas_from_lhapdf")) from_lambda_qcd = & var_list%get_lval (var_str ("?alphas_from_lambda_qcd")) pdfset = var_list%get_sval (var_str ("$pdf_builtin_set")) lambda = var_list%get_rval (var_str ("lambda_qcd")) nf = var_list%get_ival (var_str ("alphas_nf")) order = var_list%get_ival (var_str ("alphas_order")) lhapdf_dir = var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = var_list%get_sval (var_str ("$lhapdf_file")) lhapdf_member = var_list%get_ival (var_str ("lhapdf_member")) if (var_list%contains (var_str ("mZ"))) then mz = var_list%get_rval (var_str ("mZ")) else mz = MZ_REF end if if (var_list%contains (var_str ("alphas"))) then alpha_val = var_list%get_rval (var_str ("alphas")) else alpha_val = ALPHA_QCD_MZ_REF end if end subroutine unpack_variables @ <>= subroutine init_alpha () select type (alpha => qcd%alpha) type is (alpha_qcd_fixed_t) alpha%val = alpha_val type is (alpha_qcd_from_scale_t) alpha%mu_ref = mz alpha%ref = alpha_val alpha%order = order alpha%nf = nf type is (alpha_qcd_from_lambda_t) alpha%lambda = lambda alpha%order = order alpha%nf = nf type is (alpha_qcd_pdf_builtin_t) call alpha%init (pdfset, & os_data%pdf_builtin_datapath) type is (alpha_qcd_lhapdf_t) call alpha%init (lhapdf_file, lhapdf_member, lhapdf_dir) end select end subroutine init_alpha @ Index: trunk/src/matrix_elements/matrix_elements.nw =================================================================== --- trunk/src/matrix_elements/matrix_elements.nw (revision 8234) +++ trunk/src/matrix_elements/matrix_elements.nw (revision 8235) @@ -1,10204 +1,10203 @@ % -*- 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 io_units, only: given_output_unit, free_unit use format_utils, only: write_integer_array use md5, only: md5sum use pdg_arrays <> <> <> contains <> end module process_constants @ %def process_constants @ 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 contains <> end type process_constants_t @ %def process_constants_t @ <>= procedure :: get_n_tot => process_constants_get_n_tot <>= elemental 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 io_units use system_defs, only: TAB use string_utils, only: lower_case use diagnostics use os_interface <> <> <> <> contains <> end module prclib_interfaces @ %def prclib_interfaces @ \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. <>= 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. <>= 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. <>= 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 <>= 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 <>= 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 <>= 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. <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 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 <>= 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. Note: [[intent(out)]] for the [[driver]] argument segfaults with gfortran 4.7. <>= public :: dispatch_prclib_driver <>= subroutine dispatch_prclib_driver & (driver, basename, modellibs_ldflags) class(prclib_driver_t), intent(inout), 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 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 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 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 <>= 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 <>= 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 <>= 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 <>= 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 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 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 <>= 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 <>= 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 <>= 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 <>= 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 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 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 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 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 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 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 io_units use diagnostics use process_constants use prclib_interfaces <> <> <> <> contains <> end module prc_core_def @ %def prc_core_def @ \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 <>= 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 <>= 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 <>= 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 io_units use diagnostics use md5 use physics_defs use os_interface use model_data use particle_specifiers use process_constants use prclib_interfaces use prc_core_def <> <> <> <> contains <> end module process_libraries @ %def process_libraries @ \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 <>= 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 <>= 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 <>= 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 <>= 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), the 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 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 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 <>= 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 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 <>= 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 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 <>= 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 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 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 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 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 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 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 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 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) n = n - 1 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 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 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 <>= 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 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 :: requires_resonances = .false. contains <> end type process_def_t @ %def process_def_t @ Write the process definition including components: <>= procedure :: write => process_def_write <>= 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 <>= 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 <>= 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 <>= subroutine process_def_init (def, id, & model, model_name, n_in, n_components, num_id, & nlo_process, 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 :: 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 (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 <>= 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 <>= 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 - ! TODO: (bcn 2016-09-16) better output for subtraction 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 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 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 @ Number of incoming particles, common to all components. <>= procedure :: get_n_in => process_def_get_n_in <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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) 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 io_units use format_utils, only: write_separator use process_libraries <> <> <> contains <> end module prclib_stacks @ %def prclib_stacks @ \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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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 process_constants use prclib_interfaces use prc_core_def use particle_specifiers, only: new_prt_spec use process_libraries <> <> <> contains <> end module prc_test @ %def prc_test @ \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 <>= 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 <>= 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 <>= 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 <>= 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 <>= 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. <>= 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 <>= 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 <>= 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 <>= 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 <>= 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. <>= 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 Index: trunk/src/mci/mci.nw =================================================================== --- trunk/src/mci/mci.nw (revision 8234) +++ trunk/src/mci/mci.nw (revision 8235) @@ -1,14057 +1,14057 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: integration and event generation %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Multi-Channel Integration} \includemodulegraph{mci} The abstract representation of multi-channel Monte Carlo algorithms for integration and event generation. \begin{description} \item[Module [[mci_base]]:] The abstract types and their methods. It provides a test integrator that is referenced in later unit tests. \item[iterations] Container for defining integration call and pass settings. \item[integration\_results] This module handles results from integrating processes. It records passes and iterations, calculates statistical averages, and provides the user output of integration results. \end{description} These are the implementations: \begin{description} \item[Module [[mci_midpoint]]:] A simple integrator that uses the midpoint rule to sample the integrand uniformly over the unit hypercube. There is only one integration channel, so this can be matched only to single-channel phase space. \item[Module [[mci_vamp]]:] Interface for the VAMP package. \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \clearpage \section{Generic Integrator} This module provides a multi-channel integrator (MCI) base type, a corresponding configuration type, and methods for integration and event generation. <<[[mci_base.f90]]>>= <> module mci_base use kinds use io_units use format_utils, only: pac_fmt use format_defs, only: FMT_14, FMT_17 use diagnostics use cputime use phs_base use rng_base <> <> <> <> contains <> end module mci_base @ %def mci_base @ \subsection{MCI: integrator} The MCI object contains the methods for integration and event generation. For the actual work and data storage, it spawns an MCI instance object. The base object contains the number of integration dimensions and the number of channels as configuration data. Further configuration data are stored in the concrete extensions. The MCI sum contains all relevant information about the integrand. It can be used for comparing the current configuration against a previous one. If they match, we can skip an actual integration. (Implemented only for the VAMP version.) There is a random-number generator (its state with associated methods) available as [[rng]]. It may or may not be used for integration. It will be used for event generation. <>= public :: mci_t <>= type, abstract :: mci_t integer :: n_dim = 0 integer :: n_channel = 0 integer :: n_chain = 0 integer, dimension(:), allocatable :: chain real(default), dimension(:), allocatable :: chain_weights character(32) :: md5sum = "" logical :: integral_known = .false. logical :: error_known = .false. logical :: efficiency_known = .false. real(default) :: integral = 0 real(default) :: error = 0 real(default) :: efficiency = 0 logical :: use_timer = .false. type(timer_t) :: timer class(rng_t), allocatable :: rng contains <> end type mci_t @ %def mci_t @ Finalizer: the random-number generator may need one. <>= procedure :: base_final => mci_final procedure (mci_final), deferred :: final <>= subroutine mci_final (object) class(mci_t), intent(inout) :: object if (allocated (object%rng)) call object%rng%final () end subroutine mci_final @ %def mci_final @ Output: basic and extended output. <>= procedure :: base_write => mci_write procedure (mci_write), deferred :: write <>= subroutine mci_write (object, unit, pacify, md5sum_version) class(mci_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version logical :: md5sum_ver integer :: u, i, j character(len=7) :: fmt call pac_fmt (fmt, FMT_17, FMT_14, pacify) u = given_output_unit (unit) md5sum_ver = .false. if (present (md5sum_version)) md5sum_ver = md5sum_version if (object%use_timer .and. .not. md5sum_ver) then write (u, "(2x)", advance="no") call object%timer%write (u) end if if (object%integral_known) then write (u, "(3x,A," // fmt // ")") & "Integral = ", object%integral end if if (object%error_known) then write (u, "(3x,A," // fmt // ")") & "Error = ", object%error end if if (object%efficiency_known) then write (u, "(3x,A," // fmt // ")") & "Efficiency = ", object%efficiency end if write (u, "(3x,A,I0)") "Number of channels = ", object%n_channel write (u, "(3x,A,I0)") "Number of dimensions = ", object%n_dim if (object%n_chain > 0) then write (u, "(3x,A,I0)") "Number of chains = ", object%n_chain write (u, "(3x,A)") "Chains:" do i = 1, object%n_chain write (u, "(5x,I0,':')", advance = "no") i do j = 1, object%n_channel if (object%chain(j) == i) & write (u, "(1x,I0)", advance = "no") j end do write (u, "(A)") end do end if end subroutine mci_write @ %def mci_write @ Print an informative message when starting integration. <>= procedure (mci_startup_message), deferred :: startup_message procedure :: base_startup_message => mci_startup_message <>= subroutine mci_startup_message (mci, unit, n_calls) class(mci_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls if (mci%n_chain > 0) then write (msg_buffer, "(A,3(1x,I0,1x,A))") & "Integrator:", mci%n_chain, "chains,", & mci%n_channel, "channels,", & mci%n_dim, "dimensions" else write (msg_buffer, "(A,3(1x,I0,1x,A))") & "Integrator:", & mci%n_channel, "channels,", & mci%n_dim, "dimensions" end if call msg_message (unit = unit) end subroutine mci_startup_message @ %def mci_startup_message @ Dump type-specific info to a logfile. <>= procedure(mci_write_log_entry), deferred :: write_log_entry <>= abstract interface subroutine mci_write_log_entry (mci, u) import class(mci_t), intent(in) :: mci integer, intent(in) :: u end subroutine mci_write_log_entry end interface @ %def mci_write_log_entry In order to avoid dependencies on definite MCI implementations, we introduce a MD5 sum calculator. <>= procedure(mci_compute_md5sum), deferred :: compute_md5sum <>= abstract interface subroutine mci_compute_md5sum (mci, pacify) import class(mci_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_compute_md5sum end interface @ %def mci_compute_md5sum@ @ Record the index of the MCI object within a process. For multi-component processes with more than one integrator, the integrator should know about its own index, so file names can be unique, etc. The default implementation does nothing, however. <>= procedure :: record_index => mci_record_index <>= subroutine mci_record_index (mci, i_mci) class(mci_t), intent(inout) :: mci integer, intent(in) :: i_mci end subroutine mci_record_index @ %def mci_record_index @ There is no Initializer for the abstract type, but a generic setter for the number of channels and dimensions. We make two aliases available, to be able to override it. <>= procedure :: set_dimensions => mci_set_dimensions procedure :: base_set_dimensions => mci_set_dimensions <>= subroutine mci_set_dimensions (mci, n_dim, n_channel) class(mci_t), intent(inout) :: mci integer, intent(in) :: n_dim integer, intent(in) :: n_channel mci%n_dim = n_dim mci%n_channel = n_channel end subroutine mci_set_dimensions @ %def mci_set_dimensions @ Declare particular dimensions as flat. This information can be used to simplify integration. When generating events, the flat dimensions should be sampled with uniform and uncorrelated distribution. It depends on the integrator what to do with that information. <>= procedure (mci_declare_flat_dimensions), deferred :: declare_flat_dimensions <>= abstract interface subroutine mci_declare_flat_dimensions (mci, dim_flat) import class(mci_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_declare_flat_dimensions end interface @ %def mci_declare_flat_dimensions @ Declare particular channels as equivalent, possibly allowing for permutations or reflections of dimensions. We use the information stored in the [[phs_channel_t]] object array that the phase-space module provides. (We do not test this here, deferring the unit test to the [[mci_vamp]] implementation where we actually use this feature.) <>= procedure (mci_declare_equivalences), deferred :: declare_equivalences <>= abstract interface subroutine mci_declare_equivalences (mci, channel, dim_offset) import class(mci_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_declare_equivalences end interface @ %def mci_declare_equivalences @ Declare particular channels as chained together. The implementation may use this array for keeping their weights equal to each other, etc. The chain array is an array sized by the number of channels. For each channel, there is an integer entry that indicates the correponding chains. The total number of chains is the maximum value of this entry. <>= procedure :: declare_chains => mci_declare_chains <>= subroutine mci_declare_chains (mci, chain) class(mci_t), intent(inout) :: mci integer, dimension(:), intent(in) :: chain allocate (mci%chain (size (chain))) mci%n_chain = maxval (chain) allocate (mci%chain_weights (mci%n_chain), source = 0._default) mci%chain = chain end subroutine mci_declare_chains @ %def mci_declare_chains @ Collect channel weights according to chains and store them in the [[chain_weights]] for output. We sum up the weights for all channels that share the same [[chain]] index and store the results in the [[chain_weights]] array. <>= procedure :: collect_chain_weights => mci_collect_chain_weights <>= subroutine mci_collect_chain_weights (mci, weight) class(mci_t), intent(inout) :: mci real(default), dimension(:), intent(in) :: weight integer :: i, c if (allocated (mci%chain)) then mci%chain_weights = 0 do i = 1, size (mci%chain) c = mci%chain(i) mci%chain_weights(c) = mci%chain_weights(c) + weight(i) end do end if end subroutine mci_collect_chain_weights @ %def mci_collect_chain_weights @ Check if there are chains. <>= procedure :: has_chains => mci_has_chains <>= function mci_has_chains (mci) result (flag) class(mci_t), intent(in) :: mci logical :: flag flag = allocated (mci%chain) end function mci_has_chains @ %def mci_has_chains @ Output of the chain weights, kept separate from the main [[write]] method. [The formatting will work as long as the number of chains is less than $10^{10}$\ldots] <>= procedure :: write_chain_weights => mci_write_chain_weights <>= subroutine mci_write_chain_weights (mci, unit) class(mci_t), intent(in) :: mci integer, intent(in), optional :: unit integer :: u, i, n, n_digits character(4) :: ifmt u = given_output_unit (unit) if (allocated (mci%chain_weights)) then write (u, "(1x,A)") "Weights of channel chains (groves):" n_digits = 0 n = size (mci%chain_weights) do while (n > 0) n = n / 10 n_digits = n_digits + 1 end do write (ifmt, "(A1,I1)") "I", n_digits do i = 1, size (mci%chain_weights) write (u, "(3x," // ifmt // ",F13.10)") i, mci%chain_weights(i) end do end if end subroutine mci_write_chain_weights @ %def mci_write_chain_weights @ Set the MD5 sum, independent of initialization. <>= procedure :: set_md5sum => mci_set_md5sum <>= subroutine mci_set_md5sum (mci, md5sum) class(mci_t), intent(inout) :: mci character(32), intent(in) :: md5sum mci%md5sum = md5sum end subroutine mci_set_md5sum @ %def mci_set_md5sum @ Initialize a new integration pass. This is not necessarily meaningful, so we provide an empty base method. The [[mci_vamp]] implementation overrides this. <>= procedure :: add_pass => mci_add_pass <>= subroutine mci_add_pass (mci, adapt_grids, adapt_weights, final_pass) class(mci_t), intent(inout) :: mci logical, intent(in), optional :: adapt_grids logical, intent(in), optional :: adapt_weights logical, intent(in), optional :: final_pass end subroutine mci_add_pass @ %def mci_add_pass @ Allocate an instance with matching type. This must be deferred. <>= procedure (mci_allocate_instance), deferred :: allocate_instance <>= abstract interface subroutine mci_allocate_instance (mci, mci_instance) import class(mci_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance end subroutine mci_allocate_instance end interface @ %def mci_allocate_instance @ Import a random-number generator. We transfer the allocation of an existing generator state into the object. The generator state may already be initialized, or we can reset it by its [[init]] method. <>= procedure :: import_rng => mci_import_rng <>= subroutine mci_import_rng (mci, rng) class(mci_t), intent(inout) :: mci class(rng_t), intent(inout), allocatable :: rng call move_alloc (rng, mci%rng) end subroutine mci_import_rng @ %def mci_import_rng @ Activate or deactivate the timer. <>= procedure :: set_timer => mci_set_timer <>= subroutine mci_set_timer (mci, active) class(mci_t), intent(inout) :: mci logical, intent(in) :: active mci%use_timer = active end subroutine mci_set_timer @ %def mci_set_timer @ Start and stop signal for the timer, if active. The elapsed time can then be retrieved from the MCI record. <>= procedure :: start_timer => mci_start_timer procedure :: stop_timer => mci_stop_timer <>= subroutine mci_start_timer (mci) class(mci_t), intent(inout) :: mci if (mci%use_timer) call mci%timer%start () end subroutine mci_start_timer subroutine mci_stop_timer (mci) class(mci_t), intent(inout) :: mci if (mci%use_timer) call mci%timer%stop () end subroutine mci_stop_timer @ %def mci_start_timer @ %def mci_stop_timer @ Sampler test. Evaluate the sampler a given number of times. Results are discarded, so we don't need the MCI instance which would record them. The evaluation channel is iterated, and the [[x]] parameters are randomly chosen. <>= procedure :: sampler_test => mci_sampler_test <>= subroutine mci_sampler_test (mci, sampler, n_calls) class(mci_t), intent(inout) :: mci class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_calls real(default), dimension(:), allocatable :: x_in, f real(default), dimension(:,:), allocatable :: x_out real(default) :: val integer :: i, c allocate (x_in (mci%n_dim)) allocate (f (mci%n_channel)) allocate (x_out (mci%n_dim, mci%n_channel)) do i = 1, n_calls c = mod (i, mci%n_channel) + 1 call mci%rng%generate_array (x_in) call sampler%evaluate (c, x_in, val, x_out, f) end do end subroutine mci_sampler_test @ %def mci_sampler_test @ Integrate: this depends on the implementation. We foresee a pacify flag to take care of small numerical noise on different platforms. <>= procedure (mci_integrate), deferred :: integrate <>= abstract interface subroutine mci_integrate (mci, instance, sampler, & n_it, n_calls, results, pacify) import class(mci_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: pacify class(mci_results_t), intent(inout), optional :: results end subroutine mci_integrate end interface @ %def mci_integrate @ Event generation. Depending on the implementation, event generation may or may not require a previous integration pass. Instead of a black-box [[simulate]] method, we require an initializer, a finalizer, and procedures for generating a single event. This allows us to interface simulation event by event from the outside, and it facilitates the further processing of an event after successful generation. For integration, this is not necessary. The initializer has [[intent(inout)]] for the [[mci]] passed object. The reason is that the initializer can read integration results and grids from file, where the results can modify the [[mci]] record. <>= procedure (mci_prepare_simulation), deferred :: prepare_simulation @ %def mci_final_simulation <>= abstract interface subroutine mci_prepare_simulation (mci) import class(mci_t), intent(inout) :: mci end subroutine mci_prepare_simulation end interface @ %def mci_prepare_simulation @ The generated event will reside in in the [[instance]] object (overall results and weight) and in the [[sampler]] object (detailed data). In the real application, we can subsequently call methods of the [[sampler]] in order to further process the generated event. The [[target]] attributes are required by the VAMP implementation, which uses pointers to refer to the instance and sampler objects from within the integration function. <>= procedure (mci_generate), deferred :: generate_weighted_event procedure (mci_generate), deferred :: generate_unweighted_event @ %def mci_generate_weighted_event @ %def mci_generate_unweighted_event <>= abstract interface subroutine mci_generate (mci, instance, sampler) import class(mci_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler end subroutine mci_generate end interface @ %def mci_generate @ This is analogous, but we rebuild the event from the information stored in [[state]] instead of generating it. Note: currently unused outside of tests, might be deleted later. <>= procedure (mci_rebuild), deferred :: rebuild_event <>= abstract interface subroutine mci_rebuild (mci, instance, sampler, state) import class(mci_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state end subroutine mci_rebuild end interface @ %def mci_rebuild @ Pacify: reduce numerical noise. The base implementation does nothing. <>= procedure :: pacify => mci_pacify <>= subroutine mci_pacify (object, efficiency_reset, error_reset) class(mci_t), intent(inout) :: object logical, intent(in), optional :: efficiency_reset, error_reset end subroutine mci_pacify @ %def mci_pacify @ Return the value of the integral, error, efficiency, and time per call. <>= procedure :: get_integral => mci_get_integral procedure :: get_error => mci_get_error procedure :: get_efficiency => mci_get_efficiency procedure :: get_time => mci_get_time <>= function mci_get_integral (mci) result (integral) class(mci_t), intent(in) :: mci real(default) :: integral if (mci%integral_known) then integral = mci%integral else call msg_bug ("The integral is unknown. This is presumably a" // & "WHIZARD bug.") end if end function mci_get_integral function mci_get_error (mci) result (error) class(mci_t), intent(in) :: mci real(default) :: error if (mci%error_known) then error = mci%error else error = 0 end if end function mci_get_error function mci_get_efficiency (mci) result (efficiency) class(mci_t), intent(in) :: mci real(default) :: efficiency if (mci%efficiency_known) then efficiency = mci%efficiency else efficiency = 0 end if end function mci_get_efficiency function mci_get_time (mci) result (time) class(mci_t), intent(in) :: mci real(default) :: time if (mci%use_timer) then time = mci%timer else time = 0 end if end function mci_get_time @ %def mci_get_integral @ %def mci_get_error @ %def mci_get_efficiency @ %def mci_get_time @ Return the MD5 sum of the configuration. This may be overridden in an extension, to return a different MD5 sum. <>= procedure :: get_md5sum => mci_get_md5sum <>= pure function mci_get_md5sum (mci) result (md5sum) class(mci_t), intent(in) :: mci character(32) :: md5sum md5sum = mci%md5sum end function mci_get_md5sum @ %def mci_get_md5sum @ \subsection{MCI instance} The base type contains an array of channel weights. The value [[mci_weight]] is the combined MCI weight that corresponds to a particular sampling point. For convenience, we also store the [[x]] and Jacobian values for this sampling point. <>= public :: mci_instance_t <>= type, abstract :: mci_instance_t logical :: valid = .false. real(default), dimension(:), allocatable :: w real(default), dimension(:), allocatable :: f real(default), dimension(:,:), allocatable :: x integer :: selected_channel = 0 real(default) :: mci_weight = 0 real(default) :: integrand = 0 logical :: negative_weights = .false. integer :: n_dropped = 0 contains <> end type mci_instance_t @ %def mci_instance_t @ Output: deferred <>= procedure (mci_instance_write), deferred :: write <>= abstract interface subroutine mci_instance_write (object, unit, pacify) import class(mci_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify end subroutine mci_instance_write end interface @ %def mci_instance_write @ A finalizer, just in case. <>= procedure (mci_instance_final), deferred :: final <>= abstract interface subroutine mci_instance_final (object) import class(mci_instance_t), intent(inout) :: object end subroutine mci_instance_final end interface @ %def mci_instance_final @ Init: basic initializer for the arrays, otherwise deferred. Assigning the [[mci]] object is also deferred, because it depends on the concrete type. The weights are initialized with an uniform normalized value. <>= procedure (mci_instance_base_init), deferred :: init procedure :: base_init => mci_instance_base_init <>= subroutine mci_instance_base_init (mci_instance, mci) class(mci_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci allocate (mci_instance%w (mci%n_channel)) allocate (mci_instance%f (mci%n_channel)) allocate (mci_instance%x (mci%n_dim, mci%n_channel)) if (mci%n_channel > 0) then call mci_instance%set_channel_weights & (spread (1._default, dim=1, ncopies=mci%n_channel)) end if mci_instance%f = 0 mci_instance%x = 0 end subroutine mci_instance_base_init @ %def mci_instance_base_init @ Explicitly set the array of channel weights. <>= procedure :: set_channel_weights => mci_instance_set_channel_weights <>= subroutine mci_instance_set_channel_weights (mci_instance, weights, sum_non_zero) class(mci_instance_t), intent(inout) :: mci_instance real(default), dimension(:), intent(in) :: weights logical, intent(out), optional :: sum_non_zero real(default) :: wsum wsum = sum (weights) if (wsum /= 0) then mci_instance%w = weights / wsum if (present (sum_non_zero)) sum_non_zero = .true. else if (present (sum_non_zero)) sum_non_zero = .false. call msg_warning ("MC sampler initialization:& & sum of channel weights is zero") end if end subroutine mci_instance_set_channel_weights @ %def mci_instance_set_channel_weights @ Compute the overall weight factor for a configuration of $x$ values and Jacobians $f$. The $x$ values come in [[n_channel]] rows with [[n_dim]] entries each. The $f$ factors constitute an array with [[n_channel]] entries. We assume that the $x$ and $f$ arrays are already stored inside the MC instance. The result is also stored there. <>= procedure (mci_instance_compute_weight), deferred :: compute_weight <>= abstract interface subroutine mci_instance_compute_weight (mci, c) import class(mci_instance_t), intent(inout) :: mci integer, intent(in) :: c end subroutine mci_instance_compute_weight end interface @ %def mci_instance_compute_weight @ Record the integrand as returned by the sampler. Depending on the implementation, this may merely copy the value, or do more complicated things. We may need the MCI weight for the actual computations, so this should be called after the previous routine. <>= procedure (mci_instance_record_integrand), deferred :: record_integrand <>= abstract interface subroutine mci_instance_record_integrand (mci, integrand) import class(mci_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand end subroutine mci_instance_record_integrand end interface @ %def mci_instance_record_integrand @ Sample a point directly: evaluate the sampler, then compute the weight and the weighted integrand. Finally, record the integrand within the MCI instance. If a signal (interrupt) was raised recently, we abort the calculation before entering the sampler. Thus, a previous calculation will have completed and any data are already recorded, but any new point can be discarded. If the [[abort]] flag is present, we may delay the interrupt, so we can do some cleanup. <>= procedure :: evaluate => mci_instance_evaluate <>= subroutine mci_instance_evaluate (mci, sampler, c, x) class(mci_instance_t), intent(inout) :: mci class(mci_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x real(default) :: val call sampler%evaluate (c, x, val, mci%x, mci%f) mci%valid = sampler%is_valid () if (mci%valid) then call mci%compute_weight (c) call mci%record_integrand (val) end if end subroutine mci_instance_evaluate @ %def mci_instance_evaluate @ Initiate and terminate simulation. In contrast to integration, we implement these as methods of the process instance, since the [[mci]] configuration object is unchanged. The safety factor reduces the acceptance probability for unweighted events. The implementation of this feature depends on the concrete type. <>= procedure (mci_instance_init_simulation), deferred :: init_simulation procedure (mci_instance_final_simulation), deferred :: final_simulation <>= abstract interface subroutine mci_instance_init_simulation (instance, safety_factor) import class(mci_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor end subroutine mci_instance_init_simulation end interface abstract interface subroutine mci_instance_final_simulation (instance) import class(mci_instance_t), intent(inout) :: instance end subroutine mci_instance_final_simulation end interface @ %def mci_instance_init_simulation mci_instance_final_simulation @ Assuming that the sampler is in a completely defined state, just extract the data that [[evaluate]] would compute. Also record the integrand. <>= procedure :: fetch => mci_instance_fetch <>= subroutine mci_instance_fetch (mci, sampler, c) class(mci_instance_t), intent(inout) :: mci class(mci_sampler_t), intent(in) :: sampler integer, intent(in) :: c real(default) :: val mci%valid = sampler%is_valid () if (mci%valid) then call sampler%fetch (val, mci%x, mci%f) call mci%compute_weight (c) call mci%record_integrand (val) end if end subroutine mci_instance_fetch @ %def mci_instance_fetch @ The value, i.e., the weighted integrand, is the integrand (which should be taken as-is from the sampler) multiplied by the MCI weight. <>= procedure :: get_value => mci_instance_get_value <>= function mci_instance_get_value (mci) result (value) class(mci_instance_t), intent(in) :: mci real(default) :: value if (mci%valid) then value = mci%integrand * mci%mci_weight else value = 0 end if end function mci_instance_get_value @ %def mci_instance_get_value @ This is an extra routine. By default, the event weight is equal to the value returned by the previous routine. However, if we select a channel for event generation not just based on the channel weights, the event weight has to account for this bias, so the event weight that applies to event generation is different. In that case, we should override the default routine. <>= procedure :: get_event_weight => mci_instance_get_value @ %def mci_instance_get_event_weight @ Excess weight can occur during unweighted event generation, if the assumed maximum value of the integrand is too small. This excess should be normalized in the same way as the event weight above (which for unweighted events becomes unity). <>= procedure (mci_instance_get_event_excess), deferred :: get_event_excess <>= abstract interface function mci_instance_get_event_excess (mci) result (excess) import class(mci_instance_t), intent(in) :: mci real(default) :: excess end function mci_instance_get_event_excess end interface @ %def mci_instance_get_event_excess @ Dropped events (i.e., events with zero weight that are not retained) are counted within the [[mci_instance]] object. <>= procedure :: get_n_event_dropped => mci_instance_get_n_event_dropped procedure :: reset_n_event_dropped => mci_instance_reset_n_event_dropped procedure :: record_event_dropped => mci_instance_record_event_dropped <>= function mci_instance_get_n_event_dropped (mci) result (n_dropped) class(mci_instance_t), intent(in) :: mci integer :: n_dropped n_dropped = mci%n_dropped end function mci_instance_get_n_event_dropped subroutine mci_instance_reset_n_event_dropped (mci) class(mci_instance_t), intent(inout) :: mci mci%n_dropped = 0 end subroutine mci_instance_reset_n_event_dropped subroutine mci_instance_record_event_dropped (mci) class(mci_instance_t), intent(inout) :: mci mci%n_dropped = mci%n_dropped + 1 end subroutine mci_instance_record_event_dropped @ %def mci_instance_get_n_event_dropped @ %def mci_instance_reset_n_event_dropped @ %def mci_instance_record_event_dropped @ \subsection{MCI state} This object can hold the relevant information that allows us to reconstruct the MCI instance without re-evaluating the sampler completely. We store the [[x_in]] MC input parameter set, which coincides with the section of the complete [[x]] array that belongs to a particular channel. We also store the MC function value. When we want to reconstruct the state, we can use the input array to recover the complete [[x]] and [[f]] arrays (i.e., the kinematics), but do not need to recompute the MC function value (the dynamics). The [[mci_state_t]] may be extended, to allow storing/recalling more information. In that case, we would override the type-bound procedures. However, the base type is also a concrete type and self-contained. <>= public :: mci_state_t <>= type :: mci_state_t integer :: selected_channel = 0 real(default), dimension(:), allocatable :: x_in real(default) :: val contains <> end type mci_state_t @ %def mci_state_t @ Output: <>= procedure :: write => mci_state_write <>= subroutine mci_state_write (object, unit) class(mci_state_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "MCI state:" write (u, "(3x,A,I0)") "Channel = ", object%selected_channel write (u, "(3x,A,999(1x,F12.10))") "x (in) =", object%x_in write (u, "(3x,A,ES19.12)") "Integrand = ", object%val end subroutine mci_state_write @ %def mci_state_write @ To store the object, we take the relevant section of the [[x]] array. The channel used for storing data is taken from the [[instance]] object, but it could be arbitrary in principle. <>= procedure :: store => mci_instance_store <>= subroutine mci_instance_store (mci, state) class(mci_instance_t), intent(in) :: mci class(mci_state_t), intent(out) :: state state%selected_channel = mci%selected_channel allocate (state%x_in (size (mci%x, 1))) state%x_in = mci%x(:,mci%selected_channel) state%val = mci%integrand end subroutine mci_instance_store @ %def mci_instance_store @ Recalling the state, we must consult the sampler in order to fully reconstruct the [[x]] and [[f]] arrays. The integrand value is known, and we also give it to the sampler, bypassing evaluation. The final steps are equivalent to the [[evaluate]] method above. <>= procedure :: recall => mci_instance_recall <>= subroutine mci_instance_recall (mci, sampler, state) class(mci_instance_t), intent(inout) :: mci class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state if (size (state%x_in) == size (mci%x, 1) & .and. state%selected_channel <= size (mci%x, 2)) then call sampler%rebuild (state%selected_channel, & state%x_in, state%val, mci%x, mci%f) call mci%compute_weight (state%selected_channel) call mci%record_integrand (state%val) else call msg_fatal ("Recalling event: mismatch in channel or dimension") end if end subroutine mci_instance_recall @ %def mci_instance_recall @ \subsection{MCI sampler} A sampler is an object that implements a multi-channel parameterization of the unit hypercube. Specifically, it is able to compute, given a channel and a set of $x$ MC parameter values, a the complete set of $x$ values and associated Jacobian factors $f$ for all channels. Furthermore, the sampler should return a single real value, the integrand, for the given point in the hypercube. It must implement a method [[evaluate]] for performing the above computations. <>= public :: mci_sampler_t <>= type, abstract :: mci_sampler_t contains <> end type mci_sampler_t @ %def mci_sampler_t @ Output, deferred to the implementation. <>= procedure (mci_sampler_write), deferred :: write <>= abstract interface subroutine mci_sampler_write (object, unit, testflag) import class(mci_sampler_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine mci_sampler_write end interface @ %def mci_sampler_write @ The evaluation routine. Input is the channel index [[c]] and the one-dimensional parameter array [[x_in]]. Output are the integrand value [[val]], the two-dimensional parameter array [[x]] and the Jacobian array [[f]]. <>= procedure (mci_sampler_evaluate), deferred :: evaluate <>= abstract interface subroutine mci_sampler_evaluate (sampler, c, x_in, val, x, f) import class(mci_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f end subroutine mci_sampler_evaluate end interface @ %def mci_sampler_evaluate @ Query the validity of the sampling point. Can be called after [[evaluate]]. <>= procedure (mci_sampler_is_valid), deferred :: is_valid <>= abstract interface function mci_sampler_is_valid (sampler) result (valid) import class(mci_sampler_t), intent(in) :: sampler logical :: valid end function mci_sampler_is_valid end interface @ %def mci_sampler_is_valid @ The shortcut. Again, the channel index [[c]] and the parameter array [[x_in]] are input. However, we also provide the integrand value [[val]], and we just require that the complete parameter array [[x]] and Jacobian array [[f]] are recovered. <>= procedure (mci_sampler_rebuild), deferred :: rebuild <>= abstract interface subroutine mci_sampler_rebuild (sampler, c, x_in, val, x, f) import class(mci_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f end subroutine mci_sampler_rebuild end interface @ %def mci_sampler_rebuild @ This routine should extract the important data from a sampler that has been filled by other means. We fetch the integrand value [[val]], the two-dimensional parameter array [[x]] and the Jacobian array [[f]]. <>= procedure (mci_sampler_fetch), deferred :: fetch <>= abstract interface subroutine mci_sampler_fetch (sampler, val, x, f) import class(mci_sampler_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f end subroutine mci_sampler_fetch end interface @ %def mci_sampler_fetch @ \subsection{Results record} This is an abstract type which allows us to implement callback: each integration results can optionally be recorded to an instance of this object. The actual object may store a new result, average results, etc. It may also display a result on-line or otherwise, whenever the [[record]] method is called. <>= public :: mci_results_t <>= type, abstract :: mci_results_t contains <> end type mci_results_t @ %def mci_results_t @ The output routine is deferred. We provide an extra [[verbose]] flag, which could serve any purpose. <>= procedure (mci_results_write), deferred :: write procedure (mci_results_write_verbose), deferred :: write_verbose <>= abstract interface subroutine mci_results_write (object, unit, suppress) import class(mci_results_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: suppress end subroutine mci_results_write subroutine mci_results_write_verbose (object, unit) import class(mci_results_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine mci_results_write_verbose end interface @ %def mci_results_write @ This is the generic [[record]] method, which can be called directly from the integrator. The [[record_extended]] procedure store additionally the valid calls, positive and negative efficiency. <>= generic :: record => record_simple, record_extended procedure (mci_results_record_simple), deferred :: record_simple procedure (mci_results_record_extended), deferred :: record_extended <>= abstract interface subroutine mci_results_record_simple (object, n_it, & n_calls, integral, error, efficiency, chain_weights, suppress) import class(mci_results_t), intent(inout) :: object integer, intent(in) :: n_it integer, intent(in) :: n_calls real(default), intent(in) :: integral real(default), intent(in) :: error real(default), intent(in) :: efficiency real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress end subroutine mci_results_record_simple subroutine mci_results_record_extended (object, n_it, n_calls,& & n_calls_valid, integral, error, efficiency, efficiency_pos,& & efficiency_neg, chain_weights, suppress) import class(mci_results_t), intent(inout) :: object integer, intent(in) :: n_it integer, intent(in) :: n_calls integer, intent(in) :: n_calls_valid real(default), intent(in) :: integral real(default), intent(in) :: error real(default), intent(in) :: efficiency real(default), intent(in) :: efficiency_pos real(default), intent(in) :: efficiency_neg real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress end subroutine mci_results_record_extended end interface @ %def mci_results_record @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[mci_base_ut.f90]]>>= <> module mci_base_ut use unit_tests use mci_base_uti <> <> <> contains <> end module mci_base_ut @ %def mci_base_ut @ <<[[mci_base_uti.f90]]>>= <> module mci_base_uti <> use io_units use diagnostics use phs_base use rng_base use mci_base use rng_base_ut, only: rng_test_t <> <> <> <> contains <> end module mci_base_uti @ %def mci_base_ut @ API: driver for the unit tests below. <>= public :: mci_base_test <>= subroutine mci_base_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine mci_base_test @ %def mci_base_test @ \subsubsection{Test implementation of the configuration type} The concrete type contains the number of requested calls and the integral result, to be determined. The [[max_factor]] entry is set for the actual test integration, where the integrand is not unity but some other constant value. This value should be set here, such that the actual maximum of the integrand is known when vetoing unweighted events. <>= public :: mci_test_t <>= type, extends (mci_t) :: mci_test_t integer :: divisions = 0 integer :: tries = 0 real(default) :: max_factor = 1 contains procedure :: final => mci_test_final procedure :: write => mci_test_write procedure :: startup_message => mci_test_startup_message procedure :: write_log_entry => mci_test_write_log_entry procedure :: compute_md5sum => mci_test_compute_md5sum procedure :: declare_flat_dimensions => mci_test_ignore_flat_dimensions procedure :: declare_equivalences => mci_test_ignore_equivalences procedure :: set_divisions => mci_test_set_divisions procedure :: set_max_factor => mci_test_set_max_factor procedure :: allocate_instance => mci_test_allocate_instance procedure :: integrate => mci_test_integrate procedure :: prepare_simulation => mci_test_ignore_prepare_simulation procedure :: generate_weighted_event => mci_test_generate_weighted_event procedure :: generate_unweighted_event => & mci_test_generate_unweighted_event procedure :: rebuild_event => mci_test_rebuild_event end type mci_test_t @ %def mci_test_t @ Finalizer: base version is sufficient <>= subroutine mci_test_final (object) class(mci_test_t), intent(inout) :: object call object%base_final () end subroutine mci_test_final @ %def mci_test_final @ Output: trivial <>= subroutine mci_test_write (object, unit, pacify, md5sum_version) class(mci_test_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Test integrator:" call object%base_write (u, pacify, md5sum_version) if (object%divisions /= 0) then write (u, "(3x,A,I0)") "Number of divisions = ", object%divisions end if if (allocated (object%rng)) call object%rng%write (u) end subroutine mci_test_write @ %def mci_test_write @ Short version. <>= subroutine mci_test_startup_message (mci, unit, n_calls) class(mci_test_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls call mci%base_startup_message (unit = unit, n_calls = n_calls) write (msg_buffer, "(A,1x,I0,1x,A)") & "Integrator: Test:", mci%divisions, "divisions" call msg_message (unit = unit) end subroutine mci_test_startup_message @ %def mci_test_startup_message @ Log entry: nothing. <>= subroutine mci_test_write_log_entry (mci, u) class(mci_test_t), intent(in) :: mci integer, intent(in) :: u end subroutine mci_test_write_log_entry @ %def mci_test_write_log_entry @ Compute MD5 sum: nothing. <>= subroutine mci_test_compute_md5sum (mci, pacify) class(mci_test_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_test_compute_md5sum @ %def mci_test_compute_md5sum @ This is a no-op for the test integrator. <>= subroutine mci_test_ignore_flat_dimensions (mci, dim_flat) class(mci_test_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_test_ignore_flat_dimensions @ %def mci_test_ignore_flat_dimensions @ Ditto. <>= subroutine mci_test_ignore_equivalences (mci, channel, dim_offset) class(mci_test_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_test_ignore_equivalences @ %def mci_test_ignore_equivalences @ Set the number of divisions to a nonzero value. <>= subroutine mci_test_set_divisions (object, divisions) class(mci_test_t), intent(inout) :: object integer, intent(in) :: divisions object%divisions = divisions end subroutine mci_test_set_divisions @ %def mci_test_set_divisions @ Set the maximum factor (default is 1). <>= subroutine mci_test_set_max_factor (object, max_factor) class(mci_test_t), intent(inout) :: object real(default), intent(in) :: max_factor object%max_factor = max_factor end subroutine mci_test_set_max_factor @ %def mci_test_set_max_factor @ Allocate instance with matching type. <>= subroutine mci_test_allocate_instance (mci, mci_instance) class(mci_test_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance allocate (mci_test_instance_t :: mci_instance) end subroutine mci_test_allocate_instance @ %def mci_test_allocate_instance @ Integrate: sample at the midpoints of uniform bits and add the results. We implement this for one and for two dimensions. In the latter case, we scan over two channels and multiply with the channel weights. The arguments [[n_it]] and [[n_calls]] are ignored in this implementations. The test integrator does not set error or efficiency, so those will remain undefined. <>= subroutine mci_test_integrate (mci, instance, sampler, & n_it, n_calls, results, pacify) class(mci_test_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: pacify class(mci_results_t), intent(inout), optional :: results real(default), dimension(:), allocatable :: integral real(default), dimension(:), allocatable :: x integer :: i, j, c select type (instance) type is (mci_test_instance_t) allocate (integral (mci%n_channel)) integral = 0 allocate (x (mci%n_dim)) select case (mci%n_dim) case (1) do c = 1, mci%n_channel do i = 1, mci%divisions x(1) = (i - 0.5_default) / mci%divisions call instance%evaluate (sampler, c, x) integral(c) = integral(c) + instance%get_value () end do end do mci%integral = dot_product (instance%w, integral) & / mci%divisions mci%integral_known = .true. case (2) do c = 1, mci%n_channel do i = 1, mci%divisions x(1) = (i - 0.5_default) / mci%divisions do j = 1, mci%divisions x(2) = (j - 0.5_default) / mci%divisions call instance%evaluate (sampler, c, x) integral(c) = integral(c) + instance%get_value () end do end do end do mci%integral = dot_product (instance%w, integral) & / mci%divisions / mci%divisions mci%integral_known = .true. end select if (present (results)) then call results%record (n_it, n_calls, & mci%integral, mci%error, & efficiency = 0._default) end if end select end subroutine mci_test_integrate @ %def mci_test_integrate @ Simulation initializer and finalizer: nothing to do here. <>= subroutine mci_test_ignore_prepare_simulation (mci) class(mci_test_t), intent(inout) :: mci end subroutine mci_test_ignore_prepare_simulation @ %def mci_test_ignore_prepare_simulation @ Event generator. We use mock random numbers for first selecting the channel and then setting the $x$ values. The results reside in the state of [[instance]] and [[sampler]]. <>= subroutine mci_test_generate_weighted_event (mci, instance, sampler) class(mci_test_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler real(default) :: r real(default), dimension(:), allocatable :: x integer :: c select type (instance) type is (mci_test_instance_t) allocate (x (mci%n_dim)) select case (mci%n_channel) case (1) c = 1 call mci%rng%generate (x(1)) case (2) call mci%rng%generate (r) if (r < instance%w(1)) then c = 1 else c = 2 end if call mci%rng%generate (x) end select call instance%evaluate (sampler, c, x) end select end subroutine mci_test_generate_weighted_event @ %def mci_test_generate_weighted_event @ For unweighted events, we generate weighted events and apply a simple rejection step to the relative event weight, until an event passes. (This might result in an endless loop if we happen to be in sync with the mock random generator cycle. Therefore, limit the number of tries.) <>= subroutine mci_test_generate_unweighted_event (mci, instance, sampler) class(mci_test_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler real(default) :: r integer :: i select type (instance) type is (mci_test_instance_t) mci%tries = 0 do i = 1, 10 call mci%generate_weighted_event (instance, sampler) mci%tries = mci%tries + 1 call mci%rng%generate (r) if (r < instance%rel_value) exit end do end select end subroutine mci_test_generate_unweighted_event @ %def mci_test_generate_unweighted_event @ Here, we rebuild the event from the state without consulting the rng. <>= subroutine mci_test_rebuild_event (mci, instance, sampler, state) class(mci_test_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state select type (instance) type is (mci_test_instance_t) call instance%recall (sampler, state) end select end subroutine mci_test_rebuild_event @ %def mci_test_rebuild_event @ \subsubsection{Instance of the test MCI type} This instance type simulates the VAMP approach. We implement the VAMP multi-channel formula, but keep the channel-specific probability functions $g_i$ smooth and fixed. We also keep the weights fixed. The setup is as follows: we have $n$ mappings of the unit hypercube \begin{equation} x = x (x^{(k)}) \qquad \text{where $x=(x_1,\ldots)$}. \end{equation} The Jacobian factors are the determinants \begin{equation} f^{(k)}(x^{(k)}) = \left|\frac{\partial x}{\partial x^{(k)}}\right| \end{equation} We introduce arbitrary probability functions \begin{equation} g^{(k)}(x^{(k)}) \qquad \text{with}\quad \int dx^{(k)} g^{(k)}(x^{(k)}) = 1 \end{equation} and weights \begin{equation} w_k \qquad \text{with}\quad \sum_k w_k = 1 \end{equation} and construct the joint probability function \begin{equation} g(x) = \sum_k w_k\frac{g^{(k)}(x^{(k)}(x))}{f^{(k)}(x^{(k)}(x))} \end{equation} which also satisfies \begin{equation} \int g(x)\,dx = 1. \end{equation} The algorithm implements a resolution of unity as follows \begin{align} 1 &= \int dx = \int\frac{g(x)}{g(x)} dx \nonumber\\ &= \sum w_k \int \frac{g^{(k)}(x^{(k)}(x))}{f^{(k)}(x^{(k)}(x))} \,\frac{dx}{g(x)} \nonumber\\ &= \sum w_k \int g^{(k)}(x^{(k)}) \frac{dx^{(k)}}{g(x(x^{(k)}))} \end{align} where each of the integrals in the sum is evaluated using the channel-specific variables $x^{(k)}$. We provide two examples: (1) trivial with one channel, one dimension, and all functions unity and (2) two channels and two dimensions with \begin{align} x (x^{(1)}) &= (x^{(1)}_1, x^{(1)}_2) \nonumber\\ x (x^{(2)}) &= (x^{(2)}_1{}^2, x^{(2)}_2) \end{align} hence \begin{align} f^{(1)}&\equiv 1, &f^{(2)}(x^{(2)}) &= 2x^{(2)}_1 \end{align} The probability functions are \begin{align} g^{(1)}&\equiv 1, &g^{(2)}(x^{(2)}) = 2 x^{(2)}_2 \end{align} In the concrete implementation of the integrator instance we store values for the channel probabilities $g_i$ and the accumulated probability $g$. We also store the result (product of integrand and MCI weight), the expected maximum for the result in each channel. <>= public :: mci_test_instance_t <>= type, extends (mci_instance_t) :: mci_test_instance_t type(mci_test_t), pointer :: mci => null () real(default) :: g = 0 real(default), dimension(:), allocatable :: gi real(default) :: value = 0 real(default) :: rel_value = 0 real(default), dimension(:), allocatable :: max contains procedure :: write => mci_test_instance_write procedure :: final => mci_test_instance_final procedure :: init => mci_test_instance_init procedure :: compute_weight => mci_test_instance_compute_weight procedure :: record_integrand => mci_test_instance_record_integrand procedure :: init_simulation => mci_test_instance_init_simulation procedure :: final_simulation => mci_test_instance_final_simulation procedure :: get_event_excess => mci_test_instance_get_event_excess end type mci_test_instance_t @ %def mci_test_instance_t @ Output: trivial <>= subroutine mci_test_instance_write (object, unit, pacify) class(mci_test_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u, c u = given_output_unit (unit) write (u, "(1x,A,ES13.7)") "Result value = ", object%value write (u, "(1x,A,ES13.7)") "Rel. weight = ", object%rel_value write (u, "(1x,A,ES13.7)") "Integrand = ", object%integrand write (u, "(1x,A,ES13.7)") "MCI weight = ", object%mci_weight write (u, "(3x,A,I0)") "c = ", object%selected_channel write (u, "(3x,A,ES13.7)") "g = ", object%g write (u, "(1x,A)") "Channel parameters:" do c = 1, object%mci%n_channel write (u, "(1x,I0,A,4(1x,ES13.7))") c, ": w/f/g/m =", & object%w(c), object%f(c), object%gi(c), object%max(c) write (u, "(4x,A,9(1x,F9.7))") "x =", object%x(:,c) end do end subroutine mci_test_instance_write @ %def mci_test_instance_write @ The finalizer is empty. <>= subroutine mci_test_instance_final (object) class(mci_test_instance_t), intent(inout) :: object end subroutine mci_test_instance_final @ %def mci_test_instance_final @ Initializer. We make use of the analytical result that the maximum of the weighted integrand, in each channel, is equal to $1$ (one-dimensional case) and $2$ (two-dimensional case), respectively. <>= subroutine mci_test_instance_init (mci_instance, mci) class(mci_test_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci call mci_instance%base_init (mci) select type (mci) type is (mci_test_t) mci_instance%mci => mci end select allocate (mci_instance%gi (mci%n_channel)) mci_instance%gi = 0 allocate (mci_instance%max (mci%n_channel)) select case (mci%n_channel) case (1) mci_instance%max = 1._default case (2) mci_instance%max = 2._default end select end subroutine mci_test_instance_init @ %def mci_test_instance_init @ Compute weight: we implement the VAMP multi-channel formula. The channel probabilities [[gi]] are predefined functions. <>= subroutine mci_test_instance_compute_weight (mci, c) class(mci_test_instance_t), intent(inout) :: mci integer, intent(in) :: c integer :: i mci%selected_channel = c select case (mci%mci%n_dim) case (1) mci%gi(1) = 1 case (2) mci%gi(1) = 1 mci%gi(2) = 2 * mci%x(2,2) end select mci%g = 0 do i = 1, mci%mci%n_channel mci%g = mci%g + mci%w(i) * mci%gi(i) / mci%f(i) end do mci%mci_weight = mci%gi(c) / mci%g end subroutine mci_test_instance_compute_weight @ %def mci_test_instance_compute_weight @ Record the integrand. Apply the Jacobian weight to get the absolute value. Divide by the channel maximum and by any overall factor to get the value relative to the maximum. <>= subroutine mci_test_instance_record_integrand (mci, integrand) class(mci_test_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand mci%integrand = integrand mci%value = mci%integrand * mci%mci_weight mci%rel_value = mci%value / mci%max(mci%selected_channel) & / mci%mci%max_factor end subroutine mci_test_instance_record_integrand @ %def mci_test_instance_record_integrand @ Nothing to do here. <>= subroutine mci_test_instance_init_simulation (instance, safety_factor) class(mci_test_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor end subroutine mci_test_instance_init_simulation subroutine mci_test_instance_final_simulation (instance) class(mci_test_instance_t), intent(inout) :: instance end subroutine mci_test_instance_final_simulation @ %def mci_test_instance_init_simulation @ %def mci_test_instance_final_simulation @ Return always zero. <>= function mci_test_instance_get_event_excess (mci) result (excess) class(mci_test_instance_t), intent(in) :: mci real(default) :: excess excess = 0 end function mci_test_instance_get_event_excess @ %def mci_test_instance_get_event_excess @ \subsubsection{Test sampler} The test sampler implements a fixed configuration, either trivial (one-channel, one-dimension), or slightly nontrivial (two-channel, two-dimension). In the second channel, the first parameter is mapped according to $x_1 = x^{(2)}_1{}^2$, so we have $f^{(2)}(x^{(2)}) = 2x^{(2)}_1$. For display purposes, we store the return values inside the object. This is not strictly necessary. <>= type, extends (mci_sampler_t) :: test_sampler_t real(default) :: integrand = 0 integer :: selected_channel = 0 real(default), dimension(:,:), allocatable :: x real(default), dimension(:), allocatable :: f contains procedure :: init => test_sampler_init procedure :: write => test_sampler_write procedure :: compute => test_sampler_compute procedure :: is_valid => test_sampler_is_valid procedure :: evaluate => test_sampler_evaluate procedure :: rebuild => test_sampler_rebuild procedure :: fetch => test_sampler_fetch end type test_sampler_t @ %def test_sampler_t <>= subroutine test_sampler_init (sampler, n) class(test_sampler_t), intent(out) :: sampler integer, intent(in) :: n allocate (sampler%x (n, n)) allocate (sampler%f (n)) end subroutine test_sampler_init @ %def test_sampler_init @ Output <>= subroutine test_sampler_write (object, unit, testflag) class(test_sampler_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u, c u = given_output_unit (unit) write (u, "(1x,A)") "Test sampler:" write (u, "(3x,A,ES13.7)") "Integrand = ", object%integrand write (u, "(3x,A,I0)") "Channel = ", object%selected_channel do c = 1, size (object%f) write (u, "(1x,I0,':',1x,A,ES13.7)") c, "f = ", object%f(c) write (u, "(4x,A,9(1x,F9.7))") "x =", object%x(:,c) end do end subroutine test_sampler_write @ %def test_sampler_write @ Compute $x$ and Jacobians, given the input parameter array. This is called both by [[evaluate]] and [[rebuild]]. <>= subroutine test_sampler_compute (sampler, c, x_in) class(test_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in sampler%selected_channel = c select case (size (sampler%f)) case (1) sampler%x(:,1) = x_in sampler%f = 1 case (2) select case (c) case (1) sampler%x(:,1) = x_in sampler%x(1,2) = sqrt (x_in(1)) sampler%x(2,2) = x_in(2) case (2) sampler%x(1,1) = x_in(1) ** 2 sampler%x(2,1) = x_in(2) sampler%x(:,2) = x_in end select sampler%f(1) = 1 sampler%f(2) = 2 * sampler%x(1,2) end select end subroutine test_sampler_compute @ %def test_sampler_kineamtics @ The point is always valid. <>= function test_sampler_is_valid (sampler) result (valid) class(test_sampler_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_is_valid @ %def test_sampler_is_valid @ The integrand is always equal to 1. <>= subroutine test_sampler_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) sampler%integrand = 1 val = sampler%integrand x = sampler%x f = sampler%f end subroutine test_sampler_evaluate @ %def test_sampler_evaluate @ Construct kinematics from the input $x$ array. Set the integrand instead of evaluating it. <>= subroutine test_sampler_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) sampler%integrand = val x = sampler%x f = sampler%f end subroutine test_sampler_rebuild @ %def test_sampler_rebuild @ Recall contents. <>= subroutine test_sampler_fetch (sampler, val, x, f) class(test_sampler_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%integrand x = sampler%x f = sampler%f end subroutine test_sampler_fetch @ %def test_sampler_fetch @ \subsubsection{Test results object} This mock object just stores and displays the current result. <>= type, extends (mci_results_t) :: mci_test_results_t integer :: n_it = 0 integer :: n_calls = 0 real(default) :: integral = 0 real(default) :: error = 0 real(default) :: efficiency = 0 contains <> end type mci_test_results_t @ %def mci_test_results_t @ Output. <>= procedure :: write => mci_test_results_write procedure :: write_verbose => mci_test_results_write_verbose <>= subroutine mci_test_results_write (object, unit, suppress) class(mci_test_results_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: suppress integer :: u u = given_output_unit (unit) write (u, "(3x,A,1x,I0)") "Iterations = ", object%n_it write (u, "(3x,A,1x,I0)") "Calls = ", object%n_calls write (u, "(3x,A,1x,F12.10)") "Integral = ", object%integral write (u, "(3x,A,1x,F12.10)") "Error = ", object%error write (u, "(3x,A,1x,F12.10)") "Efficiency = ", object%efficiency end subroutine mci_test_results_write subroutine mci_test_results_write_verbose (object, unit) class(mci_test_results_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A,1x,I0)") "Iterations = ", object%n_it write (u, "(3x,A,1x,I0)") "Calls = ", object%n_calls write (u, "(3x,A,1x,F12.10)") "Integral = ", object%integral write (u, "(3x,A,1x,F12.10)") "Error = ", object%error write (u, "(3x,A,1x,F12.10)") "Efficiency = ", object%efficiency end subroutine mci_test_results_write_verbose @ %def mci_test_results_write @ Record result. <>= procedure :: record_simple => mci_test_results_record_simple procedure :: record_extended => mci_test_results_record_extended <>= subroutine mci_test_results_record_simple (object, n_it, n_calls, & integral, error, efficiency, chain_weights, suppress) class(mci_test_results_t), intent(inout) :: object integer, intent(in) :: n_it integer, intent(in) :: n_calls real(default), intent(in) :: integral real(default), intent(in) :: error real(default), intent(in) :: efficiency real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress object%n_it = n_it object%n_calls = n_calls object%integral = integral object%error = error object%efficiency = efficiency end subroutine mci_test_results_record_simple subroutine mci_test_results_record_extended (object, n_it, n_calls, & & n_calls_valid, integral, error, efficiency, efficiency_pos, & & efficiency_neg, chain_weights, suppress) class(mci_test_results_t), intent(inout) :: object integer, intent(in) :: n_it integer, intent(in) :: n_calls integer, intent(in) :: n_calls_valid real(default), intent(in) :: integral real(default), intent(in) :: error real(default), intent(in) :: efficiency real(default), intent(in) :: efficiency_pos real(default), intent(in) :: efficiency_neg real(default), dimension(:), intent(in), optional :: chain_weights logical, intent(in), optional :: suppress object%n_it = n_it object%n_calls = n_calls object%integral = integral object%error = error object%efficiency = efficiency end subroutine mci_test_results_record_extended @ %def mci_test_results_record @ \subsubsection{Integrator configuration data} Construct and display a test integrator configuration object. <>= call test (mci_base_1, "mci_base_1", & "integrator configuration", & u, results) <>= public :: mci_base_1 <>= subroutine mci_base_1 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler real(default) :: integrand write (u, "(A)") "* Test output: mci_base_1" write (u, "(A)") "* Purpose: initialize and display & &test integrator" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (2) end select write (u, "(A)") "* Evaluate sampler for given point and channel" write (u, "(A)") call sampler%evaluate (1, [0.25_default, 0.8_default], & integrand, mci_instance%x, mci_instance%f) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Compute MCI weight" write (u, "(A)") call mci_instance%compute_weight (1) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Get integrand and compute weight for another point" write (u, "(A)") call mci_instance%evaluate (sampler, 2, [0.5_default, 0.6_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Recall results, again" write (u, "(A)") call mci_instance%final () deallocate (mci_instance) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) call mci_instance%fetch (sampler, 2) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Retrieve value" write (u, "(A)") write (u, "(1x,A,ES13.7)") "Weighted integrand = ", & mci_instance%get_value () call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_1" end subroutine mci_base_1 @ %def mci_base_1 @ \subsubsection{Trivial integral} Use the MCI approach to compute a trivial one-dimensional integral. <>= call test (mci_base_2, "mci_base_2", & "integration", & u, results) <>= public :: mci_base_2 <>= subroutine mci_base_2 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_base_2" write (u, "(A)") "* Purpose: perform a test integral" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (1) end select write (u, "(A)") "* Integrate" write (u, "(A)") call mci%integrate (mci_instance, sampler, 0, 0) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_2" end subroutine mci_base_2 @ %def mci_base_2 @ \subsubsection{Nontrivial integral} Use the MCI approach to compute a simple two-dimensional integral with two channels. <>= call test (mci_base_3, "mci_base_3", & "integration (two channels)", & u, results) <>= public :: mci_base_3 <>= subroutine mci_base_3 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_base_3" write (u, "(A)") "* Purpose: perform a nontrivial test integral" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (2) end select write (u, "(A)") "* Integrate" write (u, "(A)") call mci%integrate (mci_instance, sampler, 0, 0) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with higher resolution" write (u, "(A)") select type (mci) type is (mci_test_t) call mci%set_divisions (100) end select call mci%integrate (mci_instance, sampler, 0, 0) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_3" end subroutine mci_base_3 @ %def mci_base_3 @ \subsubsection{Event generation} We generate ``random'' events, one weighted and one unweighted. The test implementation does not require an integration pass, we can generate events immediately. <>= call test (mci_base_4, "mci_base_4", & "event generation (two channels)", & u, results) <>= public :: mci_base_4 <>= subroutine mci_base_4 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_base_4" write (u, "(A)") "* Purpose: generate events" write (u, "(A)") write (u, "(A)") "* Initialize integrator, instance, sampler" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (2) end select allocate (rng_test_t :: rng) call mci%import_rng (rng) write (u, "(A)") "* Generate weighted event" write (u, "(A)") call mci%generate_weighted_event (mci_instance, sampler) call sampler%write (u) write (u, *) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Generate unweighted event" write (u, "(A)") call mci%generate_unweighted_event (mci_instance, sampler) select type (mci) type is (mci_test_t) write (u, "(A,I0)") " Success in try ", mci%tries write (u, "(A)") end select call sampler%write (u) write (u, *) call mci_instance%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_4" end subroutine mci_base_4 @ %def mci_base_4 @ \subsubsection{Store and recall data} We generate an event and store the relevant data, i.e., the input parameters and the result value for a particular channel. Then we use those data to recover the event, as far as the MCI record is concerned. <>= call test (mci_base_5, "mci_base_5", & "store and recall", & u, results) <>= public :: mci_base_5 <>= subroutine mci_base_5 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng class(mci_state_t), allocatable :: state write (u, "(A)") "* Test output: mci_base_5" write (u, "(A)") "* Purpose: store and recall an event" write (u, "(A)") write (u, "(A)") "* Initialize integrator, instance, sampler" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (2) end select allocate (rng_test_t :: rng) call mci%import_rng (rng) write (u, "(A)") "* Generate weighted event" write (u, "(A)") call mci%generate_weighted_event (mci_instance, sampler) call sampler%write (u) write (u, *) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Store data" write (u, "(A)") allocate (state) call mci_instance%store (state) call mci_instance%final () deallocate (mci_instance) call state%write (u) write (u, "(A)") write (u, "(A)") "* Recall data and rebuild event" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) call mci%rebuild_event (mci_instance, sampler, state) call sampler%write (u) write (u, *) call mci_instance%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_5" end subroutine mci_base_5 @ %def mci_base_5 @ \subsubsection{Chained channels} Chain channels together. In the base configuration, this just fills entries in an extra array (each channel may belong to a chain). In type implementations, this will be used for grouping equivalent channels by keeping their weights equal. <>= call test (mci_base_6, "mci_base_6", & "chained channels", & u, results) <>= public :: mci_base_6 <>= subroutine mci_base_6 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci write (u, "(A)") "* Test output: mci_base_6" write (u, "(A)") "* Purpose: initialize and display & &test integrator with chains" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (1, 5) write (u, "(A)") "* Introduce chains" write (u, "(A)") call mci%declare_chains ([1, 2, 2, 1, 2]) call mci%write (u) call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_6" end subroutine mci_base_6 @ %def mci_base_6 @ \subsubsection{Recording results} Compute a simple two-dimensional integral and record the result. <>= call test (mci_base_7, "mci_base_7", & "recording results", & u, results) <>= public :: mci_base_7 <>= subroutine mci_base_7 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(mci_results_t), allocatable :: results write (u, "(A)") "* Test output: mci_base_7" write (u, "(A)") "* Purpose: perform a nontrivial test integral & &and record results" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_t :: sampler) select type (sampler) type is (test_sampler_t) call sampler%init (2) end select allocate (mci_test_results_t :: results) write (u, "(A)") "* Integrate" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000, results) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Display results" write (u, "(A)") call results%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_7" end subroutine mci_base_7 @ %def mci_base_7 @ \subsubsection{Timer} Simple checks for the embedded timer. <>= call test (mci_base_8, "mci_base_8", & "timer", & u, results) <>= public :: mci_base_8 <>= subroutine mci_base_8 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci real(default) :: dummy write (u, "(A)") "* Test output: mci_base_8" write (u, "(A)") "* Purpose: check timer availability" write (u, "(A)") write (u, "(A)") "* Initialize integrator with timer" write (u, "(A)") allocate (mci_test_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_test_t) call mci%set_divisions (10) end select call mci%set_timer (active = .true.) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Start timer" write (u, "(A)") call mci%start_timer () call mci%write (u) write (u, "(A)") write (u, "(A)") "* Stop timer" write (u, "(A)") call mci%stop_timer () write (u, "(A)") " (ok)" write (u, "(A)") write (u, "(A)") "* Readout" write (u, "(A)") dummy = mci%get_time () write (u, "(A)") " (ok)" write (u, "(A)") write (u, "(A)") "* Deactivate timer" write (u, "(A)") call mci%set_timer (active = .false.) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_base_8" end subroutine mci_base_8 @ %def mci_base_8 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Iterations} This module defines a container for the list of iterations and calls, to be submitted to integration. <<[[iterations.f90]]>>= <> module iterations <> <> use io_units use diagnostics <> <> <> contains <> end module iterations @ %def iterations @ \subsection{The iterations list} Each integration pass has a number of iterations and a number of calls per iteration. The last pass produces the end result; the previous passes are used for adaptation. The flags [[adapt_grid]] and [[adapt_weight]] are used only if [[custom_adaptation]] is set. Otherwise, default settings are used that depend on the integration pass. <>= type :: iterations_spec_t private integer :: n_it = 0 integer :: n_calls = 0 logical :: custom_adaptation = .false. logical :: adapt_grids = .false. logical :: adapt_weights = .false. end type iterations_spec_t @ %def iterations_spec_t @ We build up a list of iterations. <>= public :: iterations_list_t <>= type :: iterations_list_t private integer :: n_pass = 0 type(iterations_spec_t), dimension(:), allocatable :: pass contains <> end type iterations_list_t @ %def iterations_list_t @ Initialize an iterations list. For each pass, we have to specify the number of iterations and calls. We may provide the adaption conventions explicitly, either as character codes or as logicals. For passes where the adaptation conventions are not specified, we use the following default setting: adapt weights and grids for all passes except the last one. <>= procedure :: init => iterations_list_init <>= subroutine iterations_list_init & (it_list, n_it, n_calls, adapt, adapt_code, adapt_grids, adapt_weights) class(iterations_list_t), intent(inout) :: it_list integer, dimension(:), intent(in) :: n_it, n_calls logical, dimension(:), intent(in), optional :: adapt type(string_t), dimension(:), intent(in), optional :: adapt_code logical, dimension(:), intent(in), optional :: adapt_grids, adapt_weights integer :: i it_list%n_pass = size (n_it) if (allocated (it_list%pass)) deallocate (it_list%pass) allocate (it_list%pass (it_list%n_pass)) it_list%pass%n_it = n_it it_list%pass%n_calls = n_calls if (present (adapt)) then it_list%pass%custom_adaptation = adapt do i = 1, it_list%n_pass if (adapt(i)) then if (verify (adapt_code(i), "wg") /= 0) then call msg_error ("iteration specification: " & // "adaptation code letters must be 'w' or 'g'") end if it_list%pass(i)%adapt_grids = scan (adapt_code(i), "g") /= 0 it_list%pass(i)%adapt_weights = scan (adapt_code(i), "w") /= 0 end if end do else if (present (adapt_grids) .and. present (adapt_weights)) then it_list%pass%custom_adaptation = .true. it_list%pass%adapt_grids = adapt_grids it_list%pass%adapt_weights = adapt_weights end if do i = 1, it_list%n_pass - 1 if (.not. it_list%pass(i)%custom_adaptation) then it_list%pass(i)%adapt_grids = .true. it_list%pass(i)%adapt_weights = .true. end if end do end subroutine iterations_list_init @ %def iterations_list_init <>= procedure :: clear => iterations_list_clear <>= subroutine iterations_list_clear (it_list) class(iterations_list_t), intent(inout) :: it_list it_list%n_pass = 0 deallocate (it_list%pass) end subroutine iterations_list_clear @ %def iterations_list_clear @ Write the list of iterations. <>= procedure :: write => iterations_list_write <>= subroutine iterations_list_write (it_list, unit) class(iterations_list_t), intent(in) :: it_list integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(A)") char (it_list%to_string ()) end subroutine iterations_list_write @ %def iterations_list_write @ The output as a single-line string. <>= procedure :: to_string => iterations_list_to_string <>= function iterations_list_to_string (it_list) result (buffer) class(iterations_list_t), intent(in) :: it_list type(string_t) :: buffer character(30) :: ibuf integer :: i buffer = "iterations = " if (it_list%n_pass > 0) then do i = 1, it_list%n_pass if (i > 1) buffer = buffer // ", " write (ibuf, "(I0,':',I0)") & it_list%pass(i)%n_it, it_list%pass(i)%n_calls buffer = buffer // trim (ibuf) if (it_list%pass(i)%custom_adaptation & .or. it_list%pass(i)%adapt_grids & .or. it_list%pass(i)%adapt_weights) then buffer = buffer // ':"' if (it_list%pass(i)%adapt_grids) buffer = buffer // "g" if (it_list%pass(i)%adapt_weights) buffer = buffer // "w" buffer = buffer // '"' end if end do else buffer = buffer // "[undefined]" end if end function iterations_list_to_string @ %def iterations_list_to_string @ \subsection{Tools} Return the total number of passes. <>= procedure :: get_n_pass => iterations_list_get_n_pass <>= function iterations_list_get_n_pass (it_list) result (n_pass) class(iterations_list_t), intent(in) :: it_list integer :: n_pass n_pass = it_list%n_pass end function iterations_list_get_n_pass @ %def iterations_list_get_n_pass @ Return the number of calls for a specific pass. <>= procedure :: get_n_calls => iterations_list_get_n_calls <>= function iterations_list_get_n_calls (it_list, pass) result (n_calls) class(iterations_list_t), intent(in) :: it_list integer :: n_calls integer, intent(in) :: pass if (pass <= it_list%n_pass) then n_calls = it_list%pass(pass)%n_calls else n_calls = 0 end if end function iterations_list_get_n_calls @ %def iterations_list_get_n_calls @ <>= procedure :: set_n_calls => iterations_list_set_n_calls <>= subroutine iterations_list_set_n_calls (it_list, pass, n_calls) class(iterations_list_t), intent(inout) :: it_list integer, intent(in) :: pass, n_calls it_list%pass(pass)%n_calls = n_calls end subroutine iterations_list_set_n_calls @ %def iterations_list_set_n_calls @ Get the adaptation mode (automatic/custom) and, for custom adaptation, the flags for a specific pass. <>= procedure :: adapt_grids => iterations_list_adapt_grids procedure :: adapt_weights => iterations_list_adapt_weights <>= function iterations_list_adapt_grids (it_list, pass) result (flag) logical :: flag class(iterations_list_t), intent(in) :: it_list integer, intent(in) :: pass if (pass <= it_list%n_pass) then flag = it_list%pass(pass)%adapt_grids else flag = .false. end if end function iterations_list_adapt_grids function iterations_list_adapt_weights (it_list, pass) result (flag) logical :: flag class(iterations_list_t), intent(in) :: it_list integer, intent(in) :: pass if (pass <= it_list%n_pass) then flag = it_list%pass(pass)%adapt_weights else flag = .false. end if end function iterations_list_adapt_weights @ %def iterations_list_has_custom_adaptation @ %def iterations_list_adapt_grids @ %def iterations_list_adapt_weights @ Return the total number of iterations / the iterations for a specific pass. <>= procedure :: get_n_it => iterations_list_get_n_it <>= function iterations_list_get_n_it (it_list, pass) result (n_it) class(iterations_list_t), intent(in) :: it_list integer :: n_it integer, intent(in) :: pass if (pass <= it_list%n_pass) then n_it = it_list%pass(pass)%n_it else n_it = 0 end if end function iterations_list_get_n_it @ %def iterations_list_get_n_it @ \subsection{Iteration Multipliers} <>= public :: iteration_multipliers_t <>= type :: iteration_multipliers_t real(default) :: mult_real = 1._default real(default) :: mult_virt = 1._default real(default) :: mult_dglap = 1._default real(default) :: mult_threshold = 1._default integer, dimension(:), allocatable :: n_calls0 end type iteration_multipliers_t @ %def iterations_multipliers @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[iterations_ut.f90]]>>= <> module iterations_ut use unit_tests use iterations_uti <> <> contains <> end module iterations_ut @ %def iterations_ut @ <<[[iterations_uti.f90]]>>= <> module iterations_uti <> use iterations <> <> contains <> end module iterations_uti @ %def iterations_ut @ API: driver for the unit tests below. <>= public :: iterations_test <>= subroutine iterations_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine iterations_test @ %def iterations_test @ \subsubsection{Empty list} <>= call test (iterations_1, "iterations_1", & "empty iterations list", & u, results) <>= public :: iterations_1 <>= subroutine iterations_1 (u) integer, intent(in) :: u type(iterations_list_t) :: it_list write (u, "(A)") "* Test output: iterations_1" write (u, "(A)") "* Purpose: display empty iterations list" write (u, "(A)") call it_list%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: iterations_1" end subroutine iterations_1 @ %def iterations_1 @ \subsubsection{Fill list} <>= call test (iterations_2, "iterations_2", & "create iterations list", & u, results) <>= public :: iterations_2 <>= subroutine iterations_2 (u) integer, intent(in) :: u type(iterations_list_t) :: it_list write (u, "(A)") "* Test output: iterations_2" write (u, "(A)") "* Purpose: fill and display iterations list" write (u, "(A)") write (u, "(A)") "* Minimal setup (2 passes)" write (u, "(A)") call it_list%init ([2, 4], [5000, 20000]) call it_list%write (u) call it_list%clear () write (u, "(A)") write (u, "(A)") "* Setup with flags (3 passes)" write (u, "(A)") call it_list%init ([2, 4, 5], [5000, 20000, 400], & [.false., .true., .true.], & [var_str (""), var_str ("g"), var_str ("wg")]) call it_list%write (u) write (u, "(A)") write (u, "(A)") "* Extract data" write (u, "(A)") write (u, "(A,I0)") "n_pass = ", it_list%get_n_pass () write (u, "(A)") write (u, "(A,I0)") "n_calls(2) = ", it_list%get_n_calls (2) write (u, "(A)") write (u, "(A,I0)") "n_it(3) = ", it_list%get_n_it (3) write (u, "(A)") write (u, "(A)") "* Test output end: iterations_2" end subroutine iterations_2 @ %def iterations_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Integration results} We record integration results and errors in a dedicated type. This allows us to do further statistics such as weighted average, chi-squared, grouping by integration passes, etc. Note WHIZARD 2.2.0: This code is taken from the previous [[processes]] module essentially unchanged and converted into a separate module. It lacks an overhaul and, in particular, self-tests. <<[[integration_results.f90]]>>= module integration_results <> <> use io_units use format_utils, only: mp_format, pac_fmt use format_defs, only: FMT_10, FMT_14 use diagnostics use md5 use os_interface use mci_base <> <> <> <> <> contains <> end module integration_results @ %def integration_results @ \subsection{Integration results entry} This object collects the results of an integration pass and makes them available to the outside. The results object has to distinguish the process type: We store the process type, the index of the integration pass and the absolute iteration index, the number of iterations contained in this result (for averages), and the integral (cross section or partial width), error estimate, efficiency. For intermediate results, we set a flag if this result is an improvement w.r.t. previous ones. The process type indicates decay or scattering. Dummy entries (skipped iterations) have a process type of [[PRC_UNKNOWN]]. The additional information [[n_calls_valid]], [[efficiency_pos]] and [[efficiency_neg]] are stored, but only used in verbose mode. <>= public :: integration_entry_t <>= type :: integration_entry_t private integer :: process_type = PRC_UNKNOWN integer :: pass = 0 integer :: it = 0 integer :: n_it = 0 integer :: n_calls = 0 integer :: n_calls_valid = 0 logical :: improved = .false. real(default) :: integral = 0 real(default) :: error = 0 real(default) :: efficiency = 0 real(default) :: efficiency_pos = 0 real(default) :: efficiency_neg = 0 real(default) :: chi2 = 0 real(default), dimension(:), allocatable :: chain_weights contains <> end type integration_entry_t @ %def integration_result_t @ The possible values of the type indicator: <>= integer, parameter, public :: PRC_UNKNOWN = 0 integer, parameter, public :: PRC_DECAY = 1 integer, parameter, public :: PRC_SCATTERING = 2 @ %def PRC_UNKNOWN PRC_DECAY PRC_SCATTERING @ Initialize with all relevant data. <>= interface integration_entry_t module procedure integration_entry_init end interface integration_entry_t <>= type(integration_entry_t) function integration_entry_init (process_type, pass,& & it, n_it, n_calls, n_calls_valid, improved, integral, error,& & efficiency, efficiency_pos, efficiency_neg, chi2, chain_weights)& & result (entry) integer, intent(in) :: process_type, pass, it, n_it, n_calls, n_calls_valid logical, intent(in) :: improved real(default), intent(in) :: integral, error, efficiency, efficiency_pos, efficiency_neg real(default), intent(in), optional :: chi2 real(default), dimension(:), intent(in), optional :: chain_weights entry%process_type = process_type entry%pass = pass entry%it = it entry%n_it = n_it entry%n_calls = n_calls entry%n_calls_valid = n_calls_valid entry%improved = improved entry%integral = integral entry%error = error entry%efficiency = efficiency entry%efficiency_pos = efficiency_pos entry%efficiency_neg = efficiency_neg if (present (chi2)) entry%chi2 = chi2 if (present (chain_weights)) then allocate (entry%chain_weights (size (chain_weights))) entry%chain_weights = chain_weights end if end function integration_entry_init @ %def integration_entry_init @ Access values, some of them computed on demand: <>= procedure :: get_pass => integration_entry_get_pass procedure :: get_n_calls => integration_entry_get_n_calls procedure :: get_n_calls_valid => integration_entry_get_n_calls_valid procedure :: get_integral => integration_entry_get_integral procedure :: get_error => integration_entry_get_error procedure :: get_rel_error => integration_entry_get_relative_error procedure :: get_accuracy => integration_entry_get_accuracy procedure :: get_efficiency => integration_entry_get_efficiency procedure :: get_efficiency_pos => integration_entry_get_efficiency_pos procedure :: get_efficiency_neg => integration_entry_get_efficiency_neg procedure :: get_chi2 => integration_entry_get_chi2 procedure :: has_improved => integration_entry_has_improved procedure :: get_n_groves => integration_entry_get_n_groves <>= elemental function integration_entry_get_pass (entry) result (n) integer :: n class(integration_entry_t), intent(in) :: entry n = entry%pass end function integration_entry_get_pass elemental function integration_entry_get_n_calls (entry) result (n) integer :: n class(integration_entry_t), intent(in) :: entry n = entry%n_calls end function integration_entry_get_n_calls elemental function integration_entry_get_n_calls_valid (entry) result (n) integer :: n class(integration_entry_t), intent(in) :: entry n = entry%n_calls_valid end function integration_entry_get_n_calls_valid elemental function integration_entry_get_integral (entry) result (int) real(default) :: int class(integration_entry_t), intent(in) :: entry int = entry%integral end function integration_entry_get_integral elemental function integration_entry_get_error (entry) result (err) real(default) :: err class(integration_entry_t), intent(in) :: entry err = entry%error end function integration_entry_get_error elemental function integration_entry_get_relative_error (entry) result (err) real(default) :: err class(integration_entry_t), intent(in) :: entry err = 0 if (entry%integral /= 0) then err = entry%error / entry%integral end if end function integration_entry_get_relative_error elemental function integration_entry_get_accuracy (entry) result (acc) real(default) :: acc class(integration_entry_t), intent(in) :: entry acc = accuracy (entry%integral, entry%error, entry%n_calls) end function integration_entry_get_accuracy elemental function accuracy (integral, error, n_calls) result (acc) real(default) :: acc real(default), intent(in) :: integral, error integer, intent(in) :: n_calls acc = 0 if (integral /= 0) then acc = error / integral * sqrt (real (n_calls, default)) end if end function accuracy elemental function integration_entry_get_efficiency (entry) result (eff) real(default) :: eff class(integration_entry_t), intent(in) :: entry eff = entry%efficiency end function integration_entry_get_efficiency elemental function integration_entry_get_efficiency_pos (entry) result (eff) real(default) :: eff class(integration_entry_t), intent(in) :: entry eff = entry%efficiency_pos end function integration_entry_get_efficiency_pos elemental function integration_entry_get_efficiency_neg (entry) result (eff) real(default) :: eff class(integration_entry_t), intent(in) :: entry eff = entry%efficiency_neg end function integration_entry_get_efficiency_neg elemental function integration_entry_get_chi2 (entry) result (chi2) real(default) :: chi2 class(integration_entry_t), intent(in) :: entry chi2 = entry%chi2 end function integration_entry_get_chi2 elemental function integration_entry_has_improved (entry) result (flag) logical :: flag class(integration_entry_t), intent(in) :: entry flag = entry%improved end function integration_entry_has_improved elemental function integration_entry_get_n_groves (entry) result (n_groves) integer :: n_groves class(integration_entry_t), intent(in) :: entry n_groves = 0 if (allocated (entry%chain_weights)) then n_groves = size (entry%chain_weights, 1) end if end function integration_entry_get_n_groves @ %def integration_entry_get_pass @ %def integration_entry_get_integral @ %def integration_entry_get_error @ %def integration_entry_get_relative_error @ %def integration_entry_get_accuracy @ %def accuracy @ %def integration_entry_get_efficiency @ %def integration_entry_get_chi2 @ %def integration_entry_has_improved @ %def integration_entry_get_n_groves @ This writes the standard result account into one screen line. The verbose version uses multiple lines and prints the unabridged values. Dummy entries are not written. <>= procedure :: write => integration_entry_write procedure :: write_verbose => integration_entry_write_verbose <>= subroutine integration_entry_write (entry, unit, verbosity, suppress) class(integration_entry_t), intent(in) :: entry integer, intent(in), optional :: unit integer, intent(in), optional :: verbosity logical, intent(in), optional :: suppress integer :: u character(1) :: star character(12) :: fmt character(7) :: fmt2 character(120) :: buffer integer :: verb logical :: supp u = given_output_unit (unit); if (u < 0) return verb = 0; if (present (verbosity)) verb = verbosity supp = .false.; if (present (suppress)) supp = suppress if (entry%process_type /= PRC_UNKNOWN) then if (entry%improved .and. .not. supp) then star = "*" else star = " " end if call pac_fmt (fmt, FMT_14, "3x," // FMT_10 // ",1x", suppress) call pac_fmt (fmt2, "1x,F6.2", "2x,F5.1", suppress) write (buffer, "(1x,I3,1x,I10)") entry%it, entry%n_calls if (verb > 1) then write (buffer, "(A,1x,I10)") trim (buffer), entry%n_calls_valid end if write (buffer, "(A,1x," // fmt // ",1x,ES9.2,1x,F7.2," // & "1x,F7.2,A1," // fmt2 // ")") & trim (buffer), & entry%integral, & abs(entry%error), & abs(integration_entry_get_relative_error (entry)) * 100, & abs(integration_entry_get_accuracy (entry)), & star, & entry%efficiency * 100 if (verb > 2) then write (buffer, "(A,1X," // fmt2 // ",1X," // fmt2 // ")") & trim (buffer), & entry%efficiency_pos * 100, & entry%efficiency_neg * 100 end if if (entry%n_it /= 1) then write (buffer, "(A,1x,F7.2,1x,I3)") & trim (buffer), & entry%chi2, & entry%n_it end if write (u, "(A)") trim (buffer) end if flush (u) end subroutine integration_entry_write subroutine integration_entry_write_verbose (entry, unit) class(integration_entry_t), intent(in) :: entry integer, intent(in) :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, *) " process_type = ", entry%process_type write (u, *) " pass = ", entry%pass write (u, *) " it = ", entry%it write (u, *) " n_it = ", entry%n_it write (u, *) " n_calls = ", entry%n_calls write (u, *) " n_calls_valid = ", entry%n_calls_valid write (u, *) " improved = ", entry%improved write (u, *) " integral = ", entry%integral write (u, *) " error = ", entry%error write (u, *) " efficiency = ", entry%efficiency write (u, *) "efficiency_pos = ", entry%efficiency_pos write (u, *) "efficiency_neg = ", entry%efficiency_neg write (u, *) " chi2 = ", entry%chi2 if (allocated (entry%chain_weights)) then write (u, *) " n_groves = ", size (entry%chain_weights) write (u, *) "chain_weights = ", entry%chain_weights else write (u, *) " n_groves = 0" end if flush (u) end subroutine integration_entry_write_verbose @ %def integration_entry_write @ Read the entry, assuming it has been written in verbose format. <>= procedure :: read => integration_entry_read <>= subroutine integration_entry_read (entry, unit) class(integration_entry_t), intent(out) :: entry integer, intent(in) :: unit character(30) :: dummy character :: equals integer :: n_groves read (unit, *) dummy, equals, entry%process_type read (unit, *) dummy, equals, entry%pass read (unit, *) dummy, equals, entry%it read (unit, *) dummy, equals, entry%n_it read (unit, *) dummy, equals, entry%n_calls read (unit, *) dummy, equals, entry%n_calls_valid read (unit, *) dummy, equals, entry%improved read (unit, *) dummy, equals, entry%integral read (unit, *) dummy, equals, entry%error read (unit, *) dummy, equals, entry%efficiency read (unit, *) dummy, equals, entry%efficiency_pos read (unit, *) dummy, equals, entry%efficiency_neg read (unit, *) dummy, equals, entry%chi2 read (unit, *) dummy, equals, n_groves if (n_groves /= 0) then allocate (entry%chain_weights (n_groves)) read (unit, *) dummy, equals, entry%chain_weights end if end subroutine integration_entry_read @ %def integration_entry_read @ Write an account of the channel weights, accumulated by groves. <>= procedure :: write_chain_weights => integration_entry_write_chain_weights <>= subroutine integration_entry_write_chain_weights (entry, unit) class(integration_entry_t), intent(in) :: entry integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return if (allocated (entry%chain_weights)) then do i = 1, size (entry%chain_weights) write (u, "(1x,I3)", advance="no") nint (entry%chain_weights(i) * 100) end do write (u, *) end if end subroutine integration_entry_write_chain_weights @ %def integration_entry_write_chain_weights @ \subsection{Combined integration results} We collect a list of results which grows during the execution of the program. This is implemented as an array which grows if necessary; so we can easily compute averages. We implement this as an extension of the [[mci_results_t]] which is defined in [[mci_base]] as an abstract type. We thus decouple the implementation of the integrator from the implementation of the results display, but nevertheless can record intermediate results during integration. This implies that the present extension implements a [[record]] method. <>= public :: integration_results_t <>= type, extends (mci_results_t) :: integration_results_t private integer :: process_type = PRC_UNKNOWN integer :: current_pass = 0 integer :: n_pass = 0 integer :: n_it = 0 logical :: screen = .false. integer :: unit = 0 integer :: verbosity = 0 real(default) :: error_threshold = 0 type(integration_entry_t), dimension(:), allocatable :: entry type(integration_entry_t), dimension(:), allocatable :: average contains <> end type integration_results_t @ %def integration_results_t @ The array is extended in chunks of 10 entries. <>= integer, parameter :: RESULTS_CHUNK_SIZE = 10 @ %def RESULTS_CHUNK_SIZE @ The standard does not require to explicitly initialize the integers; however, some gfortran version has a bug here and misses the default initialization in the type definition. <>= procedure :: init => integration_results_init <>= subroutine integration_results_init (results, process_type) class(integration_results_t), intent(out) :: results integer, intent(in) :: process_type results%process_type = process_type results%n_pass = 0 results%n_it = 0 allocate (results%entry (RESULTS_CHUNK_SIZE)) allocate (results%average (RESULTS_CHUNK_SIZE)) end subroutine integration_results_init @ %def integration_results_init @ Set verbose output of the integration results. In verbose mode, valid calls, negative as positive efficiency will be printed. <>= procedure :: set_verbosity => integration_results_set_verbosity <>= subroutine integration_results_set_verbosity (results, verbosity) class(integration_results_t), intent(inout) :: results integer, intent(in) :: verbosity results%verbosity = verbosity end subroutine integration_results_set_verbosity @ %def integration_results_set_verbose @ Set additional parameters: the [[error_threshold]] declares that any error value (in absolute numbers) smaller than this is to be considered zero. <>= procedure :: set_error_threshold => integration_results_set_error_threshold <>= subroutine integration_results_set_error_threshold (results, error_threshold) class(integration_results_t), intent(inout) :: results real(default), intent(in) :: error_threshold results%error_threshold = error_threshold end subroutine integration_results_set_error_threshold @ %def integration_results_set_error_threshold @ Output (ASCII format). The [[verbose]] format is used for writing the header in grid files. <>= procedure :: write => integration_results_write procedure :: write_verbose => integration_results_write_verbose <>= subroutine integration_results_write (object, unit, suppress) class(integration_results_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: suppress logical :: verb integer :: u, n u = given_output_unit (unit); if (u < 0) return call object%write_dline (unit) if (object%n_it /= 0) then call object%write_header (unit, logfile = .false.) call object%write_dline (unit) do n = 1, object%n_it if (n > 1) then if (object%entry(n)%pass /= object%entry(n-1)%pass) then call object%write_hline (unit) call object%average(object%entry(n-1)%pass)%write ( & & unit, suppress = suppress) call object%write_hline (unit) end if end if call object%entry(n)%write (unit, & suppress = suppress) end do call object%write_hline(unit) call object%average(object%n_pass)%write (unit, suppress = suppress) else call msg_message ("[WHIZARD integration results: empty]", unit) end if call object%write_dline (unit) flush (u) end subroutine integration_results_write subroutine integration_results_write_verbose (object, unit) class(integration_results_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, n u = given_output_unit (unit); if (u < 0) return write (u, *) "begin(integration_results)" write (u, *) " n_pass = ", object%n_pass write (u, *) " n_it = ", object%n_it if (object%n_it > 0) then write (u, *) "begin(integration_pass)" do n = 1, object%n_it if (n > 1) then if (object%entry(n)%pass /= object%entry(n-1)%pass) then write (u, *) "end(integration_pass)" write (u, *) "begin(integration_pass)" end if end if write (u, *) "begin(iteration)" call object%entry(n)%write_verbose (unit) write (u, *) "end(iteration)" end do write (u, *) "end(integration_pass)" end if write (u, *) "end(integration_results)" flush (u) end subroutine integration_results_write_verbose @ %def integration_results_write integration_results_verbose @ Write a concise table of chain weights, i.e., the channel history where channels are collected by chains. <>= procedure :: write_chain_weights => & integration_results_write_chain_weights <>= subroutine integration_results_write_chain_weights (results, unit) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit integer :: u, i, n u = given_output_unit (unit); if (u < 0) return if (allocated (results%entry(1)%chain_weights) .and. results%n_it /= 0) then call msg_message ("Phase-space chain (grove) weight history: " & // "(numbers in %)", unit) write (u, "(A9)", advance="no") "| chain |" do i = 1, integration_entry_get_n_groves (results%entry(1)) write (u, "(1x,I3)", advance="no") i end do write (u, *) call results%write_dline (unit) do n = 1, results%n_it if (n > 1) then if (results%entry(n)%pass /= results%entry(n-1)%pass) then call results%write_hline (unit) end if end if write (u, "(1x,I6,1x,A1)", advance="no") n, "|" call results%entry(n)%write_chain_weights (unit) end do flush (u) call results%write_dline(unit) end if end subroutine integration_results_write_chain_weights @ %def integration_results_write_chain_weights @ Read the list from file. The file must be written using the [[verbose]] option of the writing routine. <>= procedure :: read => integration_results_read <>= subroutine integration_results_read (results, unit) class(integration_results_t), intent(out) :: results integer, intent(in) :: unit character(80) :: buffer character :: equals integer :: pass, it read (unit, *) buffer if (trim (adjustl (buffer)) /= "begin(integration_results)") then call read_err (); return end if read (unit, *) buffer, equals, results%n_pass read (unit, *) buffer, equals, results%n_it allocate (results%entry (results%n_it + RESULTS_CHUNK_SIZE)) allocate (results%average (results%n_it + RESULTS_CHUNK_SIZE)) it = 0 do pass = 1, results%n_pass read (unit, *) buffer if (trim (adjustl (buffer)) /= "begin(integration_pass)") then call read_err (); return end if READ_ENTRIES: do read (unit, *) buffer if (trim (adjustl (buffer)) /= "begin(iteration)") then exit READ_ENTRIES end if it = it + 1 call results%entry(it)%read (unit) read (unit, *) buffer if (trim (adjustl (buffer)) /= "end(iteration)") then call read_err (); return end if end do READ_ENTRIES if (trim (adjustl (buffer)) /= "end(integration_pass)") then call read_err (); return end if results%average(pass) = compute_average (results%entry, pass) end do read (unit, *) buffer if (trim (adjustl (buffer)) /= "end(integration_results)") then call read_err (); return end if contains subroutine read_err () call msg_fatal ("Reading integration results from file: syntax error") end subroutine read_err end subroutine integration_results_read @ %def integration_results_read @ Auxiliary output. <>= procedure, private :: write_header procedure, private :: write_hline procedure, private :: write_dline <>= subroutine write_header (results, unit, logfile) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit logical, intent(in), optional :: logfile character(5) :: phys_unit integer :: u u = given_output_unit (unit); if (u < 0) return select case (results%process_type) case (PRC_DECAY); phys_unit = "[GeV]" case (PRC_SCATTERING); phys_unit = "[fb] " case default phys_unit = " " end select write (msg_buffer, "(A, A)") & "It Calls" if (results%verbosity > 1) then write (msg_buffer, "(A, A)") trim (msg_buffer), & " Valid" end if write (msg_buffer, "(A, A)") trim (msg_buffer), & " Integral" // phys_unit // & " Error" // phys_unit // & " Err[%] Acc Eff[%]" if (results%verbosity > 2) then write (msg_buffer, "(A, A)") trim (msg_buffer), & " (+)[%] (-)[%]" end if write (msg_buffer, "(A, A)") trim (msg_buffer), & " Chi2 N[It] |" call msg_message (unit=u, logfile=logfile) end subroutine write_header subroutine write_hline (results, unit) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit integer :: u, len u = given_output_unit (unit); if (u < 0) return len = 77 if (results%verbosity > 1) len = len + 11 if (results%verbosity > 2) len = len + 16 write (u, "(A)") "|" // (repeat ("-", len)) // "|" flush (u) end subroutine write_hline subroutine write_dline (results, unit) class(integration_results_t), intent(in) :: results integer, intent(in), optional :: unit integer :: u, len u = given_output_unit (unit); if (u < 0) return len = 77 if (results%verbosity > 1) len = len + 11 if (results%verbosity > 2) len = len + 16 write (u, "(A)") "|" // (repeat ("=", len)) // "|" flush (u) end subroutine write_dline @ %def write_header write_hline write_dline @ During integration, we do not want to print all results at once, but each intermediate result as soon as we get it. Thus, the previous procedure is chopped in pieces. First piece: store the output unit and a flag whether we want to print to standard output as well. Then write the header if the results are still empty, i.e., before integration has started. The second piece writes a single result to the saved output channels. We call this from the [[record]] method, which can be called from the integrator directly. The third piece writes the average result, once a pass has been completed. The fourth piece writes a footer (if any), assuming that this is the final result. <>= procedure :: display_init => integration_results_display_init procedure :: display_current => integration_results_display_current procedure :: display_pass => integration_results_display_pass procedure :: display_final => integration_results_display_final <>= subroutine integration_results_display_init & (results, screen, unit) class(integration_results_t), intent(inout) :: results logical, intent(in) :: screen integer, intent(in), optional :: unit integer :: u if (present (unit)) results%unit = unit u = given_output_unit () results%screen = screen if (results%n_it == 0) then if (results%screen) then call results%write_dline (u) call results%write_header (u, & logfile=.false.) call results%write_dline (u) end if if (results%unit /= 0) then call results%write_dline (results%unit) call results%write_header (results%unit, & logfile=.false.) call results%write_dline (results%unit) end if else if (results%screen) then call results%write_hline (u) end if if (results%unit /= 0) then call results%write_hline (results%unit) end if end if end subroutine integration_results_display_init subroutine integration_results_display_current (results, pacify) class(integration_results_t), intent(in) :: results integer :: u logical, intent(in), optional :: pacify u = given_output_unit () if (results%screen) then call results%entry(results%n_it)%write (u, & verbosity = results%verbosity, suppress = pacify) end if if (results%unit /= 0) then call results%entry(results%n_it)%write ( & results%unit, verbosity = results%verbosity, suppress = pacify) end if end subroutine integration_results_display_current subroutine integration_results_display_pass (results, pacify) class(integration_results_t), intent(in) :: results logical, intent(in), optional :: pacify integer :: u u = given_output_unit () if (results%screen) then call results%write_hline (u) call results%average(results%entry(results%n_it)%pass)%write ( & u, verbosity = results%verbosity, suppress = pacify) end if if (results%unit /= 0) then call results%write_hline (results%unit) call results%average(results%entry(results%n_it)%pass)%write ( & results%unit, verbosity = results%verbosity, suppress = pacify) end if end subroutine integration_results_display_pass subroutine integration_results_display_final (results) class(integration_results_t), intent(inout) :: results integer :: u u = given_output_unit () if (results%screen) then call results%write_dline (u) end if if (results%unit /= 0) then call results%write_dline (results%unit) end if results%screen = .false. results%unit = 0 end subroutine integration_results_display_final @ %def integration_results_display_init @ %def integration_results_display_current @ %def integration_results_display_pass @ Expand the list of entries if the limit has been reached: <>= procedure :: expand => integration_results_expand <>= subroutine integration_results_expand (results) class(integration_results_t), intent(inout) :: results type(integration_entry_t), dimension(:), allocatable :: entry_tmp if (results%n_it == size (results%entry)) then allocate (entry_tmp (results%n_it)) entry_tmp = results%entry deallocate (results%entry) allocate (results%entry (results%n_it + RESULTS_CHUNK_SIZE)) results%entry(:results%n_it) = entry_tmp deallocate (entry_tmp) end if if (results%n_pass == size (results%average)) then allocate (entry_tmp (results%n_pass)) entry_tmp = results%average deallocate (results%average) allocate (results%average (results%n_it + RESULTS_CHUNK_SIZE)) results%average(:results%n_pass) = entry_tmp deallocate (entry_tmp) end if end subroutine integration_results_expand @ %def integration_results_expand @ Increment the [[current_pass]] counter. Must be done before each new integration pass; after integration, the recording method may use the value of this counter to define the entry. <>= procedure :: new_pass => integration_results_new_pass <>= subroutine integration_results_new_pass (results) class(integration_results_t), intent(inout) :: results results%current_pass = results%current_pass + 1 end subroutine integration_results_new_pass @ %def integration_results_new_pass @ Enter results into the results list. For the error value, we may compare them with a given threshold. This guards against numerical noise, if the exact error would be zero. <>= procedure :: append => integration_results_append <>= subroutine integration_results_append (results, & n_it, n_calls, n_calls_valid, & integral, error, efficiency, efficiency_pos, efficiency_neg, & chain_weights) class(integration_results_t), intent(inout) :: results integer, intent(in) :: n_it, n_calls, n_calls_valid real(default), intent(in) :: integral, error, efficiency, efficiency_pos, & & efficiency_neg real(default), dimension(:), intent(in), optional :: chain_weights logical :: improved type(integration_entry_t) :: entry real(default) :: err_checked improved = .true. if (results%n_it /= 0) improved = abs(accuracy (integral, error, n_calls)) & < abs(results%entry(results%n_it)%get_accuracy ()) err_checked = 0 if (abs (error) >= results%error_threshold) err_checked = error entry = integration_entry_t ( & results%process_type, results%current_pass, & results%n_it+1, n_it, n_calls, n_calls_valid, improved, & integral, err_checked, efficiency, efficiency_pos, efficiency_neg, & chain_weights=chain_weights) if (results%n_it == 0) then results%n_it = 1 results%n_pass = 1 else call results%expand () if (entry%pass /= results%entry(results%n_it)%pass) & results%n_pass = results%n_pass + 1 results%n_it = results%n_it + 1 end if results%entry(results%n_it) = entry results%average(results%n_pass) = & compute_average (results%entry, entry%pass) end subroutine integration_results_append @ %def integration_results_append @ Record an integration pass executed by an [[mci]] integrator object. There is a tolerance below we treat an error (relative to the integral) as zero. <>= real(default), parameter, public :: INTEGRATION_ERROR_TOLERANCE = 1e-10 @ %def INTEGRATION_ERROR_TOLERANCE @ <>= procedure :: record_simple => integration_results_record_simple <>= subroutine integration_results_record_simple & (object, n_it, n_calls, integral, error, efficiency, & chain_weights, suppress) class(integration_results_t), intent(inout) :: object integer, intent(in) :: n_it, n_calls real(default), intent(in) :: integral, error, efficiency real(default), dimension(:), intent(in), optional :: chain_weights real(default) :: err logical, intent(in), optional :: suppress err = 0._default if (abs (error) >= abs (integral) * INTEGRATION_ERROR_TOLERANCE) then err = error end if call object%append (n_it, n_calls, 0, integral, err, efficiency, 0._default,& & 0._default, chain_weights) call object%display_current (suppress) end subroutine integration_results_record_simple @ %def integration_results_record_simple @ Record extended results from integration pass. <>= procedure :: record_extended => integration_results_record_extended <>= subroutine integration_results_record_extended (object, n_it, n_calls,& & n_calls_valid, integral, error, efficiency, efficiency_pos,& & efficiency_neg, chain_weights, suppress) class(integration_results_t), intent(inout) :: object integer, intent(in) :: n_it, n_calls, n_calls_valid real(default), intent(in) :: integral, error, efficiency, efficiency_pos,& & efficiency_neg real(default), dimension(:), intent(in), optional :: chain_weights real(default) :: err logical, intent(in), optional :: suppress err = 0._default if (abs (error) >= abs (integral) * INTEGRATION_ERROR_TOLERANCE) then err = error end if call object%append (n_it, n_calls, n_calls_valid, integral, err, efficiency,& & efficiency_pos, efficiency_neg, chain_weights) call object%display_current (suppress) end subroutine integration_results_record_extended @ %def integration_results_record_extended @ Compute the average for all entries in the specified integration pass. The integrals are weighted w.r.t.\ their individual errors. The quoted error of the result is the expected error, computed from the weighted average of the given individual errors. This should be compared to the actual distribution of the results, from which we also can compute an error estimate if there is more than one iteration. The ratio of the distribution error and the averaged error, is the $\chi^2$ value. All error distributions are assumed Gaussian, of course. The $\chi^2$ value is a partial check for this assumption. If it is significantly greater than unity, there is something wrong with the individual errors. The efficiency returned is the one of the last entry in the integration pass. If any error vanishes, averaging by this algorithm would fail. In this case, we simply average the entries and use the deviations from this average (if any) to estimate the error. <>= type(integration_entry_t) function compute_average (entry, pass) & & result (result) type(integration_entry_t), dimension(:), intent(in) :: entry integer, intent(in) :: pass integer :: i logical, dimension(size(entry)) :: mask real(default), dimension(size(entry)) :: ivar real(default) :: sum_ivar, variance result%process_type = entry(1)%process_type result%pass = pass mask = entry%pass == pass .and. entry%process_type /= PRC_UNKNOWN result%it = maxval (entry%it, mask) result%n_it = count (mask) result%n_calls = sum (entry%n_calls, mask) result%n_calls_valid = sum (entry%n_calls_valid, mask) if (.not. any (mask .and. entry%error == 0)) then where (mask) ivar = 1 / entry%error ** 2 elsewhere ivar = 0 end where sum_ivar = sum (ivar, mask) variance = 0 if (sum_ivar /= 0) then variance = 1 / sum_ivar end if result%integral = sum (entry%integral * ivar, mask) * variance if (result%n_it > 1) then result%chi2 = & sum ((entry%integral - result%integral)**2 * ivar, mask) & / (result%n_it - 1) end if else if (result%n_it /= 0) then result%integral = sum (entry%integral, mask) / result%n_it variance = 0 if (result%n_it > 1) then variance = & sum ((entry%integral - result%integral)**2, mask) & / (result%n_it - 1) if (result%integral /= 0) then if (abs (variance / result%integral) & < 100 * epsilon (1._default)) then variance = 0 end if end if end if result%chi2 = variance / result%n_it end if result%error = sqrt (variance) result%efficiency = entry(last_index (mask))%efficiency result%efficiency_pos = entry(last_index (mask))%efficiency_pos result%efficiency_neg = entry(last_index (mask))%efficiency_neg contains integer function last_index (mask) result (index) logical, dimension(:), intent(in) :: mask integer :: i do i = size (mask), 1, -1 if (mask(i)) exit end do index = i end function last_index end function compute_average @ %def compute_average @ \subsection{Access results} Return true if the results object has entries. <>= procedure :: exist => integration_results_exist <>= function integration_results_exist (results) result (flag) logical :: flag class(integration_results_t), intent(in) :: results flag = results%n_pass > 0 end function integration_results_exist @ %def integration_results_exist @ Retrieve information from the results record. If [[last]] is set and true, take the last iteration. If [[it]] is set instead, take this iteration. If [[pass]] is set, take this average. If none is set, take the final average. If the result would be invalid, the entry is not assigned. Due to default initialization, this returns a null entry. <>= procedure :: get_entry => results_get_entry <>= function results_get_entry (results, last, it, pass) result (entry) class(integration_results_t), intent(in) :: results type(integration_entry_t) :: entry logical, intent(in), optional :: last integer, intent(in), optional :: it, pass if (present (last)) then if (allocated (results%entry) .and. results%n_it > 0) then entry = results%entry(results%n_it) else call error () end if else if (present (it)) then if (allocated (results%entry) .and. it > 0 .and. it <= results%n_it) then entry = results%entry(it) else call error () end if else if (present (pass)) then if (allocated (results%average) & .and. pass > 0 .and. pass <= results%n_pass) then entry = results%average (pass) else call error () end if else if (allocated (results%average) .and. results%n_pass > 0) then entry = results%average (results%n_pass) else call error () end if end if contains subroutine error () call msg_fatal ("Requested integration result is not available") end subroutine error end function results_get_entry @ %def results_get_entry @ The individual procedures. The [[results]] record should have the [[target]] attribute, but only locally within the function. <>= procedure :: get_n_calls => integration_results_get_n_calls procedure :: get_integral => integration_results_get_integral procedure :: get_error => integration_results_get_error procedure :: get_accuracy => integration_results_get_accuracy procedure :: get_chi2 => integration_results_get_chi2 procedure :: get_efficiency => integration_results_get_efficiency <>= function integration_results_get_n_calls (results, last, it, pass) & result (n_calls) class(integration_results_t), intent(in), target :: results integer :: n_calls logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) n_calls = entry%get_n_calls () end function integration_results_get_n_calls function integration_results_get_integral (results, last, it, pass) & result (integral) class(integration_results_t), intent(in), target :: results real(default) :: integral logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) integral = entry%get_integral () end function integration_results_get_integral function integration_results_get_error (results, last, it, pass) & result (error) class(integration_results_t), intent(in), target :: results real(default) :: error logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) error = entry%get_error () end function integration_results_get_error function integration_results_get_accuracy (results, last, it, pass) & result (accuracy) class(integration_results_t), intent(in), target :: results real(default) :: accuracy logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) accuracy = entry%get_accuracy () end function integration_results_get_accuracy function integration_results_get_chi2 (results, last, it, pass) & result (chi2) class(integration_results_t), intent(in), target :: results real(default) :: chi2 logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) chi2 = entry%get_chi2 () end function integration_results_get_chi2 function integration_results_get_efficiency (results, last, it, pass) & result (efficiency) class(integration_results_t), intent(in), target :: results real(default) :: efficiency logical, intent(in), optional :: last integer, intent(in), optional :: it, pass type(integration_entry_t) :: entry entry = results%get_entry (last, it, pass) efficiency = entry%get_efficiency () end function integration_results_get_efficiency @ %def integration_results_get_n_calls @ %def integration_results_get_integral @ %def integration_results_get_error @ %def integration_results_get_accuracy @ %def integration_results_get_chi2 @ %def integration_results_get_efficiency @ Return the last pass index and the index of the last iteration \emph{within} the last pass. The third routine returns the absolute index of the last iteration. <>= function integration_results_get_current_pass (results) result (pass) integer :: pass type(integration_results_t), intent(in) :: results pass = results%n_pass end function integration_results_get_current_pass function integration_results_get_current_it (results) result (it) integer :: it type(integration_results_t), intent(in) :: results it = 0 if (allocated (results%entry)) then it = count (results%entry(1:results%n_it)%pass == results%n_pass) end if end function integration_results_get_current_it function integration_results_get_last_it (results) result (it) integer :: it type(integration_results_t), intent(in) :: results it = results%n_it end function integration_results_get_last_it @ %def integration_results_get_current_pass @ %def integration_results_get_current_it @ %def integration_results_get_last_it @ Return the index of the best iteration (lowest accuracy value) within the current pass. If none qualifies, return zero. <>= function integration_results_get_best_it (results) result (it) integer :: it type(integration_results_t), intent(in) :: results integer :: i real(default) :: acc, acc_best acc_best = -1 it = 0 do i = 1, results%n_it if (results%entry(i)%pass == results%n_pass) then acc = integration_entry_get_accuracy (results%entry(i)) if (acc_best < 0 .or. acc <= acc_best) then acc_best = acc it = i end if end if end do end function integration_results_get_best_it @ %def integration_results_get_best_it @ Compute the MD5 sum by printing everything and checksumming the resulting file. <>= function integration_results_get_md5sum (results) result (md5sum_results) character(32) :: md5sum_results type(integration_results_t), intent(in) :: results integer :: u u = free_unit () open (unit = u, status = "scratch", action = "readwrite") call results%write_verbose (u) rewind (u) md5sum_results = md5sum (u) close (u) end function integration_results_get_md5sum @ %def integration_results_get_md5sum @ This is (ab)used to suppress numerical noise when integrating constant matrix elements. <>= procedure :: pacify => integration_results_pacify <>= subroutine integration_results_pacify (results, efficiency_reset) class(integration_results_t), intent(inout) :: results logical, intent(in), optional :: efficiency_reset integer :: i logical :: reset reset = .false. if (present (efficiency_reset)) reset = efficiency_reset if (allocated (results%entry)) then do i = 1, size (results%entry) call pacify (results%entry(i)%error, & results%entry(i)%integral * 1.E-9_default) if (reset) results%entry(i)%efficiency = 1 end do end if if (allocated (results%average)) then do i = 1, size (results%average) call pacify (results%average(i)%error, & results%average(i)%integral * 1.E-9_default) if (reset) results%average(i)%efficiency = 1 end do end if end subroutine integration_results_pacify @ %def integration_results_pacify @ <>= procedure :: record_correction => integration_results_record_correction <>= subroutine integration_results_record_correction (object, corr, err) class(integration_results_t), intent(inout) :: object real(default), intent(in) :: corr, err integer :: u u = given_output_unit () if (object%screen) then call object%write_hline (u) call msg_message ("NLO Correction: [O(alpha_s+1)/O(alpha_s)]") write(msg_buffer,'(1X,A1,F8.4,A4,F9.5,1X,A3)') '(', corr, ' +- ', err, ') %' call msg_message () end if end subroutine integration_results_record_correction @ %def integration_results_record_correction @ \subsection{Results display} Write a driver file for history visualization. The ratio of $y$ range over $y$ value must not become too small, otherwise we run into an arithmetic overflow in GAMELAN. 2\% appears to be safe. <>= real, parameter, public :: GML_MIN_RANGE_RATIO = 0.02 <>= public :: integration_results_write_driver <>= subroutine integration_results_write_driver (results, filename, eff_reset) type(integration_results_t), intent(inout) :: results type(string_t), intent(in) :: filename logical, intent(in), optional :: eff_reset type(string_t) :: file_tex integer :: unit integer :: n, i, n_pass, pass integer, dimension(:), allocatable :: ipass real(default) :: ymin, ymax, yavg, ydif, y0, y1 real(default), dimension(results%n_it) :: ymin_arr, ymax_arr logical :: reset file_tex = filename // ".tex" unit = free_unit () open (unit=unit, file=char(file_tex), action="write", status="replace") reset = .false.; if (present (eff_reset)) reset = eff_reset n = results%n_it n_pass = results%n_pass allocate (ipass (results%n_pass)) ipass(1) = 0 pass = 2 do i = 1, n-1 if (integration_entry_get_pass (results%entry(i)) & /= integration_entry_get_pass (results%entry(i+1))) then ipass(pass) = i pass = pass + 1 end if end do ymin_arr = integration_entry_get_integral (results%entry(:n)) & - integration_entry_get_error (results%entry(:n)) ymin = minval (ymin_arr) ymax_arr = integration_entry_get_integral (results%entry(:n)) & + integration_entry_get_error (results%entry(:n)) ymax = maxval (ymax_arr) yavg = (ymax + ymin) / 2 ydif = (ymax - ymin) if (ydif * 1.5 > GML_MIN_RANGE_RATIO * yavg) then y0 = yavg - ydif * 0.75 y1 = yavg + ydif * 0.75 else y0 = yavg * (1 - GML_MIN_RANGE_RATIO / 2) y1 = yavg * (1 + GML_MIN_RANGE_RATIO / 2) end if write (unit, "(A)") "\documentclass{article}" write (unit, "(A)") "\usepackage{a4wide}" write (unit, "(A)") "\usepackage{gamelan}" write (unit, "(A)") "\usepackage{amsmath}" write (unit, "(A)") "" write (unit, "(A)") "\begin{document}" write (unit, "(A)") "\begin{gmlfile}" write (unit, "(A)") "\section*{Integration Results Display}" write (unit, "(A)") "" write (unit, "(A)") "Process: \verb|" // char (filename) // "|" write (unit, "(A)") "" write (unit, "(A)") "\vspace*{2\baselineskip}" write (unit, "(A)") "\unitlength 1mm" write (unit, "(A)") "\begin{gmlcode}" write (unit, "(A)") " picture sym; sym = fshape (circle scaled 1mm)();" write (unit, "(A)") " color col.band; col.band = 0.9white;" write (unit, "(A)") " color col.eband; col.eband = 0.98white;" write (unit, "(A)") "\end{gmlcode}" write (unit, "(A)") "\begin{gmlgraph*}(130,180)[history]" write (unit, "(A)") " setup (linear, linear);" write (unit, "(A,I0,A)") " history.n_pass = ", n_pass, ";" write (unit, "(A,I0,A)") " history.n_it = ", n, ";" write (unit, "(A,A,A)") " history.y0 = #""", char (mp_format (y0)), """;" write (unit, "(A,A,A)") " history.y1 = #""", char (mp_format (y1)), """;" write (unit, "(A)") & " graphrange (#0.5, history.y0), (#(n+0.5), history.y1);" do pass = 1, n_pass write (unit, "(A,I0,A,I0,A)") & " history.pass[", pass, "] = ", ipass(pass), ";" write (unit, "(A,I0,A,A,A)") & " history.avg[", pass, "] = #""", & char (mp_format & (integration_entry_get_integral (results%average(pass)))), & """;" write (unit, "(A,I0,A,A,A)") & " history.err[", pass, "] = #""", & char (mp_format & (integration_entry_get_error (results%average(pass)))), & """;" write (unit, "(A,I0,A,A,A)") & " history.chi[", pass, "] = #""", & char (mp_format & (integration_entry_get_chi2 (results%average(pass)))), & """;" end do write (unit, "(A,I0,A,I0,A)") & " history.pass[", n_pass + 1, "] = ", n, ";" write (unit, "(A)") " for i = 1 upto history.n_pass:" write (unit, "(A)") " if history.chi[i] greater one:" write (unit, "(A)") " fill plot (" write (unit, "(A)") & " (#(history.pass[i] +.5), " & // "history.avg[i] minus history.err[i] times history.chi[i])," write (unit, "(A)") & " (#(history.pass[i+1]+.5), " & // "history.avg[i] minus history.err[i] times history.chi[i])," write (unit, "(A)") & " (#(history.pass[i+1]+.5), " & // "history.avg[i] plus history.err[i] times history.chi[i])," write (unit, "(A)") & " (#(history.pass[i] +.5), " & // "history.avg[i] plus history.err[i] times history.chi[i])" write (unit, "(A)") " ) withcolor col.eband fi;" write (unit, "(A)") " fill plot (" write (unit, "(A)") & " (#(history.pass[i] +.5), history.avg[i] minus history.err[i])," write (unit, "(A)") & " (#(history.pass[i+1]+.5), history.avg[i] minus history.err[i])," write (unit, "(A)") & " (#(history.pass[i+1]+.5), history.avg[i] plus history.err[i])," write (unit, "(A)") & " (#(history.pass[i] +.5), history.avg[i] plus history.err[i])" write (unit, "(A)") " ) withcolor col.band;" write (unit, "(A)") " draw plot (" write (unit, "(A)") & " (#(history.pass[i] +.5), history.avg[i])," write (unit, "(A)") & " (#(history.pass[i+1]+.5), history.avg[i])" write (unit, "(A)") " ) dashed evenly;" write (unit, "(A)") " endfor" write (unit, "(A)") " for i = 1 upto history.n_pass + 1:" write (unit, "(A)") " draw plot (" write (unit, "(A)") & " (#(history.pass[i]+.5), history.y0)," write (unit, "(A)") & " (#(history.pass[i]+.5), history.y1)" write (unit, "(A)") " ) dashed withdots;" write (unit, "(A)") " endfor" do i = 1, n write (unit, "(A,I0,A,A,A,A,A)") " plot (history) (#", & i, ", #""", & char (mp_format (integration_entry_get_integral (results%entry(i)))),& """) vbar #""", & char (mp_format (integration_entry_get_error (results%entry(i)))), & """;" end do write (unit, "(A)") " draw piecewise from (history) " & // "withsymbol sym;" write (unit, "(A)") " fullgrid.lr (5,20);" write (unit, "(A)") " standardgrid.bt (n);" write (unit, "(A)") " begingmleps ""Whizard-Logo.eps"";" write (unit, "(A)") " base := (120*unitlength,170*unitlength);" write (unit, "(A)") " height := 9.6*unitlength;" write (unit, "(A)") " width := 11.2*unitlength;" write (unit, "(A)") " endgmleps;" write (unit, "(A)") "\end{gmlgraph*}" write (unit, "(A)") "\end{gmlfile}" write (unit, "(A)") "\clearpage" write (unit, "(A)") "\begin{verbatim}" if (reset) then call results%pacify (reset) end if call integration_results_write (results, unit) write (unit, "(A)") "\end{verbatim}" write (unit, "(A)") "\end{document}" close (unit) end subroutine integration_results_write_driver @ %def integration_results_write_driver @ Call \LaTeX\ and Metapost for the history driver file, and convert to PS and PDF. <>= public :: integration_results_compile_driver <>= subroutine integration_results_compile_driver (results, filename, os_data) type(integration_results_t), intent(in) :: results type(string_t), intent(in) :: filename type(os_data_t), intent(in) :: os_data integer :: unit_dev, status type(string_t) :: file_tex, file_dvi, file_ps, file_pdf, file_mp type(string_t) :: setenv_tex, setenv_mp, pipe, pipe_dvi if (.not. os_data%event_analysis) then call msg_warning ("Skipping integration history display " & // "because latex or mpost is not available") return end if file_tex = filename // ".tex" file_dvi = filename // ".dvi" file_ps = filename // ".ps" file_pdf = filename // ".pdf" file_mp = filename // ".mp" call msg_message ("Creating integration history display "& // char (file_ps) // " and " // char (file_pdf)) BLOCK: do unit_dev = free_unit () open (file = "/dev/null", unit = unit_dev, & action = "write", iostat = status) if (status /= 0) then pipe = "" pipe_dvi = "" else pipe = " > /dev/null" pipe_dvi = " 2>/dev/null 1>/dev/null" end if close (unit_dev) if (os_data%whizard_texpath /= "") then setenv_tex = & "TEXINPUTS=" // os_data%whizard_texpath // ":$TEXINPUTS " setenv_mp = & "MPINPUTS=" // os_data%whizard_texpath // ":$MPINPUTS " else setenv_tex = "" setenv_mp = "" end if call os_system_call (setenv_tex // os_data%latex // " " // & file_tex // pipe, status) if (status /= 0) exit BLOCK if (os_data%gml /= "") then call os_system_call (setenv_mp // os_data%gml // " " // & file_mp // pipe, status) else call msg_error ("Could not use GAMELAN/MetaPOST.") exit BLOCK end if if (status /= 0) exit BLOCK call os_system_call (setenv_tex // os_data%latex // " " // & file_tex // pipe, status) if (status /= 0) exit BLOCK if (os_data%event_analysis_ps) then call os_system_call (os_data%dvips // " " // & file_dvi // pipe_dvi, status) if (status /= 0) exit BLOCK else call msg_warning ("Skipping PostScript generation because dvips " & // "is not available") exit BLOCK end if if (os_data%event_analysis_pdf) then call os_system_call (os_data%ps2pdf // " " // & file_ps, status) if (status /= 0) exit BLOCK else call msg_warning ("Skipping PDF generation because ps2pdf " & // "is not available") exit BLOCK end if exit BLOCK end do BLOCK if (status /= 0) then call msg_error ("Unable to compile integration history display") end if end subroutine integration_results_compile_driver @ %def integration_results_compile_driver @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[integration_results_ut.f90]]>>= <> module integration_results_ut use unit_tests use integration_results_uti <> <> contains <> end module integration_results_ut @ %def integration_results_ut @ <<[[integration_results_uti.f90]]>>= <> module integration_results_uti <> use integration_results <> <> contains <> end module integration_results_uti @ %def integration_results_ut @ API: driver for the unit tests below. <>= public :: integration_results_test <>= subroutine integration_results_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine integration_results_test @ %def integration_results_test @ \subsubsection{Integration entry} <>= call test (integration_results_1, "integration_results_1", & "record single line and write to log", & u, results) <>= public :: integration_results_1 <>= subroutine integration_results_1 (u) integer, intent(in) :: u type(integration_entry_t) :: entry write (u, "(A)") "* Test output: integration_results_1" write (u, "(A)") "* Purpose: record single entry and write to log" write (u, "(A)") write (u, "(A)") "* Write single line output" write (u, "(A)") entry = integration_entry_t ( & & process_type = 1, & & pass = 1, & & it = 1, & & n_it = 10, & & n_calls = 1000, & & n_calls_valid = 500, & & improved = .true., & & integral = 1.0_default, & & error = 0.5_default, & & efficiency = 0.25_default, & & efficiency_pos = 0.22_default, & & efficiency_neg = 0.03_default) call entry%write (u, 3) write (u, "(A)") write (u, "(A)") "* Test output end: integration_results_1" end subroutine integration_results_1 @ %def integration_results_1 @ <>= call test (integration_results_2, "integration_results_2", & "record single result and write to log", & u, results) <>= public :: integration_results_2 <>= subroutine integration_results_2 (u) integer, intent(in) :: u type(integration_results_t) :: results write (u, "(A)") "* Test output: integration_results_2" write (u, "(A)") "* Purpose: record single result and write to log" write (u, "(A)") write (u, "(A)") "* Write single line output" write (u, "(A)") call results%init (PRC_DECAY) call results%append (1, 250, 0, 1.0_default, 0.5_default, 0.25_default,& & 0._default, 0._default) call results%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: integration_results_2" end subroutine integration_results_2 @ %def integration_results_2 @ <>= call test (integration_results_3, "integration_results_3", & "initialize display and add/display each entry", & u, results) <>= public :: integration_results_3 <>= subroutine integration_results_3 (u) integer, intent(in) :: u type(integration_results_t) :: results write (u, "(A)") "* Test output: integration_results_2" write (u, "(A)") "* Purpose: intialize display, record three entries,& & display pass average and finalize display" write (u, "(A)") write (u, "(A)") "* Initialize display and add entry" write (u, "(A)") call results%init (PRC_DECAY) call results%set_verbosity (1) call results%display_init (screen = .false., unit = u) call results%new_pass () call results%record (1, 250, 1.0_default, 0.5_default, 0.25_default) call results%record (1, 250, 1.1_default, 0.5_default, 0.25_default) call results%record (1, 250, 0.9_default, 0.5_default, 0.25_default) write (u, "(A)") write (u, "(A)") "* Display pass" write (u, "(A)") call results%display_pass () write (u, "(A)") write (u, "(A)") "* Finalize displays" write (u, "(A)") call results%display_final () write (u, "(A)") write (u, "(A)") "* Test output end: integration_results_3" end subroutine integration_results_3 @ %def integration_results_3 @ <>= call test (integration_results_4, "integration_results_4", & "record extended results and display", & u, results) <>= public :: integration_results_4 <>= subroutine integration_results_4 (u) integer, intent(in) :: u type(integration_results_t) :: results write (u, "(A)") "* Test output: integration_results_4" write (u, "(A)") "* Purpose: record extended results and display with verbosity = 2" write (u, "(A)") write (u, "(A)") "* Initialize display and record extended result" write (u, "(A)") call results%init (PRC_DECAY) call results%set_verbosity (2) call results%display_init (screen = .false., unit = u) call results%new_pass () call results%record (1, 250, 150, 1.0_default, 0.5_default, 0.25_default,& & 0.22_default, 0.03_default) call results%record (1, 250, 180, 1.1_default, 0.5_default, 0.25_default,& & 0.23_default, 0.02_default) call results%record (1, 250, 130, 0.9_default, 0.5_default, 0.25_default,& & 0.25_default, 0.00_default) write (u, "(A)") write (u, "(A)") "* Display pass" write (u, "(A)") call results%display_pass () write (u, "(A)") write (u, "(A)") "* Finalize displays" write (u, "(A)") call results%display_final () write (u, "(A)") write (u, "(A)") "* Test output end: integration_results_4" end subroutine integration_results_4 @ %def integration_results_4 @ <>= call test (integration_results_5, "integration_results_5", & "record extended results and display", & u, results) <>= public :: integration_results_5 <>= subroutine integration_results_5 (u) integer, intent(in) :: u type(integration_results_t) :: results write (u, "(A)") "* Test output: integration_results_5" write (u, "(A)") "* Purpose: record extended results and display with verbosity = 3" write (u, "(A)") write (u, "(A)") "* Initialize display and record extended result" write (u, "(A)") call results%init (PRC_DECAY) call results%set_verbosity (3) call results%display_init (screen = .false., unit = u) call results%new_pass () call results%record (1, 250, 150, 1.0_default, 0.5_default, 0.25_default,& & 0.22_default, 0.03_default) call results%record (1, 250, 180, 1.1_default, 0.5_default, 0.25_default,& & 0.23_default, 0.02_default) call results%record (1, 250, 130, 0.9_default, 0.5_default, 0.25_default,& & 0.25_default, 0.00_default) call results%display_pass () call results%display_final () write (u, "(A)") write (u, "(A)") "* Test output end: integration_results_5" end subroutine integration_results_5 @ %def integration_results_5 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Dummy integrator} This implementation acts as a placeholder for cases where no integration or event generation is required at all. <<[[mci_none.f90]]>>= <> module mci_none <> use io_units, only: given_output_unit use diagnostics, only: msg_message, msg_fatal use phs_base, only: phs_channel_t use mci_base <> <> <> contains <> end module mci_none @ %def mci_none @ \subsection{Integrator} The object contains the methods for integration and event generation. For the actual work and data storage, it spawns an instance object. After an integration pass, we update the [[max]] parameter to indicate the maximum absolute value of the integrand that the integrator encountered. This is required for event generation. <>= public :: mci_none_t <>= type, extends (mci_t) :: mci_none_t contains <> end type mci_none_t @ %def mci_t @ Finalizer: no-op. <>= procedure :: final => mci_none_final <>= subroutine mci_none_final (object) class(mci_none_t), intent(inout) :: object end subroutine mci_none_final @ %def mci_none_final @ Output. <>= procedure :: write => mci_none_write <>= subroutine mci_none_write (object, unit, pacify, md5sum_version) class(mci_none_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Integrator: non-functional dummy" end subroutine mci_none_write @ %def mci_none_write @ Startup message: short version. <>= procedure :: startup_message => mci_none_startup_message <>= subroutine mci_none_startup_message (mci, unit, n_calls) class(mci_none_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls call msg_message ("Integrator: none") end subroutine mci_none_startup_message @ %def mci_none_startup_message @ Log entry: just headline. <>= procedure :: write_log_entry => mci_none_write_log_entry <>= subroutine mci_none_write_log_entry (mci, u) class(mci_none_t), intent(in) :: mci integer, intent(in) :: u write (u, "(1x,A)") "MC Integrator is none (no-op)" end subroutine mci_none_write_log_entry @ %def mci_none_write_log_entry @ MD5 sum: nothing. <>= procedure :: compute_md5sum => mci_none_compute_md5sum <>= subroutine mci_none_compute_md5sum (mci, pacify) class(mci_none_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_none_compute_md5sum @ %def mci_none_compute_md5sum @ The number of channels must be one. <>= procedure :: set_dimensions => mci_none_set_dimensions <>= subroutine mci_none_set_dimensions (mci, n_dim, n_channel) class(mci_none_t), intent(inout) :: mci integer, intent(in) :: n_dim integer, intent(in) :: n_channel if (n_channel == 1) then mci%n_channel = n_channel mci%n_dim = n_dim allocate (mci%dim_is_binned (mci%n_dim)) mci%dim_is_binned = .true. mci%n_dim_binned = count (mci%dim_is_binned) allocate (mci%n_bin (mci%n_dim)) mci%n_bin = 0 else call msg_fatal ("Attempt to initialize single-channel integrator & &for multiple channels") end if end subroutine mci_none_set_dimensions @ %def mci_none_set_dimensions @ Required by API. <>= procedure :: declare_flat_dimensions => mci_none_ignore_flat_dimensions <>= subroutine mci_none_ignore_flat_dimensions (mci, dim_flat) class(mci_none_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_none_ignore_flat_dimensions @ %def mci_none_ignore_flat_dimensions @ Required by API. <>= procedure :: declare_equivalences => mci_none_ignore_equivalences <>= subroutine mci_none_ignore_equivalences (mci, channel, dim_offset) class(mci_none_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_none_ignore_equivalences @ %def mci_none_ignore_equivalences @ Allocate instance with matching type. <>= procedure :: allocate_instance => mci_none_allocate_instance <>= subroutine mci_none_allocate_instance (mci, mci_instance) class(mci_none_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance allocate (mci_none_instance_t :: mci_instance) end subroutine mci_none_allocate_instance @ %def mci_none_allocate_instance @ Integrate. This must not be called at all. <>= procedure :: integrate => mci_none_integrate <>= subroutine mci_none_integrate (mci, instance, sampler, n_it, n_calls, & results, pacify) class(mci_none_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: pacify class(mci_results_t), intent(inout), optional :: results call msg_fatal ("Integration: attempt to integrate with the 'mci_none' method") end subroutine mci_none_integrate @ %def mci_none_integrate @ Simulation initializer and finalizer: nothing to do here. <>= procedure :: prepare_simulation => mci_none_ignore_prepare_simulation <>= subroutine mci_none_ignore_prepare_simulation (mci) class(mci_none_t), intent(inout) :: mci end subroutine mci_none_ignore_prepare_simulation @ %def mci_none_ignore_prepare_simulation @ Generate events, must not be called. <>= procedure :: generate_weighted_event => mci_none_generate_no_event procedure :: generate_unweighted_event => mci_none_generate_no_event <>= subroutine mci_none_generate_no_event (mci, instance, sampler) class(mci_none_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler call msg_fatal ("Integration: attempt to generate event with the 'mci_none' method") end subroutine mci_none_generate_no_event @ %def mci_none_generate_no_event @ Rebuild an event, no-op. <>= procedure :: rebuild_event => mci_none_rebuild_event <>= subroutine mci_none_rebuild_event (mci, instance, sampler, state) class(mci_none_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state end subroutine mci_none_rebuild_event @ %def mci_none_rebuild_event @ \subsection{Integrator instance} Covering the case of flat dimensions, we store a complete [[x]] array. This is filled when generating events. <>= public :: mci_none_instance_t <>= type, extends (mci_instance_t) :: mci_none_instance_t contains <> end type mci_none_instance_t @ %def mci_none_instance_t @ Output. <>= procedure :: write => mci_none_instance_write <>= subroutine mci_none_instance_write (object, unit, pacify) class(mci_none_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Integrator instance: non-functional dummy" end subroutine mci_none_instance_write @ %def mci_none_instance_write @ The finalizer is empty. <>= procedure :: final => mci_none_instance_final <>= subroutine mci_none_instance_final (object) class(mci_none_instance_t), intent(inout) :: object end subroutine mci_none_instance_final @ %def mci_none_instance_final @ Initializer, empty. <>= procedure :: init => mci_none_instance_init <>= subroutine mci_none_instance_init (mci_instance, mci) class(mci_none_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci end subroutine mci_none_instance_init @ %def mci_none_instance_init @ Copy the stored extrema of the integrand in the instance record. <>= procedure :: get_max => mci_none_instance_get_max <>= subroutine mci_none_instance_get_max (instance) class(mci_none_instance_t), intent(inout) :: instance associate (mci => instance%mci) if (mci%max_known) then instance%max_known = .true. instance%max = mci%max instance%min = mci%min instance%max_abs = mci%max_abs instance%min_abs = mci%min_abs end if end associate end subroutine mci_none_instance_get_max @ %def mci_none_instance_get_max @ Reverse operations: recall the extrema, but only if they are wider than the extrema already stored in the configuration. Also recalculate the efficiency value. <>= procedure :: set_max => mci_none_instance_set_max <>= subroutine mci_none_instance_set_max (instance) class(mci_none_instance_t), intent(inout) :: instance associate (mci => instance%mci) if (instance%max_known) then if (mci%max_known) then mci%max = max (mci%max, instance%max) mci%min = min (mci%min, instance%min) mci%max_abs = max (mci%max_abs, instance%max_abs) mci%min_abs = min (mci%min_abs, instance%min_abs) else mci%max = instance%max mci%min = instance%min mci%max_abs = instance%max_abs mci%min_abs = instance%min_abs mci%max_known = .true. end if if (mci%max_abs /= 0) then if (mci%integral_neg == 0) then mci%efficiency = mci%integral / mci%max_abs mci%efficiency_known = .true. else if (mci%n_calls /= 0) then mci%efficiency = & (mci%integral_pos - mci%integral_neg) / mci%max_abs mci%efficiency_known = .true. end if end if end if end associate end subroutine mci_none_instance_set_max @ %def mci_none_instance_set_max @ The weight cannot be computed. <>= procedure :: compute_weight => mci_none_instance_compute_weight <>= subroutine mci_none_instance_compute_weight (mci, c) class(mci_none_instance_t), intent(inout) :: mci integer, intent(in) :: c call msg_fatal ("Integration: attempt to compute weight with the 'mci_none' method") end subroutine mci_none_instance_compute_weight @ %def mci_none_instance_compute_weight @ Record the integrand, no-op. <>= procedure :: record_integrand => mci_none_instance_record_integrand <>= subroutine mci_none_instance_record_integrand (mci, integrand) class(mci_none_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand end subroutine mci_none_instance_record_integrand @ %def mci_none_instance_record_integrand @ No-op. <>= procedure :: init_simulation => mci_none_instance_init_simulation procedure :: final_simulation => mci_none_instance_final_simulation <>= subroutine mci_none_instance_init_simulation (instance, safety_factor) class(mci_none_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor end subroutine mci_none_instance_init_simulation subroutine mci_none_instance_final_simulation (instance) class(mci_none_instance_t), intent(inout) :: instance end subroutine mci_none_instance_final_simulation @ %def mci_none_instance_init_simulation @ %def mci_none_instance_final_simulation @ Return excess weight for the current event: return zero, just in case. <>= procedure :: get_event_excess => mci_none_instance_get_event_excess <>= function mci_none_instance_get_event_excess (mci) result (excess) class(mci_none_instance_t), intent(in) :: mci real(default) :: excess excess = 0 end function mci_none_instance_get_event_excess @ %def mci_none_instance_get_event_excess @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[mci_none_ut.f90]]>>= <> module mci_none_ut use unit_tests use mci_none_uti <> <> contains <> end module mci_none_ut @ %def mci_none_ut @ <<[[mci_none_uti.f90]]>>= <> module mci_none_uti use mci_base use mci_none <> <> <> contains <> end module mci_none_uti @ %def mci_none_ut @ API: driver for the unit tests below. <>= public :: mci_none_test <>= subroutine mci_none_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine mci_none_test @ %def mci_none_test @ \subsubsection{Trivial sanity check} Construct an integrator and display it. <>= call test (mci_none_1, "mci_none_1", & "dummy integrator", & u, results) <>= public :: mci_none_1 <>= subroutine mci_none_1 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_none_1" write (u, "(A)") "* Purpose: display mci configuration" write (u, "(A)") write (u, "(A)") "* Allocate integrator" write (u, "(A)") allocate (mci_none_t :: mci) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) call mci_instance%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_none_1" end subroutine mci_none_1 @ %def mci_none_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Simple midpoint integration} This is a most simple implementation of an integrator. The algorithm is the straightforward multi-dimensional midpoint rule, i.e., the integration hypercube is binned uniformly, the integrand is evaluated at the midpoints of each bin, and the result is the average. The binning is equivalent for all integration dimensions. This rule is accurate to the order $h^2$, where $h$ is the bin width. Given that $h=N^{-1/d}$, where $d$ is the integration dimension and $N$ is the total number of sampling points, we get a relative error of order $N^{-2/d}$. This is superior to MC integration if $d<4$, and equivalent if $d=4$. It is not worse than higher-order formulas (such as Gauss integration) if the integrand is not smooth, e.g., if it contains cuts. The integrator is specifically single-channel. However, we do not limit the dimension. <<[[mci_midpoint.f90]]>>= <> module mci_midpoint <> use io_units use diagnostics use phs_base use mci_base <> <> <> contains <> end module mci_midpoint @ %def mci_midpoint @ \subsection{Integrator} The object contains the methods for integration and event generation. For the actual work and data storage, it spawns an instance object. After an integration pass, we update the [[max]] parameter to indicate the maximum absolute value of the integrand that the integrator encountered. This is required for event generation. <>= public :: mci_midpoint_t <>= type, extends (mci_t) :: mci_midpoint_t integer :: n_dim_binned = 0 logical, dimension(:), allocatable :: dim_is_binned logical :: calls_known = .false. integer :: n_calls = 0 integer :: n_calls_pos = 0 integer :: n_calls_nul = 0 integer :: n_calls_neg = 0 real(default) :: integral_pos = 0 real(default) :: integral_neg = 0 integer, dimension(:), allocatable :: n_bin logical :: max_known = .false. real(default) :: max = 0 real(default) :: min = 0 real(default) :: max_abs = 0 real(default) :: min_abs = 0 contains <> end type mci_midpoint_t @ %def mci_t @ Finalizer: base version is sufficient <>= procedure :: final => mci_midpoint_final <>= subroutine mci_midpoint_final (object) class(mci_midpoint_t), intent(inout) :: object call object%base_final () end subroutine mci_midpoint_final @ %def mci_midpoint_final @ Output. <>= procedure :: write => mci_midpoint_write <>= subroutine mci_midpoint_write (object, unit, pacify, md5sum_version) class(mci_midpoint_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "Single-channel midpoint rule integrator:" call object%base_write (u, pacify, md5sum_version) if (object%n_dim_binned < object%n_dim) then write (u, "(3x,A,99(1x,I0))") "Flat dimensions =", & pack ([(i, i = 1, object%n_dim)], mask = .not. object%dim_is_binned) write (u, "(3x,A,I0)") "Number of binned dim = ", object%n_dim_binned end if if (object%calls_known) then write (u, "(3x,A,99(1x,I0))") "Number of bins =", object%n_bin write (u, "(3x,A,I0)") "Number of calls = ", object%n_calls if (object%n_calls_pos /= object%n_calls) then write (u, "(3x,A,I0)") " positive value = ", object%n_calls_pos write (u, "(3x,A,I0)") " zero value = ", object%n_calls_nul write (u, "(3x,A,I0)") " negative value = ", object%n_calls_neg write (u, "(3x,A,ES17.10)") & "Integral (pos. part) = ", object%integral_pos write (u, "(3x,A,ES17.10)") & "Integral (neg. part) = ", object%integral_neg end if end if if (object%max_known) then write (u, "(3x,A,ES17.10)") "Maximum of integrand = ", object%max write (u, "(3x,A,ES17.10)") "Minimum of integrand = ", object%min if (object%min /= object%min_abs) then write (u, "(3x,A,ES17.10)") "Maximum (abs. value) = ", object%max_abs write (u, "(3x,A,ES17.10)") "Minimum (abs. value) = ", object%min_abs end if end if if (allocated (object%rng)) call object%rng%write (u) end subroutine mci_midpoint_write @ %def mci_midpoint_write @ Startup message: short version. <>= procedure :: startup_message => mci_midpoint_startup_message <>= subroutine mci_midpoint_startup_message (mci, unit, n_calls) class(mci_midpoint_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls call mci%base_startup_message (unit = unit, n_calls = n_calls) if (mci%n_dim_binned < mci%n_dim) then write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Integrator: Midpoint rule:", & mci%n_dim_binned, "binned dimensions" else write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Integrator: Midpoint rule" end if call msg_message (unit = unit) end subroutine mci_midpoint_startup_message @ %def mci_midpoint_startup_message @ Log entry: just headline. <>= procedure :: write_log_entry => mci_midpoint_write_log_entry <>= subroutine mci_midpoint_write_log_entry (mci, u) class(mci_midpoint_t), intent(in) :: mci integer, intent(in) :: u write (u, "(1x,A)") "MC Integrator is Midpoint rule" end subroutine mci_midpoint_write_log_entry @ %def mci_midpoint_write_log_entry @ MD5 sum: nothing. <>= procedure :: compute_md5sum => mci_midpoint_compute_md5sum <>= subroutine mci_midpoint_compute_md5sum (mci, pacify) class(mci_midpoint_t), intent(inout) :: mci logical, intent(in), optional :: pacify end subroutine mci_midpoint_compute_md5sum @ %def mci_midpoint_compute_md5sum @ The number of channels must be one. <>= procedure :: set_dimensions => mci_midpoint_set_dimensions <>= subroutine mci_midpoint_set_dimensions (mci, n_dim, n_channel) class(mci_midpoint_t), intent(inout) :: mci integer, intent(in) :: n_dim integer, intent(in) :: n_channel if (n_channel == 1) then mci%n_channel = n_channel mci%n_dim = n_dim allocate (mci%dim_is_binned (mci%n_dim)) mci%dim_is_binned = .true. mci%n_dim_binned = count (mci%dim_is_binned) allocate (mci%n_bin (mci%n_dim)) mci%n_bin = 0 else call msg_fatal ("Attempt to initialize single-channel integrator & &for multiple channels") end if end subroutine mci_midpoint_set_dimensions @ %def mci_midpoint_set_dimensions @ Declare particular dimensions as flat. These dimensions will not be binned. <>= procedure :: declare_flat_dimensions => mci_midpoint_declare_flat_dimensions <>= subroutine mci_midpoint_declare_flat_dimensions (mci, dim_flat) class(mci_midpoint_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat integer :: d mci%n_dim_binned = mci%n_dim - size (dim_flat) do d = 1, size (dim_flat) mci%dim_is_binned(dim_flat(d)) = .false. end do mci%n_dim_binned = count (mci%dim_is_binned) end subroutine mci_midpoint_declare_flat_dimensions @ %def mci_midpoint_declare_flat_dimensions @ Declare particular channels as equivalent. This has no effect. <>= procedure :: declare_equivalences => mci_midpoint_ignore_equivalences <>= subroutine mci_midpoint_ignore_equivalences (mci, channel, dim_offset) class(mci_midpoint_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset end subroutine mci_midpoint_ignore_equivalences @ %def mci_midpoint_ignore_equivalences @ Allocate instance with matching type. <>= procedure :: allocate_instance => mci_midpoint_allocate_instance <>= subroutine mci_midpoint_allocate_instance (mci, mci_instance) class(mci_midpoint_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance allocate (mci_midpoint_instance_t :: mci_instance) end subroutine mci_midpoint_allocate_instance @ %def mci_midpoint_allocate_instance @ Integrate. The number of dimensions is arbitrary. We make sure that the number of calls is evenly distributed among the dimensions. The actual number of calls will typically be smaller than the requested number, but never smaller than 1. The sampling over a variable number of dimensions implies a variable number of nested loops. We implement this by a recursive subroutine, one loop in each recursion level. The number of iterations [[n_it]] is ignored. Also, the error is set to zero in the current implementation. With this integrator, we allow the calculation to abort immediately when forced by a signal. There is no state that we can save, hence we do not catch an interrupt. <>= procedure :: integrate => mci_midpoint_integrate <>= subroutine mci_midpoint_integrate (mci, instance, sampler, n_it, n_calls, & results, pacify) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls logical, intent(in), optional :: pacify class(mci_results_t), intent(inout), optional :: results real(default), dimension(:), allocatable :: x real(default) :: integral, integral_pos, integral_neg integer :: n_bin select type (instance) type is (mci_midpoint_instance_t) allocate (x (mci%n_dim)) integral = 0 integral_pos = 0 integral_neg = 0 select case (mci%n_dim_binned) case (1) n_bin = n_calls case (2:) n_bin = max (int (n_calls ** (1. / mci%n_dim_binned)), 1) end select where (mci%dim_is_binned) mci%n_bin = n_bin elsewhere mci%n_bin = 1 end where mci%n_calls = product (mci%n_bin) mci%n_calls_pos = 0 mci%n_calls_nul = 0 mci%n_calls_neg = 0 mci%calls_known = .true. call sample_dim (mci%n_dim) mci%integral = integral / mci%n_calls mci%integral_pos = integral_pos / mci%n_calls mci%integral_neg = integral_neg / mci%n_calls mci%integral_known = .true. call instance%set_max () if (present (results)) then call results%record (1, mci%n_calls, & mci%integral, mci%error, mci%efficiency) end if end select contains recursive subroutine sample_dim (d) integer, intent(in) :: d integer :: i real(default) :: value do i = 1, mci%n_bin(d) x(d) = (i - 0.5_default) / mci%n_bin(d) if (d > 1) then call sample_dim (d - 1) else if (signal_is_pending ()) return call instance%evaluate (sampler, 1, x) value = instance%get_value () if (value > 0) then mci%n_calls_pos = mci%n_calls_pos + 1 integral = integral + value integral_pos = integral_pos + value else if (value == 0) then mci%n_calls_nul = mci%n_calls_nul + 1 else mci%n_calls_neg = mci%n_calls_neg + 1 integral = integral + value integral_neg = integral_neg + value end if end if end do end subroutine sample_dim end subroutine mci_midpoint_integrate @ %def mci_midpoint_integrate @ Simulation initializer and finalizer: nothing to do here. <>= procedure :: prepare_simulation => mci_midpoint_ignore_prepare_simulation <>= subroutine mci_midpoint_ignore_prepare_simulation (mci) class(mci_midpoint_t), intent(inout) :: mci end subroutine mci_midpoint_ignore_prepare_simulation @ %def mci_midpoint_ignore_prepare_simulation @ Generate weighted event. <>= procedure :: generate_weighted_event => mci_midpoint_generate_weighted_event <>= subroutine mci_midpoint_generate_weighted_event (mci, instance, sampler) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler real(default), dimension(mci%n_dim) :: x select type (instance) type is (mci_midpoint_instance_t) call mci%rng%generate (x) call instance%evaluate (sampler, 1, x) instance%excess_weight = 0 end select end subroutine mci_midpoint_generate_weighted_event @ %def mci_midpoint_generate_weighted_event @ For unweighted events, we generate weighted events and apply a simple rejection step to the relative event weight, until an event passes. Note that we use the [[max_abs]] value stored in the configuration record, not the one stored in the instance. The latter may change during event generation. After an event generation pass is over, we may update the value for a subsequent pass. <>= procedure :: generate_unweighted_event => & mci_midpoint_generate_unweighted_event <>= subroutine mci_midpoint_generate_unweighted_event (mci, instance, sampler) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler real(default) :: x, norm, int select type (instance) type is (mci_midpoint_instance_t) if (mci%max_known .and. mci%max_abs > 0) then norm = abs (mci%max_abs * instance%safety_factor) REJECTION: do call mci%generate_weighted_event (instance, sampler) if (sampler%is_valid ()) then call mci%rng%generate (x) int = abs (instance%integrand) if (x * norm <= int) then if (norm > 0 .and. norm < int) then instance%excess_weight = int / norm - 1 end if exit REJECTION end if end if if (signal_is_pending ()) return end do REJECTION else call msg_fatal ("Unweighted event generation: & &maximum of integrand is zero or unknown") end if end select end subroutine mci_midpoint_generate_unweighted_event @ %def mci_midpoint_generate_unweighted_event @ Rebuild an event, using the [[state]] input. <>= procedure :: rebuild_event => mci_midpoint_rebuild_event <>= subroutine mci_midpoint_rebuild_event (mci, instance, sampler, state) class(mci_midpoint_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state select type (instance) type is (mci_midpoint_instance_t) call instance%recall (sampler, state) end select end subroutine mci_midpoint_rebuild_event @ %def mci_midpoint_rebuild_event @ \subsection{Integrator instance} Covering the case of flat dimensions, we store a complete [[x]] array. This is filled when generating events. <>= public :: mci_midpoint_instance_t <>= type, extends (mci_instance_t) :: mci_midpoint_instance_t type(mci_midpoint_t), pointer :: mci => null () logical :: max_known = .false. real(default) :: max = 0 real(default) :: min = 0 real(default) :: max_abs = 0 real(default) :: min_abs = 0 real(default) :: safety_factor = 1 real(default) :: excess_weight = 0 contains <> end type mci_midpoint_instance_t @ %def mci_midpoint_instance_t @ Output. <>= procedure :: write => mci_midpoint_instance_write <>= subroutine mci_midpoint_instance_write (object, unit, pacify) class(mci_midpoint_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u u = given_output_unit (unit) write (u, "(1x,A,9(1x,F12.10))") "x =", object%x(:,1) write (u, "(1x,A,ES19.12)") "Integrand = ", object%integrand write (u, "(1x,A,ES19.12)") "Weight = ", object%mci_weight if (object%safety_factor /= 1) then write (u, "(1x,A,ES19.12)") "Safety f = ", object%safety_factor end if if (object%excess_weight /= 0) then write (u, "(1x,A,ES19.12)") "Excess = ", object%excess_weight end if if (object%max_known) then write (u, "(1x,A,ES19.12)") "Maximum = ", object%max write (u, "(1x,A,ES19.12)") "Minimum = ", object%min if (object%min /= object%min_abs) then write (u, "(1x,A,ES19.12)") "Max.(abs) = ", object%max_abs write (u, "(1x,A,ES19.12)") "Min.(abs) = ", object%min_abs end if end if end subroutine mci_midpoint_instance_write @ %def mci_midpoint_instance_write @ The finalizer is empty. <>= procedure :: final => mci_midpoint_instance_final <>= subroutine mci_midpoint_instance_final (object) class(mci_midpoint_instance_t), intent(inout) :: object end subroutine mci_midpoint_instance_final @ %def mci_midpoint_instance_final @ Initializer. <>= procedure :: init => mci_midpoint_instance_init <>= subroutine mci_midpoint_instance_init (mci_instance, mci) class(mci_midpoint_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci call mci_instance%base_init (mci) select type (mci) type is (mci_midpoint_t) mci_instance%mci => mci call mci_instance%get_max () mci_instance%selected_channel = 1 end select end subroutine mci_midpoint_instance_init @ %def mci_midpoint_instance_init @ Copy the stored extrema of the integrand in the instance record. <>= procedure :: get_max => mci_midpoint_instance_get_max <>= subroutine mci_midpoint_instance_get_max (instance) class(mci_midpoint_instance_t), intent(inout) :: instance associate (mci => instance%mci) if (mci%max_known) then instance%max_known = .true. instance%max = mci%max instance%min = mci%min instance%max_abs = mci%max_abs instance%min_abs = mci%min_abs end if end associate end subroutine mci_midpoint_instance_get_max @ %def mci_midpoint_instance_get_max @ Reverse operations: recall the extrema, but only if they are wider than the extrema already stored in the configuration. Also recalculate the efficiency value. <>= procedure :: set_max => mci_midpoint_instance_set_max <>= subroutine mci_midpoint_instance_set_max (instance) class(mci_midpoint_instance_t), intent(inout) :: instance associate (mci => instance%mci) if (instance%max_known) then if (mci%max_known) then mci%max = max (mci%max, instance%max) mci%min = min (mci%min, instance%min) mci%max_abs = max (mci%max_abs, instance%max_abs) mci%min_abs = min (mci%min_abs, instance%min_abs) else mci%max = instance%max mci%min = instance%min mci%max_abs = instance%max_abs mci%min_abs = instance%min_abs mci%max_known = .true. end if if (mci%max_abs /= 0) then if (mci%integral_neg == 0) then mci%efficiency = mci%integral / mci%max_abs mci%efficiency_known = .true. else if (mci%n_calls /= 0) then mci%efficiency = & (mci%integral_pos - mci%integral_neg) / mci%max_abs mci%efficiency_known = .true. end if end if end if end associate end subroutine mci_midpoint_instance_set_max @ %def mci_midpoint_instance_set_max @ The weight is the Jacobian of the mapping for the only channel. <>= procedure :: compute_weight => mci_midpoint_instance_compute_weight <>= subroutine mci_midpoint_instance_compute_weight (mci, c) class(mci_midpoint_instance_t), intent(inout) :: mci integer, intent(in) :: c select case (c) case (1) mci%mci_weight = mci%f(1) case default call msg_fatal ("MCI midpoint integrator: only single channel supported") end select end subroutine mci_midpoint_instance_compute_weight @ %def mci_midpoint_instance_compute_weight @ Record the integrand. Update stored values for maximum and minimum. <>= procedure :: record_integrand => mci_midpoint_instance_record_integrand <>= subroutine mci_midpoint_instance_record_integrand (mci, integrand) class(mci_midpoint_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand mci%integrand = integrand if (mci%max_known) then mci%max = max (mci%max, integrand) mci%min = min (mci%min, integrand) mci%max_abs = max (mci%max_abs, abs (integrand)) mci%min_abs = min (mci%min_abs, abs (integrand)) else mci%max = integrand mci%min = integrand mci%max_abs = abs (integrand) mci%min_abs = abs (integrand) mci%max_known = .true. end if end subroutine mci_midpoint_instance_record_integrand @ %def mci_midpoint_instance_record_integrand @ We store the safety factor, otherwise nothing to do here. <>= procedure :: init_simulation => mci_midpoint_instance_init_simulation procedure :: final_simulation => mci_midpoint_instance_final_simulation <>= subroutine mci_midpoint_instance_init_simulation (instance, safety_factor) class(mci_midpoint_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor if (present (safety_factor)) instance%safety_factor = safety_factor end subroutine mci_midpoint_instance_init_simulation subroutine mci_midpoint_instance_final_simulation (instance) class(mci_midpoint_instance_t), intent(inout) :: instance end subroutine mci_midpoint_instance_final_simulation @ %def mci_midpoint_instance_init_simulation @ %def mci_midpoint_instance_final_simulation @ Return excess weight for the current event. <>= procedure :: get_event_excess => mci_midpoint_instance_get_event_excess <>= function mci_midpoint_instance_get_event_excess (mci) result (excess) class(mci_midpoint_instance_t), intent(in) :: mci real(default) :: excess excess = mci%excess_weight end function mci_midpoint_instance_get_event_excess @ %def mci_midpoint_instance_get_event_excess @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[mci_midpoint_ut.f90]]>>= <> module mci_midpoint_ut use unit_tests use mci_midpoint_uti <> <> contains <> end module mci_midpoint_ut @ %def mci_midpoint_ut @ <<[[mci_midpoint_uti.f90]]>>= <> module mci_midpoint_uti <> use io_units use rng_base use mci_base use mci_midpoint use rng_base_ut, only: rng_test_t <> <> <> contains <> end module mci_midpoint_uti @ %def mci_midpoint_ut @ API: driver for the unit tests below. <>= public :: mci_midpoint_test <>= subroutine mci_midpoint_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine mci_midpoint_test @ %def mci_midpoint_test @ \subsubsection{Test sampler} A test sampler object should implement a function with known integral that we can use to check the integrator. This is the function $f(x) = 3 x^2$ with integral $\int_0^1 f(x)\,dx=1$ and maximum $f(1)=3$. If the integration dimension is greater than one, the function is extended as a constant in the other dimension(s). Mimicking the behavior of a process object, we store the argument and result inside the sampler, so we can [[fetch]] results. <>= type, extends (mci_sampler_t) :: test_sampler_1_t real(default), dimension(:), allocatable :: x real(default) :: val contains <> end type test_sampler_1_t @ %def test_sampler_1_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure :: write => test_sampler_1_write <>= subroutine test_sampler_1_write (object, unit, testflag) class(test_sampler_1_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Test sampler: f(x) = 3 x^2" end subroutine test_sampler_1_write @ %def test_sampler_1_write @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_1_evaluate <>= subroutine test_sampler_1_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in sampler%val = 3 * x_in(1) ** 2 call sampler%fetch (val, x, f) end subroutine test_sampler_1_evaluate @ %def test_sampler_1_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_1_is_valid <>= function test_sampler_1_is_valid (sampler) result (valid) class(test_sampler_1_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_1_is_valid @ %def test_sampler_1_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_1_rebuild <>= subroutine test_sampler_1_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in sampler%val = val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_rebuild @ %def test_sampler_1_rebuild @ Extract the results. <>= procedure :: fetch => test_sampler_1_fetch <>= subroutine test_sampler_1_fetch (sampler, val, x, f) class(test_sampler_1_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_fetch @ %def test_sampler_1_fetch @ This is the function $f(x) = 3 x^2 + 2 y$ with integral $\int_0^1 f(x,y)\,dx\,dy=2$ and maximum $f(1)=5$. <>= type, extends (mci_sampler_t) :: test_sampler_2_t real(default) :: val real(default), dimension(2) :: x contains <> end type test_sampler_2_t @ %def test_sampler_2_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure :: write => test_sampler_2_write <>= subroutine test_sampler_2_write (object, unit, testflag) class(test_sampler_2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Test sampler: f(x) = 3 x^2 + 2 y" end subroutine test_sampler_2_write @ %def test_sampler_2_write @ Evaluate: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_2_evaluate <>= subroutine test_sampler_2_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f sampler%x = x_in sampler%val = 3 * x_in(1) ** 2 + 2 * x_in(2) call sampler%fetch (val, x, f) end subroutine test_sampler_2_evaluate @ %def test_sampler_2_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_2_is_valid <>= function test_sampler_2_is_valid (sampler) result (valid) class(test_sampler_2_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_2_is_valid @ %def test_sampler_2_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_2_rebuild <>= subroutine test_sampler_2_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f sampler%x = x_in sampler%val = val x(:,1) = sampler%x f = 1 end subroutine test_sampler_2_rebuild @ %def test_sampler_2_rebuild <>= procedure :: fetch => test_sampler_2_fetch <>= subroutine test_sampler_2_fetch (sampler, val, x, f) class(test_sampler_2_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x(:,1) = sampler%x f = 1 end subroutine test_sampler_2_fetch @ %def test_sampler_2_fetch @ This is the function $f(x) = (1 - 3 x^2)\,\theta(x-1/2)$ with integral $\int_0^1 f(x)\,dx=-3/8$, minimum $f(1)=-2$ and maximum $f(1/2)=1/4$. If the integration dimension is greater than one, the function is extended as a constant in the other dimension(s). <>= type, extends (mci_sampler_t) :: test_sampler_4_t real(default) :: val real(default), dimension(:), allocatable :: x contains <> end type test_sampler_4_t @ %def test_sampler_4_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure :: write => test_sampler_4_write <>= subroutine test_sampler_4_write (object, unit, testflag) class(test_sampler_4_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Test sampler: f(x) = 1 - 3 x^2" end subroutine test_sampler_4_write @ %def test_sampler_4_write @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_4_evaluate <>= subroutine test_sampler_4_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_4_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (x_in(1) >= .5_default) then sampler%val = 1 - 3 * x_in(1) ** 2 else sampler%val = 0 end if if (.not. allocated (sampler%x)) allocate (sampler%x (size (x_in))) sampler%x = x_in call sampler%fetch (val, x, f) end subroutine test_sampler_4_evaluate @ %def test_sampler_4_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_4_is_valid <>= function test_sampler_4_is_valid (sampler) result (valid) class(test_sampler_4_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_4_is_valid @ %def test_sampler_4_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_4_rebuild <>= subroutine test_sampler_4_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_4_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f sampler%x = x_in sampler%val = val x(:,1) = sampler%x f = 1 end subroutine test_sampler_4_rebuild @ %def test_sampler_4_rebuild <>= procedure :: fetch => test_sampler_4_fetch <>= subroutine test_sampler_4_fetch (sampler, val, x, f) class(test_sampler_4_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x(:,1) = sampler%x f = 1 end subroutine test_sampler_4_fetch @ %def test_sampler_4_fetch @ \subsubsection{One-dimensional integration} Construct an integrator and use it for a one-dimensional sampler. <>= call test (mci_midpoint_1, "mci_midpoint_1", & "one-dimensional integral", & u, results) <>= public :: mci_midpoint_1 <>= subroutine mci_midpoint_1 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_midpoint_1" write (u, "(A)") "* Purpose: integrate function in one dimension" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (1, 1) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_1_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.8" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.8_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.7" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.7_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.9" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.9_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_1" end subroutine mci_midpoint_1 @ %def mci_midpoint_1 @ \subsubsection{Two-dimensional integration} Construct an integrator and use it for a two-dimensional sampler. <>= call test (mci_midpoint_2, "mci_midpoint_2", & "two-dimensional integral", & u, results) <>= public :: mci_midpoint_2 <>= subroutine mci_midpoint_2 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_midpoint_2" write (u, "(A)") "* Purpose: integrate function in two dimensions" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (2, 1) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_2_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.8, y = 0.2" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.8_default, 0.2_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_2" end subroutine mci_midpoint_2 @ %def mci_midpoint_2 @ \subsubsection{Two-dimensional integration with flat dimension} Construct an integrator and use it for a two-dimensional sampler, where the function is constant in the second dimension. <>= call test (mci_midpoint_3, "mci_midpoint_3", & "two-dimensional integral with flat dimension", & u, results) <>= public :: mci_midpoint_3 <>= subroutine mci_midpoint_3 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_midpoint_3" write (u, "(A)") "* Purpose: integrate function with one flat dimension" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) select type (mci) type is (mci_midpoint_t) call mci%set_dimensions (2, 1) call mci%declare_flat_dimensions ([2]) end select call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_1_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.8, y = 0.2" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.8_default, 0.2_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_3" end subroutine mci_midpoint_3 @ %def mci_midpoint_3 @ \subsubsection{Integrand with sign flip} Construct an integrator and use it for a one-dimensional sampler. <>= call test (mci_midpoint_4, "mci_midpoint_4", & "integrand with sign flip", & u, results) <>= public :: mci_midpoint_4 <>= subroutine mci_midpoint_4 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler write (u, "(A)") "* Test output: mci_midpoint_4" write (u, "(A)") "* Purpose: integrate function with sign flip & &in one dimension" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (1, 1) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_4_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for x = 0.8" write (u, "(A)") call mci_instance%evaluate (sampler, 1, [0.8_default]) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_4" end subroutine mci_midpoint_4 @ %def mci_midpoint_4 @ \subsubsection{Weighted events} Generate weighted events. Without rejection, we do not need to know maxima and minima, so we can start generating events immediately. We have two dimensions. <>= call test (mci_midpoint_5, "mci_midpoint_5", & "weighted events", & u, results) <>= public :: mci_midpoint_5 <>= subroutine mci_midpoint_5 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng class(mci_state_t), allocatable :: state write (u, "(A)") "* Test output: mci_midpoint_5" write (u, "(A)") "* Purpose: generate weighted events" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (2, 1) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_2_t :: sampler) write (u, "(A)") "* Initialize random-number generator" write (u, "(A)") allocate (rng_test_t :: rng) call rng%init () call mci%import_rng (rng) write (u, "(A)") "* Generate weighted event" write (u, "(A)") call mci%generate_weighted_event (mci_instance, sampler) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Generate weighted event" write (u, "(A)") call mci%generate_weighted_event (mci_instance, sampler) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Store data" write (u, "(A)") allocate (state) call mci_instance%store (state) call mci_instance%final () deallocate (mci_instance) call state%write (u) write (u, "(A)") write (u, "(A)") "* Recall data and rebuild event" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) call mci%rebuild_event (mci_instance, sampler, state) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () deallocate (mci_instance) call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_5" end subroutine mci_midpoint_5 @ %def mci_midpoint_5 @ \subsubsection{Unweighted events} Generate unweighted events. The integrand has a sign flip in it. <>= call test (mci_midpoint_6, "mci_midpoint_6", & "unweighted events", & u, results) <>= public :: mci_midpoint_6 <>= subroutine mci_midpoint_6 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_midpoint_6" write (u, "(A)") "* Purpose: generate unweighted events" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (1, 1) write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_4_t :: sampler) write (u, "(A)") "* Initialize random-number generator" write (u, "(A)") allocate (rng_test_t :: rng) call rng%init () call mci%import_rng (rng) write (u, "(A)") "* Integrate (determine maximum of integrand" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Generate unweighted event" write (u, "(A)") call mci%generate_unweighted_event (mci_instance, sampler) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () deallocate (mci_instance) call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_6" end subroutine mci_midpoint_6 @ %def mci_midpoint_6 @ \subsubsection{Excess weight} Generate unweighted events. With only 2 points for integration, the maximum of the integrand is too low, and we produce excess weight. <>= call test (mci_midpoint_7, "mci_midpoint_7", & "excess weight", & u, results) <>= public :: mci_midpoint_7 <>= subroutine mci_midpoint_7 (u) integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_midpoint_7" write (u, "(A)") "* Purpose: generate unweighted event & &with excess weight" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_midpoint_t :: mci) call mci%set_dimensions (1, 1) write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_4_t :: sampler) write (u, "(A)") "* Initialize random-number generator" write (u, "(A)") allocate (rng_test_t :: rng) call rng%init () call mci%import_rng (rng) write (u, "(A)") "* Integrate (determine maximum of integrand" write (u, "(A)") call mci%integrate (mci_instance, sampler, 1, 2) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Generate unweighted event" write (u, "(A)") call mci_instance%init_simulation () call mci%generate_unweighted_event (mci_instance, sampler) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Use getter methods" write (u, "(A)") write (u, "(1x,A,1x,ES19.12)") "weight =", mci_instance%get_event_weight () write (u, "(1x,A,1x,ES19.12)") "excess =", mci_instance%get_event_excess () write (u, "(A)") write (u, "(A)") "* Apply safety factor" write (u, "(A)") call mci_instance%init_simulation (safety_factor = 2.1_default) write (u, "(A)") "* Generate unweighted event" write (u, "(A)") call mci%generate_unweighted_event (mci_instance, sampler) call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Use getter methods" write (u, "(A)") write (u, "(1x,A,1x,ES19.12)") "weight =", mci_instance%get_event_weight () write (u, "(1x,A,1x,ES19.12)") "excess =", mci_instance%get_event_excess () write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () deallocate (mci_instance) call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_midpoint_7" end subroutine mci_midpoint_7 @ %def mci_midpoint_7 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{\vamp\ interface} The standard method for integration is \vamp: the multi-channel version of the VEGAS algorithm. Each parameterization (channel) of the hypercube is binned in each dimension. The binning is equally equidistant, but an iteration of the integration procedure, the binning is updated for each dimension, according to the variance distribution of the integrand, summed over all other dimension. In the next iteration, the binning approximates (hopefully) follows the integrand more closely, and the accuracy of the result is increased. Furthermore, the relative weight of the individual channels is also updated after an iteration. The bin distribution is denoted as the grid for a channel, which we can write to file and reuse later. In our implementation we specify the generic \vamp\ algorithm more tightly: the number of bins is equal for all dimensions, the initial weights are all equal. The user controls whether to update bins and/or weights after each iteration. The integration is organized in passes, each one consisting of several iterations with a common number of calls to the integrand. The first passes are intended as warmup, so the results are displayed but otherwise discarded. In the final pass, the integration estimates for the individual iterations are averaged for the final result. <<[[mci_vamp.f90]]>>= <> module mci_vamp <> <> use io_units use constants, only: zero use format_utils, only: pac_fmt use format_utils, only: write_separator use format_defs, only: FMT_12, FMT_14, FMT_17, FMT_19 use diagnostics use md5 use phs_base use rng_base use rng_tao use vamp !NODEP! use exceptions !NODEP! use mci_base <> <> <> <> contains <> end module mci_vamp @ %def mci_vamp @ \subsection{Grid parameters} This is a transparent container. It holds the parameters that are stored in grid files, and are checked when grid files are read. <>= public :: grid_parameters_t <>= type :: grid_parameters_t integer :: threshold_calls = 0 integer :: min_calls_per_channel = 10 integer :: min_calls_per_bin = 10 integer :: min_bins = 3 integer :: max_bins = 20 logical :: stratified = .true. logical :: use_vamp_equivalences = .true. real(default) :: channel_weights_power = 0.25_default real(default) :: accuracy_goal = 0 real(default) :: error_goal = 0 real(default) :: rel_error_goal = 0 contains <> end type grid_parameters_t @ %def grid_parameters_t @ I/O: <>= procedure :: write => grid_parameters_write <>= subroutine grid_parameters_write (object, unit) class(grid_parameters_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A,I0)") "threshold_calls = ", & object%threshold_calls write (u, "(3x,A,I0)") "min_calls_per_channel = ", & object%min_calls_per_channel write (u, "(3x,A,I0)") "min_calls_per_bin = ", & object%min_calls_per_bin write (u, "(3x,A,I0)") "min_bins = ", & object%min_bins write (u, "(3x,A,I0)") "max_bins = ", & object%max_bins write (u, "(3x,A,L1)") "stratified = ", & object%stratified write (u, "(3x,A,L1)") "use_vamp_equivalences = ", & object%use_vamp_equivalences write (u, "(3x,A,F10.7)") "channel_weights_power = ", & object%channel_weights_power if (object%accuracy_goal > 0) then write (u, "(3x,A,F10.7)") "accuracy_goal = ", & object%accuracy_goal end if if (object%error_goal > 0) then write (u, "(3x,A,F10.7)") "error_goal = ", & object%error_goal end if if (object%rel_error_goal > 0) then write (u, "(3x,A,F10.7)") "rel_error_goal = ", & object%rel_error_goal end if end subroutine grid_parameters_write @ %def grid_parameters_write @ \subsection{History parameters} The history parameters are also stored in a transparent container. This is not a part of the grid definition, and should not be included in the MD5 sum. <>= public :: history_parameters_t <>= type :: history_parameters_t logical :: global = .true. logical :: global_verbose = .false. logical :: channel = .false. logical :: channel_verbose = .false. contains <> end type history_parameters_t @ %def history_parameters_t @ I/O: <>= procedure :: write => history_parameters_write <>= subroutine history_parameters_write (object, unit) class(history_parameters_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A,L1)") "history(global) = ", object%global write (u, "(3x,A,L1)") "history(global) verb. = ", object%global_verbose write (u, "(3x,A,L1)") "history(channels) = ", object%channel write (u, "(3x,A,L1)") "history(chann.) verb. = ", object%channel_verbose end subroutine history_parameters_write @ %def history_parameters_write @ \subsection{Integration pass} We store the parameters for each integration pass in a linked list. <>= type :: pass_t integer :: i_pass = 0 integer :: i_first_it = 0 integer :: n_it = 0 integer :: n_calls = 0 integer :: n_bins = 0 logical :: adapt_grids = .false. logical :: adapt_weights = .false. logical :: is_final_pass = .false. logical :: integral_defined = .false. integer, dimension(:), allocatable :: calls integer, dimension(:), allocatable :: calls_valid real(default), dimension(:), allocatable :: integral real(default), dimension(:), allocatable :: error real(default), dimension(:), allocatable :: efficiency type(vamp_history), dimension(:), allocatable :: v_history type(vamp_history), dimension(:,:), allocatable :: v_histories type(pass_t), pointer :: next => null () contains <> end type pass_t @ %def pass_t @ Finalizer. The VAMP histories contain a pointer array. <>= procedure :: final => pass_final <>= subroutine pass_final (object) class(pass_t), intent(inout) :: object if (allocated (object%v_history)) then call vamp_delete_history (object%v_history) end if if (allocated (object%v_histories)) then call vamp_delete_history (object%v_histories) end if end subroutine pass_final @ %def pass_final @ Output. Note that the precision of the numerical values should match the precision for comparing output from file with data. <>= procedure :: write => pass_write <>= subroutine pass_write (object, unit, pacify) class(pass_t), intent(in) :: object integer, intent(in) :: unit logical, intent(in), optional :: pacify integer :: u, i character(len=7) :: fmt call pac_fmt (fmt, FMT_17, FMT_14, pacify) u = given_output_unit (unit) write (u, "(3x,A,I0)") "n_it = ", object%n_it write (u, "(3x,A,I0)") "n_calls = ", object%n_calls write (u, "(3x,A,I0)") "n_bins = ", object%n_bins write (u, "(3x,A,L1)") "adapt grids = ", object%adapt_grids write (u, "(3x,A,L1)") "adapt weights = ", object%adapt_weights if (object%integral_defined) then write (u, "(3x,A)") "Results: [it, calls, valid, integral, error, efficiency]" do i = 1, object%n_it write (u, "(5x,I0,2(1x,I0),3(1x," // fmt // "))") & i, object%calls(i), object%calls_valid(i), object%integral(i), object%error(i), & object%efficiency(i) end do else write (u, "(3x,A)") "Results: [undefined]" end if end subroutine pass_write @ %def pass_write @ Read and reconstruct the pass. <>= procedure :: read => pass_read <>= subroutine pass_read (object, u, n_pass, n_it) class(pass_t), intent(out) :: object integer, intent(in) :: u, n_pass, n_it integer :: i, j character(80) :: buffer object%i_pass = n_pass + 1 object%i_first_it = n_it + 1 call read_ival (u, object%n_it) call read_ival (u, object%n_calls) call read_ival (u, object%n_bins) call read_lval (u, object%adapt_grids) call read_lval (u, object%adapt_weights) allocate (object%calls (object%n_it), source = 0) allocate (object%calls_valid (object%n_it), source = 0) allocate (object%integral (object%n_it), source = 0._default) allocate (object%error (object%n_it), source = 0._default) allocate (object%efficiency (object%n_it), source = 0._default) read (u, "(A)") buffer select case (trim (adjustl (buffer))) case ("Results: [it, calls, valid, integral, error, efficiency]") do i = 1, object%n_it read (u, *) & j, object%calls(i), object%calls_valid(i), object%integral(i), object%error(i), & object%efficiency(i) end do object%integral_defined = .true. case ("Results: [undefined]") object%integral_defined = .false. case default call msg_fatal ("Reading integration pass: corrupted file") end select end subroutine pass_read @ %def pass_read @ Write the VAMP history for this pass. (The subroutine writes the whole array at once.) <>= procedure :: write_history => pass_write_history <>= subroutine pass_write_history (pass, unit) class(pass_t), intent(in) :: pass integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (allocated (pass%v_history)) then call vamp_write_history (u, pass%v_history) else write (u, "(1x,A)") "Global history: [undefined]" end if if (allocated (pass%v_histories)) then write (u, "(1x,A)") "Channel histories:" call vamp_write_history (u, pass%v_histories) else write (u, "(1x,A)") "Channel histories: [undefined]" end if end subroutine pass_write_history @ %def pass_write_history @ Given a number of calls and iterations, compute remaining data. <>= procedure :: configure => pass_configure <>= subroutine pass_configure (pass, n_it, n_calls, min_calls, & min_bins, max_bins, min_channel_calls) class(pass_t), intent(inout) :: pass integer, intent(in) :: n_it, n_calls, min_channel_calls integer, intent(in) :: min_calls, min_bins, max_bins pass%n_it = n_it if (min_calls /= 0) then pass%n_bins = max (min_bins, & min (n_calls / min_calls, max_bins)) else pass%n_bins = max_bins end if pass%n_calls = max (n_calls, max (min_calls, min_channel_calls)) if (pass%n_calls /= n_calls) then write (msg_buffer, "(A,I0)") "VAMP: too few calls, resetting " & // "n_calls to ", pass%n_calls call msg_warning () end if allocate (pass%calls (n_it), source = 0) allocate (pass%calls_valid (n_it), source = 0) allocate (pass%integral (n_it), source = 0._default) allocate (pass%error (n_it), source = 0._default) allocate (pass%efficiency (n_it), source = 0._default) end subroutine pass_configure @ %def pass_configure @ Allocate the VAMP history and give options. We assume that the [[configure]] routine above has been executed, so the number of iterations is known. <>= procedure :: configure_history => pass_configure_history <>= subroutine pass_configure_history (pass, n_channels, par) class(pass_t), intent(inout) :: pass integer, intent(in) :: n_channels type(history_parameters_t), intent(in) :: par if (par%global) then allocate (pass%v_history (pass%n_it)) call vamp_create_history (pass%v_history, & verbose = par%global_verbose) end if if (par%channel) then allocate (pass%v_histories (pass%n_it, n_channels)) call vamp_create_history (pass%v_histories, & verbose = par%channel_verbose) end if end subroutine pass_configure_history @ %def pass_configure_history @ Given two pass objects, compare them. All parameters must match. Where integrations are done in both (number of calls nonzero), the results must be equal (up to numerical noise). The allocated array sizes might be different, but should match up to the common [[n_it]] value. <>= interface operator (.matches.) module procedure pass_matches end interface operator (.matches.) <>= function pass_matches (pass, ref) result (ok) type(pass_t), intent(in) :: pass, ref integer :: n logical :: ok ok = .true. if (ok) ok = pass%i_pass == ref%i_pass if (ok) ok = pass%i_first_it == ref%i_first_it if (ok) ok = pass%n_it == ref%n_it if (ok) ok = pass%n_calls == ref%n_calls if (ok) ok = pass%n_bins == ref%n_bins if (ok) ok = pass%adapt_grids .eqv. ref%adapt_grids if (ok) ok = pass%adapt_weights .eqv. ref%adapt_weights if (ok) ok = pass%integral_defined .eqv. ref%integral_defined if (pass%integral_defined) then n = pass%n_it if (ok) ok = all (pass%calls(:n) == ref%calls(:n)) if (ok) ok = all (pass%calls_valid(:n) == ref%calls_valid (:n)) if (ok) ok = all (pass%integral(:n) .matches. ref%integral(:n)) if (ok) ok = all (pass%error(:n) .matches. ref%error(:n)) if (ok) ok = all (pass%efficiency(:n) .matches. ref%efficiency(:n)) end if end function pass_matches @ %def pass_matches @ Update a pass object, given a reference. The parameters must match, except for the [[n_it]] entry. The number of complete iterations must be less or equal to the reference, and the number of complete iterations in the reference must be no larger than [[n_it]]. Where results are present in both passes, they must match. Where results are present in the reference only, the pass is updated accordingly. <>= procedure :: update => pass_update <>= subroutine pass_update (pass, ref, ok) class(pass_t), intent(inout) :: pass type(pass_t), intent(in) :: ref logical, intent(out) :: ok integer :: n, n_ref ok = .true. if (ok) ok = pass%i_pass == ref%i_pass if (ok) ok = pass%i_first_it == ref%i_first_it if (ok) ok = pass%n_calls == ref%n_calls if (ok) ok = pass%n_bins == ref%n_bins if (ok) ok = pass%adapt_grids .eqv. ref%adapt_grids if (ok) ok = pass%adapt_weights .eqv. ref%adapt_weights if (ok) then if (ref%integral_defined) then if (.not. allocated (pass%calls)) then allocate (pass%calls (pass%n_it), source = 0) allocate (pass%calls_valid (pass%n_it), source = 0) allocate (pass%integral (pass%n_it), source = 0._default) allocate (pass%error (pass%n_it), source = 0._default) allocate (pass%efficiency (pass%n_it), source = 0._default) end if n = count (pass%calls /= 0) n_ref = count (ref%calls /= 0) ok = n <= n_ref .and. n_ref <= pass%n_it if (ok) ok = all (pass%calls(:n) == ref%calls(:n)) if (ok) ok = all (pass%calls_valid(:n) == ref%calls_valid(:n)) if (ok) ok = all (pass%integral(:n) .matches. ref%integral(:n)) if (ok) ok = all (pass%error(:n) .matches. ref%error(:n)) if (ok) ok = all (pass%efficiency(:n) .matches. ref%efficiency(:n)) if (ok) then pass%calls(n+1:n_ref) = ref%calls(n+1:n_ref) pass%calls_valid(n+1:n_ref) = ref%calls_valid(n+1:n_ref) pass%integral(n+1:n_ref) = ref%integral(n+1:n_ref) pass%error(n+1:n_ref) = ref%error(n+1:n_ref) pass%efficiency(n+1:n_ref) = ref%efficiency(n+1:n_ref) pass%integral_defined = any (pass%calls /= 0) end if end if end if end subroutine pass_update @ %def pass_update @ Match two real numbers: they are equal up to a tolerance, which is $10^{-8}$, matching the number of digits that are output by [[pass_write]]. In particular, if one number is exactly zero, the other one must also be zero. <>= interface operator (.matches.) module procedure real_matches end interface operator (.matches.) <>= elemental function real_matches (x, y) result (ok) real(default), intent(in) :: x, y logical :: ok real(default), parameter :: tolerance = 1.e-8_default ok = abs (x - y) <= tolerance * max (abs (x), abs (y)) end function real_matches @ %def real_matches @ Return the index of the most recent complete integration. If there is none, return zero. <>= procedure :: get_integration_index => pass_get_integration_index <>= function pass_get_integration_index (pass) result (n) class (pass_t), intent(in) :: pass integer :: n integer :: i n = 0 if (allocated (pass%calls)) then do i = 1, pass%n_it if (pass%calls(i) == 0) exit n = i end do end if end function pass_get_integration_index @ %def pass_get_integration_index @ Return the most recent integral and error, if available. <>= procedure :: get_calls => pass_get_calls procedure :: get_calls_valid => pass_get_calls_valid procedure :: get_integral => pass_get_integral procedure :: get_error => pass_get_error procedure :: get_efficiency => pass_get_efficiency <>= function pass_get_calls (pass) result (calls) class(pass_t), intent(in) :: pass integer :: calls integer :: n n = pass%get_integration_index () if (n /= 0) then calls = pass%calls(n) else calls = 0 end if end function pass_get_calls function pass_get_calls_valid (pass) result (calls_valid) class(pass_t), intent(in) :: pass integer :: calls_valid integer :: n n = pass%get_integration_index () if (n /= 0) then calls_valid = pass%calls_valid(n) else calls_valid = 0 end if end function pass_get_calls_valid function pass_get_integral (pass) result (integral) class(pass_t), intent(in) :: pass real(default) :: integral integer :: n n = pass%get_integration_index () if (n /= 0) then integral = pass%integral(n) else integral = 0 end if end function pass_get_integral function pass_get_error (pass) result (error) class(pass_t), intent(in) :: pass real(default) :: error integer :: n n = pass%get_integration_index () if (n /= 0) then error = pass%error(n) else error = 0 end if end function pass_get_error function pass_get_efficiency (pass) result (efficiency) class(pass_t), intent(in) :: pass real(default) :: efficiency integer :: n n = pass%get_integration_index () if (n /= 0) then efficiency = pass%efficiency(n) else efficiency = 0 end if end function pass_get_efficiency @ %def pass_get_calls @ %def pass_get_calls_valid @ %def pass_get_integral @ %def pass_get_error @ %def pass_get_efficiency @ \subsection{Integrator} <>= public :: mci_vamp_t <>= type, extends (mci_t) :: mci_vamp_t logical, dimension(:), allocatable :: dim_is_flat type(grid_parameters_t) :: grid_par type(history_parameters_t) :: history_par integer :: min_calls = 0 type(pass_t), pointer :: first_pass => null () type(pass_t), pointer :: current_pass => null () type(vamp_equivalences_t) :: equivalences logical :: rebuild = .true. logical :: check_grid_file = .true. logical :: grid_filename_set = .false. logical :: negative_weights = .false. logical :: verbose = .false. type(string_t) :: grid_filename character(32) :: md5sum_adapted = "" contains <> end type mci_vamp_t @ %def mci_vamp_t @ Reset: delete integration-pass entries. <>= procedure :: reset => mci_vamp_reset <>= subroutine mci_vamp_reset (object) class(mci_vamp_t), intent(inout) :: object type(pass_t), pointer :: current_pass do while (associated (object%first_pass)) current_pass => object%first_pass object%first_pass => current_pass%next call current_pass%final () deallocate (current_pass) end do object%current_pass => null () end subroutine mci_vamp_reset @ %def mci_vamp_reset @ Finalizer: reset and finalize the equivalences list. <>= procedure :: final => mci_vamp_final <>= subroutine mci_vamp_final (object) class(mci_vamp_t), intent(inout) :: object call object%reset () call vamp_equivalences_final (object%equivalences) call object%base_final () end subroutine mci_vamp_final @ %def mci_vamp_final @ Output. Do not output the grids themselves, this may result in tons of data. <>= procedure :: write => mci_vamp_write <>= subroutine mci_vamp_write (object, unit, pacify, md5sum_version) class(mci_vamp_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version type(pass_t), pointer :: current_pass integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "VAMP integrator:" call object%base_write (u, pacify, md5sum_version) if (allocated (object%dim_is_flat)) then write (u, "(3x,A,999(1x,I0))") "Flat dimensions =", & pack ([(i, i = 1, object%n_dim)], object%dim_is_flat) end if write (u, "(1x,A)") "Grid parameters:" call object%grid_par%write (u) write (u, "(3x,A,I0)") "min_calls = ", object%min_calls write (u, "(3x,A,L1)") "negative weights = ", & object%negative_weights write (u, "(3x,A,L1)") "verbose = ", & object%verbose if (object%grid_par%use_vamp_equivalences) then call vamp_equivalences_write (object%equivalences, u) end if current_pass => object%first_pass do while (associated (current_pass)) write (u, "(1x,A,I0,A)") "Integration pass:" call current_pass%write (u, pacify) current_pass => current_pass%next end do if (object%md5sum_adapted /= "") then write (u, "(1x,A,A,A)") "MD5 sum (including results) = '", & object%md5sum_adapted, "'" end if end subroutine mci_vamp_write @ %def mci_vamp_write @ Write the history parameters. <>= procedure :: write_history_parameters => mci_vamp_write_history_parameters <>= subroutine mci_vamp_write_history_parameters (mci, unit) class(mci_vamp_t), intent(in) :: mci integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "VAMP history parameters:" call mci%history_par%write (unit) end subroutine mci_vamp_write_history_parameters @ %def mci_vamp_write_history_parameters @ Write the history, iterating over passes. We keep this separate from the generic [[write]] routine. <>= procedure :: write_history => mci_vamp_write_history <>= subroutine mci_vamp_write_history (mci, unit) class(mci_vamp_t), intent(in) :: mci integer, intent(in), optional :: unit type(pass_t), pointer :: current_pass integer :: i_pass integer :: u u = given_output_unit (unit) if (associated (mci%first_pass)) then write (u, "(1x,A)") "VAMP history (global):" i_pass = 0 current_pass => mci%first_pass do while (associated (current_pass)) i_pass = i_pass + 1 write (u, "(1x,A,I0,':')") "Pass #", i_pass call current_pass%write_history (u) current_pass => current_pass%next end do end if end subroutine mci_vamp_write_history @ %def mci_vamp_write_history @ Compute the MD5 sum, including the configuration MD5 sum and the printout, which incorporates the current results. <>= procedure :: compute_md5sum => mci_vamp_compute_md5sum <>= subroutine mci_vamp_compute_md5sum (mci, pacify) class(mci_vamp_t), intent(inout) :: mci logical, intent(in), optional :: pacify integer :: u mci%md5sum_adapted = "" u = free_unit () open (u, status = "scratch", action = "readwrite") write (u, "(A)") mci%md5sum call mci%write (u, pacify, md5sum_version = .true.) rewind (u) mci%md5sum_adapted = md5sum (u) close (u) end subroutine mci_vamp_compute_md5sum @ %def mci_vamp_compute_md5sum @ Return the MD5 sum: If available, return the adapted one. <>= procedure :: get_md5sum => mci_vamp_get_md5sum <>= pure function mci_vamp_get_md5sum (mci) result (md5sum) class(mci_vamp_t), intent(in) :: mci character(32) :: md5sum if (mci%md5sum_adapted /= "") then md5sum = mci%md5sum_adapted else md5sum = mci%md5sum end if end function mci_vamp_get_md5sum @ %def mci_vamp_get_md5sum @ Startup message: short version. <>= procedure :: startup_message => mci_vamp_startup_message <>= subroutine mci_vamp_startup_message (mci, unit, n_calls) class(mci_vamp_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls integer :: num_calls, n_bins if (present (n_calls)) then num_calls = n_calls else num_calls = 0 end if if (mci%min_calls /= 0) then n_bins = max (mci%grid_par%min_bins, & min (num_calls / mci%min_calls, & mci%grid_par%max_bins)) else n_bins = mci%grid_par%max_bins end if call mci%base_startup_message (unit = unit, n_calls = n_calls) if (mci%grid_par%use_vamp_equivalences) then write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Integrator: Using VAMP channel equivalences" call msg_message (unit = unit) end if write (msg_buffer, "(A,2(1x,I0,1x,A),L1)") & "Integrator:", num_calls, & "initial calls,", n_bins, & "bins, stratified = ", & mci%grid_par%stratified call msg_message (unit = unit) write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Integrator: VAMP" call msg_message (unit = unit) end subroutine mci_vamp_startup_message @ %def mci_vamp_startup_message @ Log entry: just headline. <>= procedure :: write_log_entry => mci_vamp_write_log_entry <>= subroutine mci_vamp_write_log_entry (mci, u) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: u write (u, "(1x,A)") "MC Integrator is VAMP" call write_separator (u) call mci%write_history (u) call write_separator (u) if (mci%grid_par%use_vamp_equivalences) then call vamp_equivalences_write (mci%equivalences, u) else write (u, "(3x,A)") "No VAMP equivalences have been used" end if call write_separator (u) call mci%write_chain_weights (u) end subroutine mci_vamp_write_log_entry @ %def mci_vamp_write_log_entry @ Set the MCI index (necessary for processes with multiple components). We append the index to the grid filename, just before the final dotted suffix. <>= procedure :: record_index => mci_vamp_record_index <>= subroutine mci_vamp_record_index (mci, i_mci) class(mci_vamp_t), intent(inout) :: mci integer, intent(in) :: i_mci type(string_t) :: basename, suffix character(32) :: buffer if (mci%grid_filename_set) then basename = mci%grid_filename call split (basename, suffix, ".", back=.true.) write (buffer, "(I0)") i_mci if (basename /= "") then mci%grid_filename = basename // ".m" // trim (buffer) // "." // suffix else mci%grid_filename = suffix // ".m" // trim (buffer) // ".vg" end if end if end subroutine mci_vamp_record_index @ %def mci_vamp_record_index @ Set the grid parameters. <>= procedure :: set_grid_parameters => mci_vamp_set_grid_parameters <>= subroutine mci_vamp_set_grid_parameters (mci, grid_par) class(mci_vamp_t), intent(inout) :: mci type(grid_parameters_t), intent(in) :: grid_par mci%grid_par = grid_par mci%min_calls = grid_par%min_calls_per_bin * mci%n_channel end subroutine mci_vamp_set_grid_parameters @ %def mci_vamp_set_grid_parameters @ Set the history parameters. <>= procedure :: set_history_parameters => mci_vamp_set_history_parameters <>= subroutine mci_vamp_set_history_parameters (mci, history_par) class(mci_vamp_t), intent(inout) :: mci type(history_parameters_t), intent(in) :: history_par mci%history_par = history_par end subroutine mci_vamp_set_history_parameters @ %def mci_vamp_set_history_parameters @ Set the rebuild flag, also the flag for checking the grid file. <>= procedure :: set_rebuild_flag => mci_vamp_set_rebuild_flag <>= subroutine mci_vamp_set_rebuild_flag (mci, rebuild, check_grid_file) class(mci_vamp_t), intent(inout) :: mci logical, intent(in) :: rebuild logical, intent(in) :: check_grid_file mci%rebuild = rebuild mci%check_grid_file = check_grid_file end subroutine mci_vamp_set_rebuild_flag @ %def mci_vamp_set_rebuild_flag @ Set the filename. <>= procedure :: set_grid_filename => mci_vamp_set_grid_filename <>= subroutine mci_vamp_set_grid_filename (mci, name, run_id) class(mci_vamp_t), intent(inout) :: mci type(string_t), intent(in) :: name type(string_t), intent(in), optional :: run_id if (present (run_id)) then mci%grid_filename = name // "." // run_id // ".vg" else mci%grid_filename = name // ".vg" end if mci%grid_filename_set = .true. end subroutine mci_vamp_set_grid_filename @ %def mci_vamp_set_grid_filename @ To simplify the interface, we prepend a grid path in a separate subroutine. <>= procedure :: prepend_grid_path => mci_vamp_prepend_grid_path <>= subroutine mci_vamp_prepend_grid_path (mci, prefix) class(mci_vamp_t), intent(inout) :: mci type(string_t), intent(in) :: prefix if (mci%grid_filename_set) then mci%grid_filename = prefix // "/" // mci%grid_filename else call msg_warning ("Cannot add prefix to invalid grid filename!") end if end subroutine mci_vamp_prepend_grid_path @ %def mci_vamp_prepend_grid_path @ Declare particular dimensions as flat. <>= procedure :: declare_flat_dimensions => mci_vamp_declare_flat_dimensions <>= subroutine mci_vamp_declare_flat_dimensions (mci, dim_flat) class(mci_vamp_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat integer :: d allocate (mci%dim_is_flat (mci%n_dim), source = .false.) do d = 1, size (dim_flat) mci%dim_is_flat(dim_flat(d)) = .true. end do end subroutine mci_vamp_declare_flat_dimensions @ %def mci_vamp_declare_flat_dimensions @ Declare equivalences. We have an array of channel equivalences, provided by the phase-space module. Here, we translate this into the [[vamp_equivalences]] array. <>= procedure :: declare_equivalences => mci_vamp_declare_equivalences <>= subroutine mci_vamp_declare_equivalences (mci, channel, dim_offset) class(mci_vamp_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset integer, dimension(:), allocatable :: perm, mode integer :: n_channels, n_dim, n_equivalences integer :: c, i, j, left, right n_channels = mci%n_channel n_dim = mci%n_dim n_equivalences = 0 do c = 1, n_channels n_equivalences = n_equivalences + size (channel(c)%eq) end do call vamp_equivalences_init (mci%equivalences, & n_equivalences, n_channels, n_dim) allocate (perm (n_dim)) allocate (mode (n_dim)) perm(1:dim_offset) = [(i, i = 1, dim_offset)] mode(1:dim_offset) = VEQ_IDENTITY c = 1 j = 0 do i = 1, n_equivalences if (j < size (channel(c)%eq)) then j = j + 1 else c = c + 1 j = 1 end if associate (eq => channel(c)%eq(j)) left = c right = eq%c perm(dim_offset+1:) = eq%perm + dim_offset mode(dim_offset+1:) = eq%mode call vamp_equivalence_set (mci%equivalences, & i, left, right, perm, mode) end associate end do call vamp_equivalences_complete (mci%equivalences) end subroutine mci_vamp_declare_equivalences @ %def mci_vamp_declare_equivalences @ Allocate instance with matching type. <>= procedure :: allocate_instance => mci_vamp_allocate_instance <>= subroutine mci_vamp_allocate_instance (mci, mci_instance) class(mci_vamp_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance allocate (mci_vamp_instance_t :: mci_instance) end subroutine mci_vamp_allocate_instance @ %def mci_vamp_allocate_instance @ Allocate a new integration pass. We can preset everything that does not depend on the number of iterations and calls. This is postponed to the [[integrate]] method. In the final pass, we do not check accuracy goal etc., since we can assume that the user wants to perform and average all iterations in this pass. <>= procedure :: add_pass => mci_vamp_add_pass <>= subroutine mci_vamp_add_pass (mci, adapt_grids, adapt_weights, final_pass) class(mci_vamp_t), intent(inout) :: mci logical, intent(in), optional :: adapt_grids, adapt_weights, final_pass integer :: i_pass, i_it type(pass_t), pointer :: new allocate (new) if (associated (mci%current_pass)) then i_pass = mci%current_pass%i_pass + 1 i_it = mci%current_pass%i_first_it + mci%current_pass%n_it mci%current_pass%next => new else i_pass = 1 i_it = 1 mci%first_pass => new end if mci%current_pass => new new%i_pass = i_pass new%i_first_it = i_it if (present (adapt_grids)) then new%adapt_grids = adapt_grids else new%adapt_grids = .false. end if if (present (adapt_weights)) then new%adapt_weights = adapt_weights else new%adapt_weights = .false. end if if (present (final_pass)) then new%is_final_pass = final_pass else new%is_final_pass = .false. end if end subroutine mci_vamp_add_pass @ %def mci_vamp_add_pass @ Update the list of integration passes. All passes except for the last one must match exactly. For the last one, integration results are updated. The reference output may contain extra passes, these are ignored. <>= procedure :: update_from_ref => mci_vamp_update_from_ref <>= subroutine mci_vamp_update_from_ref (mci, mci_ref, success) class(mci_vamp_t), intent(inout) :: mci class(mci_t), intent(in) :: mci_ref logical, intent(out) :: success type(pass_t), pointer :: current_pass, ref_pass select type (mci_ref) type is (mci_vamp_t) current_pass => mci%first_pass ref_pass => mci_ref%first_pass success = .true. do while (success .and. associated (current_pass)) if (associated (ref_pass)) then if (associated (current_pass%next)) then success = current_pass .matches. ref_pass else call current_pass%update (ref_pass, success) if (current_pass%integral_defined) then mci%integral = current_pass%get_integral () mci%error = current_pass%get_error () mci%efficiency = current_pass%get_efficiency () mci%integral_known = .true. mci%error_known = .true. mci%efficiency_known = .true. end if end if current_pass => current_pass%next ref_pass => ref_pass%next else success = .false. end if end do end select end subroutine mci_vamp_update_from_ref @ %def mci_vamp_update @ Update the MCI record (i.e., the integration passes) by reading from input stream. The stream should contain a [[write]] output from a previous run. We first check the MD5 sum of the configuration parameters. If that matches, we proceed directly to the stored integration passes. If successful, we may continue to read the file; the position will be after a blank line that must follow the MCI record. <>= procedure :: update => mci_vamp_update <>= subroutine mci_vamp_update (mci, u, success) class(mci_vamp_t), intent(inout) :: mci integer, intent(in) :: u logical, intent(out) :: success character(80) :: buffer character(32) :: md5sum_file type(mci_vamp_t) :: mci_file integer :: n_pass, n_it call read_sval (u, md5sum_file) if (mci%check_grid_file) then success = md5sum_file == mci%md5sum else success = .true. end if if (success) then read (u, *) read (u, "(A)") buffer if (trim (adjustl (buffer)) == "VAMP integrator:") then n_pass = 0 n_it = 0 do read (u, "(A)") buffer select case (trim (adjustl (buffer))) case ("") exit case ("Integration pass:") call mci_file%add_pass () call mci_file%current_pass%read (u, n_pass, n_it) n_pass = n_pass + 1 n_it = n_it + mci_file%current_pass%n_it end select end do call mci%update_from_ref (mci_file, success) call mci_file%final () else call msg_fatal ("VAMP: reading grid file: corrupted data") end if end if end subroutine mci_vamp_update @ %def mci_vamp_update @ Read / write grids from / to file. Bug fix for 2.2.5: after reading grids from file, channel weights must be copied back to the [[mci_instance]] record. <>= procedure :: write_grids => mci_vamp_write_grids procedure :: read_grids_header => mci_vamp_read_grids_header procedure :: read_grids_data => mci_vamp_read_grids_data procedure :: read_grids => mci_vamp_read_grids <>= subroutine mci_vamp_write_grids (mci, instance) class(mci_vamp_t), intent(in) :: mci class(mci_instance_t), intent(inout) :: instance integer :: u select type (instance) type is (mci_vamp_instance_t) if (mci%grid_filename_set) then if (instance%grids_defined) then u = free_unit () open (u, file = char (mci%grid_filename), & action = "write", status = "replace") write (u, "(1x,A,A,A)") "MD5sum = '", mci%md5sum, "'" write (u, *) call mci%write (u) write (u, *) write (u, "(1x,A)") "VAMP grids:" call vamp_write_grids (instance%grids, u, & write_integrals = .true.) close (u) else call msg_bug ("VAMP: write grids: grids undefined") end if else call msg_bug ("VAMP: write grids: filename undefined") end if end select end subroutine mci_vamp_write_grids subroutine mci_vamp_read_grids_header (mci, success) class(mci_vamp_t), intent(inout) :: mci logical, intent(out) :: success logical :: exist integer :: u success = .false. if (mci%grid_filename_set) then inquire (file = char (mci%grid_filename), exist = exist) if (exist) then u = free_unit () open (u, file = char (mci%grid_filename), & action = "read", status = "old") call mci%update (u, success) close (u) if (.not. success) then write (msg_buffer, "(A,A,A)") & "VAMP: parameter mismatch, discarding grid file '", & char (mci%grid_filename), "'" call msg_message () end if end if else call msg_bug ("VAMP: read grids: filename undefined") end if end subroutine mci_vamp_read_grids_header subroutine mci_vamp_read_grids_data (mci, instance, read_integrals) class(mci_vamp_t), intent(in) :: mci class(mci_instance_t), intent(inout) :: instance logical, intent(in), optional :: read_integrals integer :: u character(80) :: buffer select type (instance) type is (mci_vamp_instance_t) if (.not. instance%grids_defined) then u = free_unit () open (u, file = char (mci%grid_filename), & action = "read", status = "old") do read (u, "(A)") buffer if (trim (adjustl (buffer)) == "VAMP grids:") exit end do call vamp_read_grids (instance%grids, u, read_integrals) close (u) call instance%set_channel_weights (instance%grids%weights) instance%grids_defined = .true. else call msg_bug ("VAMP: read grids: grids already defined") end if end select end subroutine mci_vamp_read_grids_data subroutine mci_vamp_read_grids (mci, instance, success) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance logical, intent(out) :: success logical :: exist integer :: u character(80) :: buffer select type (instance) type is (mci_vamp_instance_t) success = .false. if (mci%grid_filename_set) then if (.not. instance%grids_defined) then inquire (file = char (mci%grid_filename), exist = exist) if (exist) then u = free_unit () open (u, file = char (mci%grid_filename), & action = "read", status = "old") call mci%update (u, success) if (success) then read (u, "(A)") buffer if (trim (adjustl (buffer)) == "VAMP grids:") then call vamp_read_grids (instance%grids, u) else call msg_fatal ("VAMP: reading grid file: & &corrupted grid data") end if else write (msg_buffer, "(A,A,A)") & "VAMP: parameter mismatch, discarding grid file '", & char (mci%grid_filename), "'" call msg_message () end if close (u) instance%grids_defined = success end if else call msg_bug ("VAMP: read grids: grids already defined") end if else call msg_bug ("VAMP: read grids: filename undefined") end if end select end subroutine mci_vamp_read_grids @ %def mci_vamp_write_grids @ %def mci_vamp_read_grids_header @ %def mci_vamp_read_grids_data @ %def mci_vamp_read_grids @ Auxiliary: Read real, integer, string value. We search for an equals sign, the value must follow. <>= subroutine read_rval (u, rval) integer, intent(in) :: u real(default), intent(out) :: rval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) rval end subroutine read_rval subroutine read_ival (u, ival) integer, intent(in) :: u integer, intent(out) :: ival character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) ival end subroutine read_ival subroutine read_sval (u, sval) integer, intent(in) :: u character(*), intent(out) :: sval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) sval end subroutine read_sval subroutine read_lval (u, lval) integer, intent(in) :: u logical, intent(out) :: lval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) lval end subroutine read_lval @ %def read_rval read_ival read_sval read_lval @ Integrate. Perform a new integration pass (possibly reusing previous results), which may consist of several iterations. Note: we record the integral once per iteration. The integral stored in the [[mci]] record itself is the last integral of the current iteration, no averaging done. The [[results]] record may average results. Note: recording the efficiency is not supported yet. <>= procedure :: integrate => mci_vamp_integrate <>= subroutine mci_vamp_integrate (mci, instance, sampler, & n_it, n_calls, results, pacify) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls class(mci_results_t), intent(inout), optional :: results logical, intent(in), optional :: pacify integer :: it logical :: reshape, from_file, success select type (instance) type is (mci_vamp_instance_t) if (associated (mci%current_pass)) then mci%current_pass%integral_defined = .false. call mci%current_pass%configure (n_it, n_calls, & mci%min_calls, mci%grid_par%min_bins, & mci%grid_par%max_bins, & mci%grid_par%min_calls_per_channel * mci%n_channel) call mci%current_pass%configure_history & (mci%n_channel, mci%history_par) instance%pass_complete = .false. instance%it_complete = .false. call instance%new_pass (reshape) if (.not. instance%grids_defined .or. instance%grids_from_file) then if (mci%grid_filename_set .and. .not. mci%rebuild) then call mci%read_grids_header (success) from_file = success if (.not. instance%grids_defined .and. success) then call mci%read_grids_data (instance) end if else from_file = .false. end if else from_file = .false. end if if (from_file) then if (.not. mci%check_grid_file) & call msg_warning ("Reading grid file: MD5 sum check disabled") call msg_message ("VAMP: " & // "using grids and results from file '" & // char (mci%grid_filename) // "'") else if (.not. instance%grids_defined) then call instance%create_grids () end if do it = 1, instance%n_it if (signal_is_pending ()) return instance%grids_from_file = from_file .and. & it <= mci%current_pass%get_integration_index () if (.not. instance%grids_from_file) then instance%it_complete = .false. call instance%adapt_grids () if (signal_is_pending ()) return call instance%adapt_weights () if (signal_is_pending ()) return call instance%discard_integrals (reshape) if (mci%grid_par%use_vamp_equivalences) then call instance%sample_grids (mci%rng, sampler, & mci%equivalences) else call instance%sample_grids (mci%rng, sampler) end if if (signal_is_pending ()) return instance%it_complete = .true. if (instance%integral /= 0) then mci%current_pass%calls(it) = instance%calls mci%current_pass%calls_valid(it) = instance%calls_valid mci%current_pass%integral(it) = instance%integral if (abs (instance%error / instance%integral) & > epsilon (1._default)) then mci%current_pass%error(it) = instance%error end if mci%current_pass%efficiency(it) = instance%efficiency end if mci%current_pass%integral_defined = .true. end if if (present (results)) then if (mci%has_chains ()) then call mci%collect_chain_weights (instance%w) call results%record (1, & n_calls = mci%current_pass%calls(it), & n_calls_valid = mci%current_pass%calls_valid(it), & integral = mci%current_pass%integral(it), & error = mci%current_pass%error(it), & efficiency = mci%current_pass%efficiency(it), & - ! TODO pos. and neg. Efficiency + ! TODO Insert pos. and neg. Efficiency from VAMP. efficiency_pos = 0._default, & efficiency_neg = 0._default, & chain_weights = mci%chain_weights, & suppress = pacify) else call results%record (1, & n_calls = mci%current_pass%calls(it), & n_calls_valid = mci%current_pass%calls_valid(it), & integral = mci%current_pass%integral(it), & error = mci%current_pass%error(it), & efficiency = mci%current_pass%efficiency(it), & - ! TODO pos. and neg. Efficiency + ! TODO Insert pos. and neg. Efficiency from VAMP. efficiency_pos = 0._default, & efficiency_neg = 0._default, & suppress = pacify) end if end if if (.not. instance%grids_from_file & .and. mci%grid_filename_set) then call mci%write_grids (instance) end if call instance%allow_adaptation () reshape = .false. if (.not. mci%current_pass%is_final_pass) then call mci%check_goals (it, success) if (success) exit end if end do if (signal_is_pending ()) return instance%pass_complete = .true. mci%integral = mci%current_pass%get_integral() mci%error = mci%current_pass%get_error() mci%efficiency = mci%current_pass%get_efficiency() mci%integral_known = .true. mci%error_known = .true. mci%efficiency_known = .true. call mci%compute_md5sum (pacify) else call msg_bug ("MCI integrate: current_pass object not allocated") end if end select end subroutine mci_vamp_integrate @ %def mci_vamp_integrate @ Check whether we are already finished with this pass. <>= procedure :: check_goals => mci_vamp_check_goals <>= subroutine mci_vamp_check_goals (mci, it, success) class(mci_vamp_t), intent(inout) :: mci integer, intent(in) :: it logical, intent(out) :: success success = .false. if (mci%error_reached (it)) then mci%current_pass%n_it = it call msg_message ("VAMP: error goal reached; & &skipping iterations") success = .true. return end if if (mci%rel_error_reached (it)) then mci%current_pass%n_it = it call msg_message ("VAMP: relative error goal reached; & &skipping iterations") success = .true. return end if if (mci%accuracy_reached (it)) then mci%current_pass%n_it = it call msg_message ("VAMP: accuracy goal reached; & &skipping iterations") success = .true. return end if end subroutine mci_vamp_check_goals @ %def mci_vamp_check_goals @ Return true if the error, relative error, or accuracy goal has been reached, if any. <>= procedure :: error_reached => mci_vamp_error_reached procedure :: rel_error_reached => mci_vamp_rel_error_reached procedure :: accuracy_reached => mci_vamp_accuracy_reached <>= function mci_vamp_error_reached (mci, it) result (flag) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: it logical :: flag real(default) :: error_goal, error error_goal = mci%grid_par%error_goal if (error_goal > 0) then associate (pass => mci%current_pass) if (pass%integral_defined) then error = abs (pass%error(it)) flag = error < error_goal else flag = .false. end if end associate else flag = .false. end if end function mci_vamp_error_reached function mci_vamp_rel_error_reached (mci, it) result (flag) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: it logical :: flag real(default) :: rel_error_goal, rel_error rel_error_goal = mci%grid_par%rel_error_goal if (rel_error_goal > 0) then associate (pass => mci%current_pass) if (pass%integral_defined) then if (pass%integral(it) /= 0) then rel_error = abs (pass%error(it) / pass%integral(it)) flag = rel_error < rel_error_goal else flag = .true. end if else flag = .false. end if end associate else flag = .false. end if end function mci_vamp_rel_error_reached function mci_vamp_accuracy_reached (mci, it) result (flag) class(mci_vamp_t), intent(in) :: mci integer, intent(in) :: it logical :: flag real(default) :: accuracy_goal, accuracy accuracy_goal = mci%grid_par%accuracy_goal if (accuracy_goal > 0) then associate (pass => mci%current_pass) if (pass%integral_defined) then if (pass%integral(it) /= 0) then accuracy = abs (pass%error(it) / pass%integral(it)) & * sqrt (real (pass%calls(it), default)) flag = accuracy < accuracy_goal else flag = .true. end if else flag = .false. end if end associate else flag = .false. end if end function mci_vamp_accuracy_reached @ %def mci_vamp_error_reached @ %def mci_vamp_rel_error_reached @ %def mci_vamp_accuracy_reached @ Prepare an event generation pass. Should be called before a sequence of events is generated, then we should call the corresponding finalizer. The pass-specific data of the previous integration pass are retained, but we reset the number of iterations and calls to zero. The latter now counts the number of events (calls to the sampling function, actually). <>= procedure :: prepare_simulation => mci_vamp_prepare_simulation <>= subroutine mci_vamp_prepare_simulation (mci) class(mci_vamp_t), intent(inout) :: mci logical :: success if (mci%grid_filename_set) then call mci%read_grids_header (success) call mci%compute_md5sum () if (.not. success) then call msg_fatal ("Simulate: " & // "reading integration grids from file '" & // char (mci%grid_filename) // "' failed") end if else call msg_bug ("VAMP: simulation: no grids, no grid filename") end if end subroutine mci_vamp_prepare_simulation @ %def mci_vamp_prepare_simulation @ Generate weighted event. Note that the event weight ([[vamp_weight]]) is not just the MCI weight. [[vamp_next_event]] selects a channel based on the channel weights multiplied by the (previously recorded) maximum integrand value of the channel. The MCI weight is renormalized accordingly, to cancel this effect on the result. <>= procedure :: generate_weighted_event => mci_vamp_generate_weighted_event <>= subroutine mci_vamp_generate_weighted_event (mci, instance, sampler) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler class(vamp_data_t), allocatable :: data type(exception) :: vamp_exception select type (instance) type is (mci_vamp_instance_t) instance%vamp_weight_set = .false. allocate (mci_workspace_t :: data) select type (data) type is (mci_workspace_t) data%sampler => sampler data%instance => instance end select select type (rng => mci%rng) type is (rng_tao_t) if (instance%grids_defined) then call vamp_next_event ( & instance%vamp_x, & rng%state, & instance%grids, & vamp_sampling_function, & data, & phi = phi_trivial, & weight = instance%vamp_weight, & exc = vamp_exception) call handle_vamp_exception (vamp_exception, mci%verbose) instance%vamp_excess = 0 instance%vamp_weight_set = .true. else call msg_bug ("VAMP: generate event: grids undefined") end if class default call msg_fatal ("VAMP event generation: & &random-number generator must be TAO") end select end select end subroutine mci_vamp_generate_weighted_event @ %def mci_vamp_generate_weighted_event @ Generate unweighted event. <>= procedure :: generate_unweighted_event => & mci_vamp_generate_unweighted_event <>= subroutine mci_vamp_generate_unweighted_event (mci, instance, sampler) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler class(vamp_data_t), allocatable :: data logical :: positive type(exception) :: vamp_exception select type (instance) type is (mci_vamp_instance_t) instance%vamp_weight_set = .false. allocate (mci_workspace_t :: data) select type (data) type is (mci_workspace_t) data%sampler => sampler data%instance => instance end select select type (rng => mci%rng) type is (rng_tao_t) if (instance%grids_defined) then REJECTION: do call vamp_next_event ( & instance%vamp_x, & rng%state, & instance%grids, & vamp_sampling_function, & data, & phi = phi_trivial, & excess = instance%vamp_excess, & positive = positive, & exc = vamp_exception) if (signal_is_pending ()) return if (sampler%is_valid ()) exit REJECTION end do REJECTION call handle_vamp_exception (vamp_exception, mci%verbose) if (positive) then instance%vamp_weight = 1 else if (instance%negative_weights) then instance%vamp_weight = -1 else call msg_fatal ("VAMP: event with negative weight generated") instance%vamp_weight = 0 end if instance%vamp_weight_set = .true. else call msg_bug ("VAMP: generate event: grids undefined") end if class default call msg_fatal ("VAMP event generation: & &random-number generator must be TAO") end select end select end subroutine mci_vamp_generate_unweighted_event @ %def mci_vamp_generate_unweighted_event @ Rebuild an event, using the [[state]] input. Note: This feature is currently unused. <>= procedure :: rebuild_event => mci_vamp_rebuild_event <>= subroutine mci_vamp_rebuild_event (mci, instance, sampler, state) class(mci_vamp_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state call msg_bug ("MCI vamp rebuild event not implemented yet") end subroutine mci_vamp_rebuild_event @ %def mci_vamp_rebuild_event @ Pacify: override the default no-op, since VAMP numerics might need some massage. <>= procedure :: pacify => mci_vamp_pacify <>= subroutine mci_vamp_pacify (object, efficiency_reset, error_reset) class(mci_vamp_t), intent(inout) :: object logical, intent(in), optional :: efficiency_reset, error_reset logical :: err_reset type(pass_t), pointer :: current_pass err_reset = .false. if (present (error_reset)) err_reset = error_reset current_pass => object%first_pass do while (associated (current_pass)) if (allocated (current_pass%error) .and. err_reset) then current_pass%error = 0 end if if (allocated (current_pass%efficiency) .and. err_reset) then current_pass%efficiency = 1 end if current_pass => current_pass%next end do end subroutine mci_vamp_pacify @ %def mci_vamp_pacify @ \subsection{Sampler as Workspace} In the full setup, the sampling function requires the process instance object as workspace. We implement this by (i) implementing the process instance as a type extension of the abstract [[sampler_t]] object used by the MCI implementation and (ii) providing such an object as an extra argument to the sampling function that VAMP can call. To minimize cross-package dependencies, we use an abstract type [[vamp_workspace]] that VAMP declares and extend this by including a pointer to the [[sampler]] and [[instance]] objects. In the body of the sampling function, we dereference this pointer and can then work with the contents. <>= type, extends (vamp_data_t) :: mci_workspace_t class(mci_sampler_t), pointer :: sampler => null () class(mci_vamp_instance_t), pointer :: instance => null () end type mci_workspace_t @ %def mci_workspace_t @ \subsection{Integrator instance} The history entries should point to the corresponding history entry in the [[pass_t]] object. If there is none, we may allocate a local history, which is then just transient. <>= public :: mci_vamp_instance_t <>= type, extends (mci_instance_t) :: mci_vamp_instance_t type(mci_vamp_t), pointer :: mci => null () logical :: grids_defined = .false. logical :: grids_from_file = .false. integer :: n_it = 0 integer :: it = 0 logical :: pass_complete = .false. integer :: n_calls = 0 integer :: calls = 0 integer :: calls_valid = 0 logical :: it_complete = .false. logical :: enable_adapt_grids = .false. logical :: enable_adapt_weights = .false. logical :: allow_adapt_grids = .false. logical :: allow_adapt_weights = .false. integer :: n_adapt_grids = 0 integer :: n_adapt_weights = 0 logical :: generating_events = .false. real(default) :: safety_factor = 1 type(vamp_grids) :: grids real(default) :: g = 0 real(default), dimension(:), allocatable :: gi real(default) :: integral = 0 real(default) :: error = 0 real(default) :: efficiency = 0 real(default), dimension(:), allocatable :: vamp_x logical :: vamp_weight_set = .false. real(default) :: vamp_weight = 0 real(default) :: vamp_excess = 0 logical :: allocate_global_history = .false. type(vamp_history), dimension(:), pointer :: v_history => null () logical :: allocate_channel_history = .false. type(vamp_history), dimension(:,:), pointer :: v_histories => null () contains <> end type mci_vamp_instance_t @ %def mci_vamp_instance_t @ Output. <>= procedure :: write => mci_vamp_instance_write <>= subroutine mci_vamp_instance_write (object, unit, pacify) class(mci_vamp_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u, i character(len=7) :: fmt call pac_fmt (fmt, FMT_17, FMT_14, pacify) u = given_output_unit (unit) write (u, "(3x,A," // FMT_19 // ")") "Integrand = ", object%integrand write (u, "(3x,A," // FMT_19 // ")") "Weight = ", object%mci_weight if (object%vamp_weight_set) then write (u, "(3x,A," // FMT_19 // ")") "VAMP wgt = ", object%vamp_weight if (object%vamp_excess /= 0) then write (u, "(3x,A," // FMT_19 // ")") "VAMP exc = ", & object%vamp_excess end if end if write (u, "(3x,A,L1)") "adapt grids = ", object%enable_adapt_grids write (u, "(3x,A,L1)") "adapt weights = ", object%enable_adapt_weights if (object%grids_defined) then if (object%grids_from_file) then write (u, "(3x,A)") "VAMP grids: read from file" else write (u, "(3x,A)") "VAMP grids: defined" end if else write (u, "(3x,A)") "VAMP grids: [undefined]" end if write (u, "(3x,A,I0)") "n_it = ", object%n_it write (u, "(3x,A,I0)") "it = ", object%it write (u, "(3x,A,L1)") "pass complete = ", object%it_complete write (u, "(3x,A,I0)") "n_calls = ", object%n_calls write (u, "(3x,A,I0)") "calls = ", object%calls write (u, "(3x,A,I0)") "calls_valid = ", object%calls_valid write (u, "(3x,A,L1)") "it complete = ", object%it_complete write (u, "(3x,A,I0)") "n adapt.(g) = ", object%n_adapt_grids write (u, "(3x,A,I0)") "n adapt.(w) = ", object%n_adapt_weights write (u, "(3x,A,L1)") "gen. events = ", object%generating_events write (u, "(3x,A,L1)") "neg. weights = ", object%negative_weights if (object%safety_factor /= 1) write & (u, "(3x,A," // fmt // ")") "safety f = ", object%safety_factor write (u, "(3x,A," // fmt // ")") "integral = ", object%integral write (u, "(3x,A," // fmt // ")") "error = ", object%error write (u, "(3x,A," // fmt // ")") "eff. = ", object%efficiency write (u, "(3x,A)") "weights:" do i = 1, size (object%w) write (u, "(5x,I0,1x," // FMT_12 // ")") i, object%w(i) end do end subroutine mci_vamp_instance_write @ %def mci_vamp_instance_write @ Write the grids to the specified unit. <>= procedure :: write_grids => mci_vamp_instance_write_grids <>= subroutine mci_vamp_instance_write_grids (object, unit) class(mci_vamp_instance_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (object%grids_defined) then call vamp_write_grids (object%grids, u, write_integrals = .true.) end if end subroutine mci_vamp_instance_write_grids @ %def mci_vamp_instance_write_grids @ Finalizer: the history arrays are pointer arrays and need finalization. <>= procedure :: final => mci_vamp_instance_final <>= subroutine mci_vamp_instance_final (object) class(mci_vamp_instance_t), intent(inout) :: object if (object%allocate_global_history) then if (associated (object%v_history)) then call vamp_delete_history (object%v_history) deallocate (object%v_history) end if end if if (object%allocate_channel_history) then if (associated (object%v_histories)) then call vamp_delete_history (object%v_histories) deallocate (object%v_histories) end if end if if (object%grids_defined) then call vamp_delete_grids (object%grids) object%grids_defined = .false. end if end subroutine mci_vamp_instance_final @ %def mci_vamp_instance_final @ Initializer. <>= procedure :: init => mci_vamp_instance_init <>= subroutine mci_vamp_instance_init (mci_instance, mci) class(mci_vamp_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci call mci_instance%base_init (mci) select type (mci) type is (mci_vamp_t) mci_instance%mci => mci allocate (mci_instance%gi (mci%n_channel)) mci_instance%allocate_global_history = .not. mci%history_par%global mci_instance%allocate_channel_history = .not. mci%history_par%channel mci_instance%negative_weights = mci%negative_weights end select end subroutine mci_vamp_instance_init @ %def mci_vamp_instance_init @ Prepare a new integration pass: write the pass-specific settings to the [[instance]] object. This should be called initially, together with the [[create_grids]] procedure, and whenever we start a new integration pass. Set [[reshape]] if the number of calls is different than previously (unless it was zero, indicating the first pass). We link VAMP histories to the allocated histories in the current pass object, so the recorded results are persistent. However, if there are no histories present there, we allocate them locally. In that case, the histories will disappear together with the MCI instance object. <>= procedure :: new_pass => mci_vamp_instance_new_pass <>= subroutine mci_vamp_instance_new_pass (instance, reshape) class(mci_vamp_instance_t), intent(inout) :: instance logical, intent(out) :: reshape type(pass_t), pointer :: current associate (mci => instance%mci) current => mci%current_pass instance%n_it = current%n_it if (instance%n_calls == 0) then reshape = .false. instance%n_calls = current%n_calls else if (instance%n_calls == current%n_calls) then reshape = .false. else reshape = .true. instance%n_calls = current%n_calls end if instance%it = 0 instance%calls = 0 instance%calls_valid = 0 instance%enable_adapt_grids = current%adapt_grids instance%enable_adapt_weights = current%adapt_weights instance%generating_events = .false. if (instance%allocate_global_history) then if (associated (instance%v_history)) then call vamp_delete_history (instance%v_history) deallocate (instance%v_history) end if allocate (instance%v_history (instance%n_it)) call vamp_create_history (instance%v_history, verbose = .false.) else instance%v_history => current%v_history end if if (instance%allocate_channel_history) then if (associated (instance%v_histories)) then call vamp_delete_history (instance%v_histories) deallocate (instance%v_histories) end if allocate (instance%v_histories (instance%n_it, mci%n_channel)) call vamp_create_history (instance%v_histories, verbose = .false.) else instance%v_histories => current%v_histories end if end associate end subroutine mci_vamp_instance_new_pass @ %def mci_vamp_instance_new_pass @ Create a grid set within the [[instance]] object, using the data of the current integration pass. Also reset counters that track this grid set. <>= procedure :: create_grids => mci_vamp_instance_create_grids <>= subroutine mci_vamp_instance_create_grids (instance) class(mci_vamp_instance_t), intent(inout) :: instance type (pass_t), pointer :: current integer, dimension(:), allocatable :: num_div real(default), dimension(:,:), allocatable :: region associate (mci => instance%mci) current => mci%current_pass allocate (num_div (mci%n_dim)) allocate (region (2, mci%n_dim)) region(1,:) = 0 region(2,:) = 1 num_div = current%n_bins instance%n_adapt_grids = 0 instance%n_adapt_weights = 0 if (.not. instance%grids_defined) then call vamp_create_grids (instance%grids, & region, & current%n_calls, & weights = instance%w, & num_div = num_div, & stratified = mci%grid_par%stratified) instance%grids_defined = .true. else call msg_bug ("VAMP: create grids: grids already defined") end if end associate end subroutine mci_vamp_instance_create_grids @ %def mci_vamp_instance_create_grids @ Reset a grid set, so we can start a fresh integration pass. In effect, we delete results of previous integrations, but keep the grid shapes, weights, and variance arrays, so adaptation is still possible. The grids are prepared for a specific number of calls (per iteration) and sampling mode (stratified/importance). The [[vamp_discard_integrals]] implementation will reshape the grids only if the argument [[num_calls]] is present. <>= procedure :: discard_integrals => mci_vamp_instance_discard_integrals <>= subroutine mci_vamp_instance_discard_integrals (instance, reshape) class(mci_vamp_instance_t), intent(inout) :: instance logical, intent(in) :: reshape instance%calls = 0 instance%calls_valid = 0 instance%integral = 0 instance%error = 0 instance%efficiency = 0 associate (mci => instance%mci) if (instance%grids_defined) then if (mci%grid_par%use_vamp_equivalences) then if (reshape) then call vamp_discard_integrals (instance%grids, & num_calls = instance%n_calls, & stratified = mci%grid_par%stratified, & eq = mci%equivalences) else call vamp_discard_integrals (instance%grids, & stratified = mci%grid_par%stratified, & eq = mci%equivalences) end if else if (reshape) then call vamp_discard_integrals (instance%grids, & num_calls = instance%n_calls, & stratified = mci%grid_par%stratified) else call vamp_discard_integrals (instance%grids, & stratified = mci%grid_par%stratified) end if end if else call msg_bug ("VAMP: discard integrals: grids undefined") end if end associate end subroutine mci_vamp_instance_discard_integrals @ %def mci_vamp_instance_discard_integrals @ After grids are created (with equidistant binning and equal weight), adaptation is redundant. Therefore, we should allow it only after a complete integration step has been performed, calling this. <>= procedure :: allow_adaptation => mci_vamp_instance_allow_adaptation <>= subroutine mci_vamp_instance_allow_adaptation (instance) class(mci_vamp_instance_t), intent(inout) :: instance instance%allow_adapt_grids = .true. instance%allow_adapt_weights = .true. end subroutine mci_vamp_instance_allow_adaptation @ %def mci_vamp_instance_allow_adaptation @ Adapt grids. <>= procedure :: adapt_grids => mci_vamp_instance_adapt_grids <>= subroutine mci_vamp_instance_adapt_grids (instance) class(mci_vamp_instance_t), intent(inout) :: instance if (instance%enable_adapt_grids .and. instance%allow_adapt_grids) then if (instance%grids_defined) then call vamp_refine_grids (instance%grids) instance%n_adapt_grids = instance%n_adapt_grids + 1 else call msg_bug ("VAMP: adapt grids: grids undefined") end if end if end subroutine mci_vamp_instance_adapt_grids @ %def mci_vamp_instance_adapt_grids @ Adapt weights. Use the variance array returned by \vamp\ for recalculating the weight array. The parameter [[channel_weights_power]] dampens fluctuations. If the number of calls in a given channel falls below a user-defined threshold, the weight is not lowered further but kept at this threshold. The other channel weights are reduced accordingly. <>= procedure :: adapt_weights => mci_vamp_instance_adapt_weights <>= subroutine mci_vamp_instance_adapt_weights (instance) class(mci_vamp_instance_t), intent(inout) :: instance real(default) :: w_sum, w_avg_ch, sum_w_underflow, w_min real(default), dimension(:), allocatable :: weights integer :: n_ch, ch, n_underflow logical, dimension(:), allocatable :: mask, underflow type(exception) :: vamp_exception logical :: wsum_non_zero if (instance%enable_adapt_weights .and. instance%allow_adapt_weights) then associate (mci => instance%mci) if (instance%grids_defined) then allocate (weights (size (instance%grids%weights))) weights = instance%grids%weights & * vamp_get_variance (instance%grids%grids) & ** mci%grid_par%channel_weights_power w_sum = sum (weights) if (w_sum /= 0) then weights = weights / w_sum if (mci%n_chain /= 0) then allocate (mask (mci%n_channel)) do ch = 1, mci%n_chain mask = mci%chain == ch n_ch = count (mask) if (n_ch /= 0) then w_avg_ch = sum (weights, mask) / n_ch where (mask) weights = w_avg_ch end if end do end if if (mci%grid_par%threshold_calls /= 0) then w_min = & real (mci%grid_par%threshold_calls, default) & / instance%n_calls allocate (underflow (mci%n_channel)) underflow = weights /= 0 .and. abs (weights) < w_min n_underflow = count (underflow) sum_w_underflow = sum (weights, mask=underflow) if (sum_w_underflow /= 1) then where (underflow) weights = w_min elsewhere weights = weights & * (1 - n_underflow * w_min) / (1 - sum_w_underflow) end where end if end if end if call instance%set_channel_weights (weights, wsum_non_zero) if (wsum_non_zero) call vamp_update_weights & (instance%grids, weights, exc = vamp_exception) call handle_vamp_exception (vamp_exception, mci%verbose) else call msg_bug ("VAMP: adapt weights: grids undefined") end if end associate instance%n_adapt_weights = instance%n_adapt_weights + 1 end if end subroutine mci_vamp_instance_adapt_weights @ %def mci_vamp_instance_adapt_weights @ Integration: sample the VAMP grids. The number of calls etc. are already stored inside the grids. We provide the random-number generator, the sampling function, and a link to the workspace object, which happens to contain a pointer to the sampler object. The sampler object thus becomes the workspace of the sampling function. Note: in the current implementation, the random-number generator must be the TAO generator. This explicit dependence should be removed from the VAMP implementation. <>= procedure :: sample_grids => mci_vamp_instance_sample_grids <>= subroutine mci_vamp_instance_sample_grids (instance, rng, sampler, eq) class(mci_vamp_instance_t), intent(inout), target :: instance class(rng_t), intent(inout) :: rng class(mci_sampler_t), intent(inout), target :: sampler type(vamp_equivalences_t), intent(in), optional :: eq class(vamp_data_t), allocatable :: data type(exception) :: vamp_exception allocate (mci_workspace_t :: data) select type (data) type is (mci_workspace_t) data%sampler => sampler data%instance => instance end select select type (rng) type is (rng_tao_t) instance%it = instance%it + 1 instance%calls = 0 if (instance%grids_defined) then call vamp_sample_grids ( & rng%state, & instance%grids, & vamp_sampling_function, & data, & 1, & eq = eq, & history = instance%v_history(instance%it:), & histories = instance%v_histories(instance%it:,:), & integral = instance%integral, & std_dev = instance%error, & exc = vamp_exception, & negative_weights = instance%negative_weights) call handle_vamp_exception (vamp_exception, instance%mci%verbose) instance%efficiency = instance%get_efficiency () else call msg_bug ("VAMP: sample grids: grids undefined") end if class default call msg_fatal ("VAMP integration: random-number generator must be TAO") end select end subroutine mci_vamp_instance_sample_grids @ %def mci_vamp_instance_sample_grids @ Compute the reweighting efficiency for the current grids, suitable averaged over all active channels. <>= procedure :: get_efficiency_array => mci_vamp_instance_get_efficiency_array procedure :: get_efficiency => mci_vamp_instance_get_efficiency <>= function mci_vamp_instance_get_efficiency_array (mci) result (efficiency) class(mci_vamp_instance_t), intent(in) :: mci real(default), dimension(:), allocatable :: efficiency allocate (efficiency (mci%mci%n_channel)) if (.not. mci%negative_weights) then where (mci%grids%grids%f_max /= 0) efficiency = mci%grids%grids%mu(1) / abs (mci%grids%grids%f_max) elsewhere efficiency = 0 end where else where (mci%grids%grids%f_max /= 0) efficiency = & (mci%grids%grids%mu_plus(1) - mci%grids%grids%mu_minus(1)) & / abs (mci%grids%grids%f_max) elsewhere efficiency = 0 end where end if end function mci_vamp_instance_get_efficiency_array function mci_vamp_instance_get_efficiency (mci) result (efficiency) class(mci_vamp_instance_t), intent(in) :: mci real(default) :: efficiency real(default), dimension(:), allocatable :: weight real(default) :: norm allocate (weight (mci%mci%n_channel)) weight = mci%grids%weights * abs (mci%grids%grids%f_max) norm = sum (weight) if (norm /= 0) then efficiency = dot_product (mci%get_efficiency_array (), weight) / norm else efficiency = 1 end if end function mci_vamp_instance_get_efficiency @ %def mci_vamp_instance_get_efficiency_array @ %def mci_vamp_instance_get_efficiency @ Prepare an event generation pass. Should be called before a sequence of events is generated, then we should call the corresponding finalizer. The pass-specific data of the previous integration pass are retained, but we reset the number of iterations and calls to zero. The latter now counts the number of events (calls to the sampling function, actually). <>= procedure :: init_simulation => mci_vamp_instance_init_simulation <>= subroutine mci_vamp_instance_init_simulation (instance, safety_factor) class(mci_vamp_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor associate (mci => instance%mci) allocate (instance%vamp_x (mci%n_dim)) instance%it = 0 instance%calls = 0 instance%generating_events = .true. if (present (safety_factor)) instance%safety_factor = safety_factor if (.not. instance%grids_defined) then if (mci%grid_filename_set) then if (.not. mci%check_grid_file) & call msg_warning ("Reading grid file: MD5 sum check disabled") call msg_message ("Simulate: " & // "using integration grids from file '" & // char (mci%grid_filename) // "'") call mci%read_grids_data (instance) if (instance%safety_factor /= 1) then write (msg_buffer, "(A,ES10.3,A)") "Simulate: & &applying safety factor", instance%safety_factor, & " to event rejection" call msg_message () instance%grids%grids%f_max = & instance%grids%grids%f_max * instance%safety_factor end if else call msg_bug ("VAMP: simulation: no grids, no grid filename") end if end if end associate end subroutine mci_vamp_instance_init_simulation @ %def mci_vamp_init_simulation @ Finalize an event generation pass. Should be called before a sequence of events is generated, then we should call the corresponding finalizer. <>= procedure :: final_simulation => mci_vamp_instance_final_simulation <>= subroutine mci_vamp_instance_final_simulation (instance) class(mci_vamp_instance_t), intent(inout) :: instance if (allocated (instance%vamp_x)) deallocate (instance%vamp_x) end subroutine mci_vamp_instance_final_simulation @ %def mci_vamp_instance_final_simulation @ \subsection{Sampling function} The VAMP sampling function has a well-defined interface which we have to implement. The [[data]] argument allows us to pass pointers to the [[sampler]] and [[instance]] objects, so we can access configuration data and fill point-dependent contents within these objects. The [[weights]] and [[channel]] argument must be present in the call. Note: we would normally declare the [[instance]] pointer with the concrete type, or just use the [[data]] component directly. Unfortunately, gfortran 4.6 forgets the inherited base-type methods in that case. Note: this is the place where we must look for external signals, i.e., interrupt from the OS. We would like to raise a \vamp\ exception which is then caught by [[vamp_sample_grids]] as the caller, so it dumps its current state and returns (with the signal still pending). \whizard\ will then terminate gracefully. Of course, VAMP should be able to resume from the dump. In the current implementation, we handle the exception in place and terminate immediately. The incomplete current integration pass is lost. <>= function vamp_sampling_function & (xi, data, weights, channel, grids) result (f) real(default) :: f real(default), dimension(:), intent(in) :: xi class(vamp_data_t), intent(in) :: data real(default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception) :: exc logical :: verbose character(*), parameter :: FN = "WHIZARD sampling function" class(mci_instance_t), pointer :: instance select type (data) type is (mci_workspace_t) instance => data%instance select type (instance) class is (mci_vamp_instance_t) verbose = instance%mci%verbose call instance%evaluate (data%sampler, channel, xi) if (signal_is_pending ()) then call raise_exception (exc, EXC_FATAL, FN, "signal received") call handle_vamp_exception (exc, verbose) call terminate_now_if_signal () end if instance%calls = instance%calls + 1 if (data%sampler%is_valid ()) & & instance%calls_valid = instance%calls_valid + 1 f = instance%get_value () call terminate_now_if_single_event () class default call msg_bug("VAMP: " // FN // ": unknown MCI instance type") end select end select end function vamp_sampling_function @ %def vamp_sampling_function @ This is supposed to be the mapping between integration channels. The VAMP event generating procedures technically require it, but it is meaningless in our setup where all transformations happen inside the sampler object. So, this implementation is trivial: <>= pure function phi_trivial (xi, channel_dummy) result (x) real(default), dimension(:), intent(in) :: xi integer, intent(in) :: channel_dummy real(default), dimension(size(xi)) :: x x = xi end function phi_trivial @ %def phi_trivial @ \subsection{Integrator instance: evaluation} Here, we compute the multi-channel reweighting factor for the current channel, that accounts for the Jacobians of the transformations from/to all other channels. The computation of the VAMP probabilities may consume considerable time, therefore we enable parallel evaluation. (Collecting the contributions to [[mci%g]] is a reduction, which we should also implement via OpenMP.) <>= procedure :: compute_weight => mci_vamp_instance_compute_weight <>= subroutine mci_vamp_instance_compute_weight (mci, c) class(mci_vamp_instance_t), intent(inout) :: mci integer, intent(in) :: c integer :: i mci%selected_channel = c !$OMP PARALLEL PRIVATE(i) SHARED(mci) !$OMP DO do i = 1, mci%mci%n_channel if (mci%w(i) /= 0) then mci%gi(i) = vamp_probability (mci%grids%grids(i), mci%x(:,i)) else mci%gi(i) = 0 end if end do !$OMP END DO !$OMP END PARALLEL mci%g = 0 if (mci%gi(c) /= 0) then do i = 1, mci%mci%n_channel if (mci%w(i) /= 0 .and. mci%f(i) /= 0) then mci%g = mci%g + mci%w(i) * mci%gi(i) / mci%f(i) end if end do end if if (mci%g /= 0) then mci%mci_weight = mci%gi(c) / mci%g else mci%mci_weight = 0 end if end subroutine mci_vamp_instance_compute_weight @ %def mci_vamp_instance_compute_weight @ Record the integrand. <>= procedure :: record_integrand => mci_vamp_instance_record_integrand <>= subroutine mci_vamp_instance_record_integrand (mci, integrand) class(mci_vamp_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand mci%integrand = integrand end subroutine mci_vamp_instance_record_integrand @ %def mci_vamp_instance_record_integrand @ Get the event weight. The default routine returns the same value that we would use for integration. This is correct if we select the integration channel according to the channel weight. [[vamp_next_event]] does differently, so we should rather rely on the weight that VAMP returns. This is the value stored in [[vamp_weight]]. We override the default TBP accordingly. <>= procedure :: get_event_weight => mci_vamp_instance_get_event_weight procedure :: get_event_excess => mci_vamp_instance_get_event_excess <>= function mci_vamp_instance_get_event_weight (mci) result (value) class(mci_vamp_instance_t), intent(in) :: mci real(default) :: value if (mci%vamp_weight_set) then value = mci%vamp_weight else call msg_bug ("VAMP: attempt to read undefined event weight") end if end function mci_vamp_instance_get_event_weight function mci_vamp_instance_get_event_excess (mci) result (value) class(mci_vamp_instance_t), intent(in) :: mci real(default) :: value if (mci%vamp_weight_set) then value = mci%vamp_excess else call msg_bug ("VAMP: attempt to read undefined event excess weight") end if end function mci_vamp_instance_get_event_excess @ %def mci_vamp_instance_get_event_excess @ \subsection{VAMP exceptions} A VAMP routine may have raised an exception. Turn this into a WHIZARD error message. An external signal could raise a fatal exception, but this should be delayed and handled by the correct termination routine. <>= subroutine handle_vamp_exception (exc, verbose) type(exception), intent(in) :: exc logical, intent(in) :: verbose integer :: exc_level if (verbose) then exc_level = EXC_INFO else exc_level = EXC_ERROR end if if (exc%level >= exc_level) then write (msg_buffer, "(A,':',1x,A)") trim (exc%origin), trim (exc%message) select case (exc%level) case (EXC_INFO); call msg_message () case (EXC_WARN); call msg_warning () case (EXC_ERROR); call msg_error () case (EXC_FATAL) if (signal_is_pending ()) then call msg_message () else call msg_fatal () end if end select end if end subroutine handle_vamp_exception @ %def handle_vamp_exception @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[mci_vamp_ut.f90]]>>= <> module mci_vamp_ut use unit_tests use mci_vamp_uti <> <> contains <> end module mci_vamp_ut @ %def mci_vamp_ut @ <<[[mci_vamp_uti.f90]]>>= <> module mci_vamp_uti <> <> use io_units use constants, only: PI, TWOPI use rng_base use rng_tao use phs_base use mci_base use vamp, only: vamp_write_grids !NODEP! use mci_vamp <> <> <> contains <> end module mci_vamp_uti @ %def mci_vamp_ut @ API: driver for the unit tests below. <>= public :: mci_vamp_test <>= subroutine mci_vamp_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine mci_vamp_test @ %def mci_vamp_test @ \subsubsection{Test sampler} A test sampler object should implement a function with known integral that we can use to check the integrator. In mode [[1]], the function is $f(x) = 3 x^2$ with integral $\int_0^1 f(x)\,dx=1$ and maximum $f(1)=3$. If the integration dimension is greater than one, the function is extended as a constant in the other dimension(s). In mode [[2]], the function is $11 x^{10}$, also with integral $1$. Mode [[4]] includes ranges of zero and negative function value, the integral is negative. The results should be identical to the results of [[mci_midpoint_4]], where the same function is evaluated. The function is $f(x) = (1 - 3 x^2)\,\theta(x-1/2)$ with integral $\int_0^1 f(x)\,dx=-3/8$, minimum $f(1)=-2$ and maximum $f(1/2)=1/4$. <>= type, extends (mci_sampler_t) :: test_sampler_1_t real(default), dimension(:), allocatable :: x real(default) :: val integer :: mode = 1 contains <> end type test_sampler_1_t @ %def test_sampler_1_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure :: write => test_sampler_1_write <>= subroutine test_sampler_1_write (object, unit, testflag) class(test_sampler_1_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) select case (object%mode) case (1) write (u, "(1x,A)") "Test sampler: f(x) = 3 x^2" case (2) write (u, "(1x,A)") "Test sampler: f(x) = 11 x^10" case (3) write (u, "(1x,A)") "Test sampler: f(x) = 11 x^10 * 2 * cos^2 (2 pi y)" case (4) write (u, "(1x,A)") "Test sampler: f(x) = (1 - 3 x^2) theta(x - 1/2)" end select end subroutine test_sampler_1_write @ %def test_sampler_1_write @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_1_evaluate <>= subroutine test_sampler_1_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in select case (sampler%mode) case (1) sampler%val = 3 * x_in(1) ** 2 case (2) sampler%val = 11 * x_in(1) ** 10 case (3) sampler%val = 11 * x_in(1) ** 10 * 2 * cos (twopi * x_in(2)) ** 2 case (4) if (x_in(1) >= .5_default) then sampler%val = 1 - 3 * x_in(1) ** 2 else sampler%val = 0 end if end select call sampler%fetch (val, x, f) end subroutine test_sampler_1_evaluate @ %def test_sampler_1_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_1_is_valid <>= function test_sampler_1_is_valid (sampler) result (valid) class(test_sampler_1_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_1_is_valid @ %def test_sampler_1_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_1_rebuild <>= subroutine test_sampler_1_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in sampler%val = val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_rebuild @ %def test_sampler_1_rebuild @ Extract the results. <>= procedure :: fetch => test_sampler_1_fetch <>= subroutine test_sampler_1_fetch (sampler, val, x, f) class(test_sampler_1_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_fetch @ %def test_sampler_1_fetch @ \subsubsection{Two-channel, two dimension test sampler} This sampler implements the function \begin{equation} f(x, y) = 4\sin^2(\pi x)\sin^2(\pi y) + 2\sin^2(\pi v) \end{equation} where \begin{align} x &= u^v &u &= xy \\ y &= u^{(1-v)} &v &= \frac12\left(1 + \frac{\log(x/y)}{\log xy}\right) \end{align} Each term contributes $1$ to the integral. The first term in the function is peaked along a cross aligned to the coordinates $x$ and $y$, while the second term is peaked along the diagonal $x=y$. The Jacobian is \begin{equation} \frac{\partial(x,y)}{\partial(u,v)} = |\log u| \end{equation} <>= type, extends (mci_sampler_t) :: test_sampler_2_t real(default), dimension(:,:), allocatable :: x real(default), dimension(:), allocatable :: f real(default) :: val contains <> end type test_sampler_2_t @ %def test_sampler_2_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure :: write => test_sampler_2_write <>= subroutine test_sampler_2_write (object, unit, testflag) class(test_sampler_2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Two-channel test sampler 2" end subroutine test_sampler_2_write @ %def test_sampler_2_write @ Kinematics: compute $x$ and Jacobians, given the input parameter array. <>= procedure :: compute => test_sampler_2_compute <>= subroutine test_sampler_2_compute (sampler, c, x_in) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default) :: xx, yy, uu, vv if (.not. allocated (sampler%x)) & allocate (sampler%x (size (x_in), 2)) if (.not. allocated (sampler%f)) & allocate (sampler%f (2)) select case (c) case (1) xx = x_in(1) yy = x_in(2) uu = xx * yy vv = (1 + log (xx/yy) / log (xx*yy)) / 2 case (2) uu = x_in(1) vv = x_in(2) xx = uu ** vv yy = uu ** (1 - vv) end select sampler%val = (2 * sin (pi * xx) * sin (pi * yy)) ** 2 & + 2 * sin (pi * vv) ** 2 sampler%f(1) = 1 sampler%f(2) = abs (log (uu)) sampler%x(:,1) = [xx, yy] sampler%x(:,2) = [uu, vv] end subroutine test_sampler_2_compute @ %def test_sampler_kinematics @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_2_evaluate <>= subroutine test_sampler_2_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) call sampler%fetch (val, x, f) end subroutine test_sampler_2_evaluate @ %def test_sampler_2_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_2_is_valid <>= function test_sampler_2_is_valid (sampler) result (valid) class(test_sampler_2_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_2_is_valid @ %def test_sampler_2_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_2_rebuild <>= subroutine test_sampler_2_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) x = sampler%x f = sampler%f end subroutine test_sampler_2_rebuild @ %def test_sampler_2_rebuild @ Extract the results. <>= procedure :: fetch => test_sampler_2_fetch <>= subroutine test_sampler_2_fetch (sampler, val, x, f) class(test_sampler_2_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x = sampler%x f = sampler%f end subroutine test_sampler_2_fetch @ %def test_sampler_2_fetch @ \subsubsection{Two-channel, one dimension test sampler} This sampler implements the function \begin{equation} f(x, y) = a * 5 x^4 + b * 5 (1-x)^4 \end{equation} Each term contributes $1$ to the integral, multiplied by $a$ or $b$, respectively. The first term is peaked at $x=1$, the second one at $x=0$.. We implement the two mappings \begin{equation} x = u^{1/5} \quad\text{and}\quad x = 1 - v^{1/5}, \end{equation} with Jacobians \begin{equation} \frac{\partial(x)}{\partial(u)} = u^{-4/5}/5 \quad\text{and}\quad v^{-4/5}/5, \end{equation} respectively. The first mapping concentrates points near $x=1$, the second one near $x=0$. <>= type, extends (mci_sampler_t) :: test_sampler_3_t real(default), dimension(:,:), allocatable :: x real(default), dimension(:), allocatable :: f real(default) :: val real(default) :: a = 1 real(default) :: b = 1 contains <> end type test_sampler_3_t @ %def test_sampler_3_t @ Output: display $a$ and $b$ <>= procedure :: write => test_sampler_3_write <>= subroutine test_sampler_3_write (object, unit, testflag) class(test_sampler_3_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Two-channel test sampler 3" write (u, "(3x,A,F5.2)") "a = ", object%a write (u, "(3x,A,F5.2)") "b = ", object%b end subroutine test_sampler_3_write @ %def test_sampler_3_write @ Kinematics: compute $x$ and Jacobians, given the input parameter array. <>= procedure :: compute => test_sampler_3_compute <>= subroutine test_sampler_3_compute (sampler, c, x_in) class(test_sampler_3_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default) :: u, v, xx if (.not. allocated (sampler%x)) & allocate (sampler%x (size (x_in), 2)) if (.not. allocated (sampler%f)) & allocate (sampler%f (2)) select case (c) case (1) u = x_in(1) xx = u ** 0.2_default v = (1 - xx) ** 5._default case (2) v = x_in(1) xx = 1 - v ** 0.2_default u = xx ** 5._default end select sampler%val = sampler%a * 5 * xx ** 4 + sampler%b * 5 * (1 - xx) ** 4 sampler%f(1) = 0.2_default * u ** (-0.8_default) sampler%f(2) = 0.2_default * v ** (-0.8_default) sampler%x(:,1) = [u] sampler%x(:,2) = [v] end subroutine test_sampler_3_compute @ %def test_sampler_kineamtics @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure :: evaluate => test_sampler_3_evaluate <>= subroutine test_sampler_3_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_3_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) call sampler%fetch (val, x, f) end subroutine test_sampler_3_evaluate @ %def test_sampler_3_evaluate @ The point is always valid. <>= procedure :: is_valid => test_sampler_3_is_valid <>= function test_sampler_3_is_valid (sampler) result (valid) class(test_sampler_3_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_3_is_valid @ %def test_sampler_3_is_valid @ Rebuild: compute all but the function value. <>= procedure :: rebuild => test_sampler_3_rebuild <>= subroutine test_sampler_3_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_3_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) x = sampler%x f = sampler%f end subroutine test_sampler_3_rebuild @ %def test_sampler_3_rebuild @ Extract the results. <>= procedure :: fetch => test_sampler_3_fetch <>= subroutine test_sampler_3_fetch (sampler, val, x, f) class(test_sampler_3_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x = sampler%x f = sampler%f end subroutine test_sampler_3_fetch @ %def test_sampler_3_fetch @ \subsubsection{One-dimensional integration} Construct an integrator and use it for a one-dimensional sampler. Note: We would like to check the precise contents of the grid allocated during integration, but the output format for reals is very long (for good reasons), so the last digits in the grid content display are numerical noise. So, we just check the integration results. <>= call test (mci_vamp_1, "mci_vamp_1", & "one-dimensional integral", & u, results) <>= public :: mci_vamp_1 <>= subroutine mci_vamp_1 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_1" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_1_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") " (lower precision to avoid" write (u, "(A)") " numerical noise)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass () end select call mci%integrate (mci_instance, sampler, 1, 1000, pacify = .true.) call mci%write (u, .true.) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u, .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_1" end subroutine mci_vamp_1 @ %def mci_vamp_1 @ \subsubsection{Multiple iterations} Construct an integrator and use it for a one-dimensional sampler. Integrate with five iterations without grid adaptation. <>= call test (mci_vamp_2, "mci_vamp_2", & "multiple iterations", & u, results) <>= public :: mci_vamp_2 <>= subroutine mci_vamp_2 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_2" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 2 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 100" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .false.) end select call mci%integrate (mci_instance, sampler, 3, 100) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_2" end subroutine mci_vamp_2 @ %def mci_vamp_2 @ \subsubsection{Grid adaptation} Construct an integrator and use it for a one-dimensional sampler. Integrate with three iterations and in-between grid adaptations. <>= call test (mci_vamp_3, "mci_vamp_3", & "grid adaptation", & u, results) <>= public :: mci_vamp_3 <>= subroutine mci_vamp_3 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_3" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") "* and adapt grid" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 2 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 100" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 100) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_3" end subroutine mci_vamp_3 @ %def mci_vamp_3 @ \subsubsection{Two-dimensional integral} Construct an integrator and use it for a two-dimensional sampler. Integrate with three iterations and in-between grid adaptations. <>= call test (mci_vamp_4, "mci_vamp_4", & "two-dimensional integration", & u, results) <>= public :: mci_vamp_4 <>= subroutine mci_vamp_4 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_4" write (u, "(A)") "* Purpose: integrate function in two dimensions & &(single channel)" write (u, "(A)") "* and adapt grid" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 3 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_4" end subroutine mci_vamp_4 @ %def mci_vamp_4 @ \subsubsection{Two-channel integral} Construct an integrator and use it for a two-dimensional sampler with two channels. Integrate with three iterations and in-between grid adaptations. <>= call test (mci_vamp_5, "mci_vamp_5", & "two-dimensional integration", & u, results) <>= public :: mci_vamp_5 <>= subroutine mci_vamp_5 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_5" write (u, "(A)") "* Purpose: integrate function in two dimensions & &(two channels)" write (u, "(A)") "* and adapt grid" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_2_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_5" end subroutine mci_vamp_5 @ %def mci_vamp_5 @ \subsubsection{Weight adaptation} Construct an integrator and use it for a one-dimensional sampler with two channels. Integrate with three iterations and in-between weight adaptations. <>= call test (mci_vamp_6, "mci_vamp_6", & "weight adaptation", & u, results) <>= public :: mci_vamp_6 <>= subroutine mci_vamp_6 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_6" write (u, "(A)") "* Purpose: integrate function in one dimension & &(two channels)" write (u, "(A)") "* and adapt weights" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_3_t :: sampler) select type (sampler) type is (test_sampler_3_t) sampler%a = 0.9_default sampler%b = 0.1_default end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_weights = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () deallocate (mci_instance) deallocate (mci) write (u, "(A)") write (u, "(A)") "* Re-initialize with chained channels" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) call mci%declare_chains ([1,1]) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_weights = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_6" end subroutine mci_vamp_6 @ %def mci_vamp_6 @ \subsubsection{Equivalences} Construct an integrator and use it for a one-dimensional sampler with two channels. Integrate with three iterations and in-between grid adaptations. Apply an equivalence between the two channels, so the binning of the two channels is forced to coincide. Compare this with the behavior without equivalences. <>= call test (mci_vamp_7, "mci_vamp_7", & "use channel equivalences", & u, results) <>= public :: mci_vamp_7 <>= subroutine mci_vamp_7 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler type(phs_channel_t), dimension(:), allocatable :: channel class(rng_t), allocatable :: rng real(default), dimension(:,:), allocatable :: x integer :: u_grid, iostat, i, div, ch character(16) :: buffer write (u, "(A)") "* Test output: mci_vamp_7" write (u, "(A)") "* Purpose: check effect of channel equivalences" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_3_t :: sampler) select type (sampler) type is (test_sampler_3_t) sampler%a = 0.7_default sampler%b = 0.3_default end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 2 and n_calls = 1000, & &adapt grids" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 2, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Write grids and extract binning" write (u, "(A)") u_grid = free_unit () open (u_grid, status = "scratch", action = "readwrite") select type (mci_instance) type is (mci_vamp_instance_t) call vamp_write_grids (mci_instance%grids, u_grid) end select rewind (u_grid) allocate (x (0:20, 2)) do div = 1, 2 FIND_BINS1: do read (u_grid, "(A)") buffer if (trim (adjustl (buffer)) == "begin d%x") then do read (u_grid, *, iostat = iostat) i, x(i,div) if (iostat /= 0) exit FIND_BINS1 end do end if end do FIND_BINS1 end do close (u_grid) write (u, "(1x,A,L1)") "Equal binning in both channels = ", & all (x(:,1) == x(:,2)) deallocate (x) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () deallocate (mci_instance) deallocate (mci) write (u, "(A)") write (u, "(A)") "* Re-initialize integrator, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .true. call mci%set_grid_parameters (grid_par) end select write (u, "(A)") "* Define equivalences" write (u, "(A)") allocate (channel (2)) do ch = 1, 2 allocate (channel(ch)%eq (2)) do i = 1, 2 associate (eq => channel(ch)%eq(i)) call eq%init (1) eq%c = i eq%perm = [1] eq%mode = [0] end associate end do write (u, "(1x,I0,':')", advance = "no") ch call channel(ch)%write (u) end do call mci%declare_equivalences (channel, dim_offset = 0) allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 2 and n_calls = 1000, & &adapt grids" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 2, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Write grids and extract binning" write (u, "(A)") u_grid = free_unit () open (u_grid, status = "scratch", action = "readwrite") select type (mci_instance) type is (mci_vamp_instance_t) call vamp_write_grids (mci_instance%grids, u_grid) end select rewind (u_grid) allocate (x (0:20, 2)) do div = 1, 2 FIND_BINS2: do read (u_grid, "(A)") buffer if (trim (adjustl (buffer)) == "begin d%x") then do read (u_grid, *, iostat = iostat) i, x(i,div) if (iostat /= 0) exit FIND_BINS2 end do end if end do FIND_BINS2 end do close (u_grid) write (u, "(1x,A,L1)") "Equal binning in both channels = ", & all (x(:,1) == x(:,2)) deallocate (x) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_7" end subroutine mci_vamp_7 @ %def mci_vamp_7 @ \subsubsection{Multiple passes} Integrate with three passes and different settings for weight and grid adaptation. <>= call test (mci_vamp_8, "mci_vamp_8", & "integration passes", & u, results) <>= public :: mci_vamp_8 <>= subroutine mci_vamp_8 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_8" write (u, "(A)") "* Purpose: integrate function in one dimension & &(two channels)" write (u, "(A)") "* in three passes" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_3_t :: sampler) select type (sampler) type is (test_sampler_3_t) sampler%a = 0.9_default sampler%b = 0.1_default end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with grid and weight adaptation" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true., adapt_weights = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with grid adaptation" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Integrate without adaptation" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass () end select call mci%integrate (mci_instance, sampler, 3, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_8" end subroutine mci_vamp_8 @ %def mci_vamp_8 @ \subsubsection{Weighted events} Construct an integrator and use it for a two-dimensional sampler with two channels. Integrate and generate a weighted event. <>= call test (mci_vamp_9, "mci_vamp_9", & "weighted event", & u, results) <>= public :: mci_vamp_9 <>= subroutine mci_vamp_9 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_9" write (u, "(A)") "* Purpose: integrate function in two dimensions & &(two channels)" write (u, "(A)") "* and generate a weighted event" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_2_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") call mci%add_pass () call mci%integrate (mci_instance, sampler, 1, 1000) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Generate a weighted event" write (u, "(A)") call mci_instance%init_simulation () call mci%generate_weighted_event (mci_instance, sampler) write (u, "(1x,A)") "MCI instance:" call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final_simulation () call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_9" end subroutine mci_vamp_9 @ %def mci_vamp_9 @ \subsubsection{Grids I/O} Construct an integrator and allocate grids. Write grids to file, read them in again and compare. <>= call test (mci_vamp_10, "mci_vamp_10", & "grids I/O", & u, results) <>= public :: mci_vamp_10 <>= subroutine mci_vamp_10 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng type(string_t) :: file1, file2 character(80) :: buffer1, buffer2 integer :: u1, u2, iostat1, iostat2 logical :: equal, success write (u, "(A)") "* Test output: mci_vamp_10" write (u, "(A)") "* Purpose: write and read VAMP grids" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) mci%md5sum = "1234567890abcdef1234567890abcdef" call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_2_t :: sampler) call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") call mci%add_pass () call mci%integrate (mci_instance, sampler, 1, 1000) write (u, "(A)") "* Write grids to file" write (u, "(A)") file1 = "mci_vamp_10.1" select type (mci) type is (mci_vamp_t) call mci%set_grid_filename (file1) call mci%write_grids (mci_instance) end select call mci_instance%final () call mci%final () deallocate (mci) write (u, "(A)") "* Read grids from file" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) mci%md5sum = "1234567890abcdef1234567890abcdef" call mci%allocate_instance (mci_instance) call mci_instance%init (mci) select type (mci) type is (mci_vamp_t) call mci%set_grid_filename (file1) call mci%add_pass () call mci%current_pass%configure (1, 1000, & mci%min_calls, & mci%grid_par%min_bins, mci%grid_par%max_bins, & mci%grid_par%min_calls_per_channel * mci%n_channel) call mci%read_grids_header (success) call mci%compute_md5sum () call mci%read_grids_data (mci_instance, read_integrals = .true.) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") write (u, "(A)") "* Write grids again" write (u, "(A)") file2 = "mci_vamp_10.2" select type (mci) type is (mci_vamp_t) call mci%set_grid_filename (file2) call mci%write_grids (mci_instance) end select u1 = free_unit () open (u1, file = char (file1) // ".vg", action = "read", status = "old") u2 = free_unit () open (u2, file = char (file2) // ".vg", action = "read", status = "old") equal = .true. iostat1 = 0 iostat2 = 0 do while (equal .and. iostat1 == 0 .and. iostat2 == 0) read (u1, "(A)", iostat = iostat1) buffer1 read (u2, "(A)", iostat = iostat2) buffer2 equal = buffer1 == buffer2 .and. iostat1 == iostat2 end do close (u1) close (u2) if (equal) then write (u, "(1x,A)") "Success: grid files are identical" else write (u, "(1x,A)") "Failure: grid files differ" end if write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_10" end subroutine mci_vamp_10 @ %def mci_vamp_10 @ \subsubsection{Weighted events with grid I/O} Construct an integrator and use it for a two-dimensional sampler with two channels. Integrate, write grids, and generate a weighted event using the grids from file. <>= call test (mci_vamp_11, "mci_vamp_11", & "weighted events with grid I/O", & u, results) <>= public :: mci_vamp_11 <>= subroutine mci_vamp_11 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_11" write (u, "(A)") "* Purpose: integrate function in two dimensions & &(two channels)" write (u, "(A)") "* and generate a weighted event" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) call mci%set_grid_filename (var_str ("mci_vamp_11")) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_2_t :: sampler) write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") call mci%add_pass () call mci%integrate (mci_instance, sampler, 1, 1000) write (u, "(A)") "* Reset instance" write (u, "(A)") call mci_instance%final () call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Generate a weighted event" write (u, "(A)") call mci_instance%init_simulation () call mci%generate_weighted_event (mci_instance, sampler) write (u, "(A)") "* Cleanup" call mci_instance%final_simulation () call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_11" end subroutine mci_vamp_11 @ %def mci_vamp_11 @ \subsubsection{Unweighted events with grid I/O} Construct an integrator and use it for a two-dimensional sampler with two channels. <>= call test (mci_vamp_12, "mci_vamp_12", & "unweighted events with grid I/O", & u, results) <>= public :: mci_vamp_12 <>= subroutine mci_vamp_12 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_12" write (u, "(A)") "* Purpose: integrate function in two dimensions & &(two channels)" write (u, "(A)") "* and generate an unweighted event" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) call mci%set_grid_filename (var_str ("mci_vamp_12")) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_2_t :: sampler) write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 1000" write (u, "(A)") call mci%add_pass () call mci%integrate (mci_instance, sampler, 1, 1000) write (u, "(A)") "* Reset instance" write (u, "(A)") call mci_instance%final () call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Generate an unweighted event" write (u, "(A)") call mci_instance%init_simulation () call mci%generate_unweighted_event (mci_instance, sampler) write (u, "(1x,A)") "MCI instance:" call mci_instance%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final_simulation () call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_12" end subroutine mci_vamp_12 @ %def mci_vamp_12 @ \subsubsection{Update integration results} Compare two [[mci]] objects; match the two and update the first if successful. <>= call test (mci_vamp_13, "mci_vamp_13", & "updating integration results", & u, results) <>= public :: mci_vamp_13 <>= subroutine mci_vamp_13 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci, mci_ref logical :: success write (u, "(A)") "* Test output: mci_vamp_13" write (u, "(A)") "* Purpose: match and update integrators" write (u, "(A)") write (u, "(A)") "* Initialize integrator with no passes" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (2, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) end select call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize reference" write (u, "(A)") allocate (mci_vamp_t :: mci_ref) call mci_ref%set_dimensions (2, 2) select type (mci_ref) type is (mci_vamp_t) call mci_ref%set_grid_parameters (grid_par) end select select type (mci_ref) type is (mci_vamp_t) call mci_ref%add_pass (adapt_grids = .true.) call mci_ref%current_pass%configure (2, 1000, 0, 1, 5, 0) mci_ref%current_pass%calls = [77, 77] mci_ref%current_pass%integral = [1.23_default, 3.45_default] mci_ref%current_pass%error = [0.23_default, 0.45_default] mci_ref%current_pass%efficiency = [0.1_default, 0.6_default] mci_ref%current_pass%integral_defined = .true. call mci_ref%add_pass () call mci_ref%current_pass%configure (2, 2000, 0, 1, 7, 0) mci_ref%current_pass%calls = [99, 0] mci_ref%current_pass%integral = [7.89_default, 0._default] mci_ref%current_pass%error = [0.89_default, 0._default] mci_ref%current_pass%efficiency = [0.86_default, 0._default] mci_ref%current_pass%integral_defined = .true. end select call mci_ref%write (u) write (u, "(A)") write (u, "(A)") "* Update integrator (no-op, should succeed)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Add pass to integrator" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) call mci%current_pass%configure (2, 1000, 0, 1, 5, 0) mci%current_pass%calls = [77, 77] mci%current_pass%integral = [1.23_default, 3.45_default] mci%current_pass%error = [0.23_default, 0.45_default] mci%current_pass%efficiency = [0.1_default, 0.6_default] mci%current_pass%integral_defined = .true. end select write (u, "(A)") "* Update integrator (no-op, should succeed)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Add pass to integrator, wrong parameters" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass () call mci%current_pass%configure (2, 1000, 0, 1, 7, 0) end select write (u, "(A)") "* Update integrator (should fail)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Reset and add passes to integrator" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%reset () call mci%add_pass (adapt_grids = .true.) call mci%current_pass%configure (2, 1000, 0, 1, 5, 0) mci%current_pass%calls = [77, 77] mci%current_pass%integral = [1.23_default, 3.45_default] mci%current_pass%error = [0.23_default, 0.45_default] mci%current_pass%efficiency = [0.1_default, 0.6_default] mci%current_pass%integral_defined = .true. call mci%add_pass () call mci%current_pass%configure (2, 2000, 0, 1, 7, 0) end select write (u, "(A)") "* Update integrator (should succeed)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Update again (no-op, should succeed)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Add extra result to integrator" write (u, "(A)") select type (mci) type is (mci_vamp_t) mci%current_pass%calls(2) = 1234 end select write (u, "(A)") "* Update integrator (should fail)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%update_from_ref (mci_ref, success) end select write (u, "(1x,A,L1)") "success = ", success write (u, "(A)") call mci%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci%final () call mci_ref%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_13" end subroutine mci_vamp_13 @ %def mci_vamp_13 @ \subsubsection{Accuracy Goal} Integrate with multiple iterations. Skip iterations once an accuracy goal has been reached. <>= call test (mci_vamp_14, "mci_vamp_14", & "accuracy goal", & u, results) <>= public :: mci_vamp_14 <>= subroutine mci_vamp_14 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_14" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") "* and check accuracy goal" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. grid_par%accuracy_goal = 5E-2_default call mci%set_grid_parameters (grid_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 2 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 5 and n_calls = 100" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 5, 100) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_14" end subroutine mci_vamp_14 @ %def mci_vamp_14 @ \subsubsection{VAMP history} Integrate with three passes and different settings for weight and grid adaptation. Then show the VAMP history. <>= call test (mci_vamp_15, "mci_vamp_15", & "VAMP history", & u, results) <>= public :: mci_vamp_15 <>= subroutine mci_vamp_15 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par type(history_parameters_t) :: history_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_15" write (u, "(A)") "* Purpose: integrate function in one dimension & &(two channels)" write (u, "(A)") "* in three passes, show history" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") history_par%channel = .true. allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 2) select type (mci) type is (mci_vamp_t) grid_par%stratified = .false. grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) call mci%set_history_parameters (history_par) end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_3_t :: sampler) select type (sampler) type is (test_sampler_3_t) sampler%a = 0.9_default sampler%b = 0.1_default end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Pass 1: grid and weight adaptation" select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true., adapt_weights = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) write (u, "(A)") write (u, "(A)") "* Pass 2: grid adaptation" select type (mci) type is (mci_vamp_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000) write (u, "(A)") write (u, "(A)") "* Pass 3: without adaptation" select type (mci) type is (mci_vamp_t) call mci%add_pass () end select call mci%integrate (mci_instance, sampler, 3, 1000) write (u, "(A)") write (u, "(A)") "* Contents of MCI record, with history" write (u, "(A)") call mci%write (u) select type (mci) type is (mci_vamp_t) call mci%write_history (u) end select write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_15" end subroutine mci_vamp_15 @ %def mci_vamp_15 @ \subsubsection{One-dimensional integration with sign change} Construct an integrator and use it for a one-dimensional sampler. <>= call test (mci_vamp_16, "mci_vamp_16", & "1-D integral with sign change", & u, results) <>= public :: mci_vamp_16 <>= subroutine mci_vamp_16 (u) integer, intent(in) :: u type(grid_parameters_t) :: grid_par class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng write (u, "(A)") "* Test output: mci_vamp_16" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") write (u, "(A)") "* Initialize integrator" write (u, "(A)") allocate (mci_vamp_t :: mci) call mci%set_dimensions (1, 1) select type (mci) type is (mci_vamp_t) grid_par%use_vamp_equivalences = .false. call mci%set_grid_parameters (grid_par) mci%negative_weights = .true. end select allocate (rng_tao_t :: rng) call rng%init () call mci%import_rng (rng) call mci%write (u) write (u, "(A)") write (u, "(A)") "* Initialize instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") "* Initialize test sampler" write (u, "(A)") allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 4 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") " (lower precision to avoid" write (u, "(A)") " numerical noise)" write (u, "(A)") select type (mci) type is (mci_vamp_t) call mci%add_pass () end select call mci%integrate (mci_instance, sampler, 1, 1000, pacify = .true.) call mci%write (u, .true.) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u, .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp_16" end subroutine mci_vamp_16 @ %def mci_vamp_16 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Multi-channel integration with VAMP2} \label{sec:vegas-integration} The multi-channel integration uses VEGAS as backbone integrator. The base interface for the multi-channel integration is given by [[mci_base]] module. We interface the VAMP2 interface given by [[vamp2]] module. <<[[mci_vamp2.f90]]>>= <> module mci_vamp2 <> <> use io_units use format_utils, only: pac_fmt use format_utils, only: write_separator, write_indent use format_defs, only: FMT_12, FMT_14, FMT_17, FMT_19 use constants, only: tiny_13 use diagnostics use md5 use phs_base use rng_base use mci_base use vegas, only: VEGAS_MODE_IMPORTANCE, VEGAS_MODE_IMPORTANCE_ONLY use vamp2 <> <> <> <> <> contains <> end module mci_vamp2 @ %def mci_vamp2 <>= @ <>= use mpi_f08 !NODEP! @ %def mpi_f08 @ \subsection{Type: mci\_vamp2\_func\_t} \label{sec:mci-vamp2-func} <>= type, extends (vamp2_func_t) :: mci_vamp2_func_t private real(default) :: integrand = 0. class(mci_sampler_t), pointer :: sampler => null () class(mci_vamp2_instance_t), pointer :: instance => null () contains <> end type mci_vamp2_func_t @ %def mci_vamp2_func_t @ Set instance and sampler aka workspace. Also, reset number of [[n_calls]]. <>= procedure, public :: set_workspace => mci_vamp2_func_set_workspace <>= subroutine mci_vamp2_func_set_workspace (self, instance, sampler) class(mci_vamp2_func_t), intent(inout) :: self class(mci_vamp2_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler self%instance => instance self%sampler => sampler end subroutine mci_vamp2_func_set_workspace @ %def mci_vamp2_func_set_workspace @ Get the different channel probabilities. <>= procedure, public :: get_probabilities => mci_vamp2_func_get_probabilities <>= function mci_vamp2_func_get_probabilities (self) result (gi) class(mci_vamp2_func_t), intent(inout) :: self real(default), dimension(self%n_channel) :: gi gi = self%gi end function mci_vamp2_func_get_probabilities @ %def mci_vamp2_func_get_probabilities @ Get multi-channel weight. <>= procedure, public :: get_weight => mci_vamp2_func_get_weight <>= real(default) function mci_vamp2_func_get_weight (self) result (g) class(mci_vamp2_func_t), intent(in) :: self g = self%g end function mci_vamp2_func_get_weight @ %def mci_vamp2_func_get_weight @ Set integrand. <>= procedure, public :: set_integrand => mci_vamp2_func_set_integrand <>= subroutine mci_vamp2_func_set_integrand (self, integrand) class(mci_vamp2_func_t), intent(inout) :: self real(default), intent(in) :: integrand self%integrand = integrand end subroutine mci_vamp2_func_set_integrand @ %def mci_vamp2_func_set_integrand @ Evaluate the mappings. <>= procedure, public :: evaluate_maps => mci_vamp2_func_evaluate_maps <>= subroutine mci_vamp2_func_evaluate_maps (self, x) class(mci_vamp2_func_t), intent(inout) :: self real(default), dimension(:), intent(in) :: x select type (self) type is (mci_vamp2_func_t) call self%instance%evaluate (self%sampler, self%current_channel, x) end select self%valid_x = self%instance%valid self%xi = self%instance%x self%det = self%instance%f end subroutine mci_vamp2_func_evaluate_maps @ %def mci_vamp2_func_evaluate_maps @ Evaluate the function, more or less. <>= procedure, public :: evaluate_func => mci_vamp2_func_evaluate_func <>= real(default) function mci_vamp2_func_evaluate_func (self, x) result (f) class(mci_vamp2_func_t), intent(in) :: self real(default), dimension(:), intent(in) :: x f = self%integrand if (signal_is_pending ()) then call msg_message ("MCI VAMP2: function evaluate_func: signal received") call terminate_now_if_signal () end if call terminate_now_if_single_event () end function mci_vamp2_func_evaluate_func @ %def mci_vamp2_func_evaluate_func @ \subsection{Type: mci\_vamp2\_config\_t} We extend [[vamp2_config_t]]. <>= public :: mci_vamp2_config_t <>= type, extends (vamp2_config_t) :: mci_vamp2_config_t ! end type mci_vamp2_config_t @ %def mci_vamp2_config_t @ \subsection{Integration pass} The list of passes is organized in a separate container. We store the parameters and results for each integration pass in [[pass_t]] and the linked list is stored in [[list_pass_t]]. <>= type :: list_pass_t type(pass_t), pointer :: first => null () type(pass_t), pointer :: current => null () contains <> end type list_pass_t @ %def list_pass_t @ Finalizer. Deallocate each element of the list beginning by the first. <>= procedure :: final => list_pass_final <>= subroutine list_pass_final (self) class(list_pass_t), intent(inout) :: self type(pass_t), pointer :: current current => self%first do while (associated (current)) self%first => current%next deallocate (current) current => self%first end do end subroutine list_pass_final @ %def pass_final @ Add a new pass. <>= procedure :: add => list_pass_add <>= subroutine list_pass_add (self, adapt_grids, adapt_weights, final_pass) class(list_pass_t), intent(inout) :: self logical, intent(in), optional :: adapt_grids, adapt_weights, final_pass type(pass_t), pointer :: new_pass allocate (new_pass) new_pass%i_pass = 1 new_pass%i_first_it = 1 new_pass%adapt_grids = .false.; if (present (adapt_grids)) & & new_pass%adapt_grids = adapt_grids new_pass%adapt_weights = .false.; if (present (adapt_weights)) & & new_pass%adapt_weights = adapt_weights new_pass%is_final_pass = .false.; if (present (final_pass)) & & new_pass%is_final_pass = final_pass if (.not. associated (self%first)) then self%first => new_pass else new_pass%i_pass = new_pass%i_pass + self%current%i_pass new_pass%i_first_it = self%current%i_first_it + self%current%n_it self%current%next => new_pass end if self%current => new_pass end subroutine list_pass_add @ %def list_pass_add @ Update list from a reference. All passes except for the last one must match exactly. For the last one, integration results are updated. The reference output may contain extra passes, these are ignored. <>= procedure :: update_from_ref => list_pass_update_from_ref <>= subroutine list_pass_update_from_ref (self, ref, success) class(list_pass_t), intent(inout) :: self type(list_pass_t), intent(in) :: ref logical, intent(out) :: success type(pass_t), pointer :: current, ref_current current => self%first ref_current => ref%first success = .true. do while (success .and. associated (current)) if (associated (ref_current)) then if (associated (current%next)) then success = current .matches. ref_current else call current%update (ref_current, success) end if current => current%next ref_current => ref_current%next else success = .false. end if end do end subroutine list_pass_update_from_ref @ %def list_pass_update_from_ref @ Output. Write the complete linked list to the specified unit. <>= procedure :: write => list_pass_write <>= subroutine list_pass_write (self, unit, pacify) class(list_pass_t), intent(in) :: self integer, intent(in) :: unit logical, intent(in), optional :: pacify type(pass_t), pointer :: current current => self%first do while (associated (current)) write (unit, "(1X,A)") "Integration pass:" call current%write (unit, pacify) current => current%next end do end subroutine list_pass_write @ %def list_pass_write @ The parameters and results are stored in the nodes [[pass_t]] of the linked list. <>= type :: pass_t integer :: i_pass = 0 integer :: i_first_it = 0 integer :: n_it = 0 integer :: n_calls = 0 logical :: adapt_grids = .false. logical :: adapt_weights = .false. logical :: is_final_pass = .false. logical :: integral_defined = .false. integer, dimension(:), allocatable :: calls integer, dimension(:), allocatable :: calls_valid real(default), dimension(:), allocatable :: integral real(default), dimension(:), allocatable :: error real(default), dimension(:), allocatable :: efficiency type(pass_t), pointer :: next => null () contains <> end type pass_t @ %def pass_t @ Output. Note that the precision of the numerical values should match the precision for comparing output from file with data. <>= procedure :: write => pass_write <>= subroutine pass_write (self, unit, pacify) class(pass_t), intent(in) :: self integer, intent(in) :: unit logical, intent(in), optional :: pacify integer :: u, i real(default) :: pac_error character(len=7) :: fmt call pac_fmt (fmt, FMT_17, FMT_14, pacify) u = given_output_unit (unit) write (u, "(3X,A,I0)") "n_it = ", self%n_it write (u, "(3X,A,I0)") "n_calls = ", self%n_calls write (u, "(3X,A,L1)") "adapt grids = ", self%adapt_grids write (u, "(3X,A,L1)") "adapt weights = ", self%adapt_weights if (self%integral_defined) then write (u, "(3X,A)") "Results: [it, calls, valid, integral, error, efficiency]" do i = 1, self%n_it if (abs (self%error(i)) > tiny_13) then pac_error = self%error(i) else pac_error = 0 end if write (u, "(5x,I0,2(1x,I0),3(1x," // fmt // "))") & i, self%calls(i), self%calls_valid(i), self%integral(i), & pac_error, self%efficiency(i) end do else write (u, "(3x,A)") "Results: [undefined]" end if end subroutine pass_write @ %def pass_write @ Read and reconstruct the pass. <>= procedure :: read => pass_read <>= subroutine pass_read (self, u, n_pass, n_it) class(pass_t), intent(out) :: self integer, intent(in) :: u, n_pass, n_it integer :: i, j character(80) :: buffer self%i_pass = n_pass + 1 self%i_first_it = n_it + 1 call read_ival (u, self%n_it) call read_ival (u, self%n_calls) call read_lval (u, self%adapt_grids) call read_lval (u, self%adapt_weights) allocate (self%calls (self%n_it), source = 0) allocate (self%calls_valid (self%n_it), source = 0) allocate (self%integral (self%n_it), source = 0._default) allocate (self%error (self%n_it), source = 0._default) allocate (self%efficiency (self%n_it), source = 0._default) read (u, "(A)") buffer select case (trim (adjustl (buffer))) case ("Results: [it, calls, valid, integral, error, efficiency]") do i = 1, self%n_it read (u, *) & j, self%calls(i), self%calls_valid(i), self%integral(i), self%error(i), & self%efficiency(i) end do self%integral_defined = .true. case ("Results: [undefined]") self%integral_defined = .false. case default call msg_fatal ("Reading integration pass: corrupted file") end select end subroutine pass_read @ %def pass_read @ Auxiliary: Read real, integer, string value. We search for an equals sign, the value must follow. <>= subroutine read_rval (u, rval) integer, intent(in) :: u real(default), intent(out) :: rval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) rval end subroutine read_rval subroutine read_ival (u, ival) integer, intent(in) :: u integer, intent(out) :: ival character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) ival end subroutine read_ival subroutine read_sval (u, sval) integer, intent(in) :: u character(*), intent(out) :: sval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) sval end subroutine read_sval subroutine read_lval (u, lval) integer, intent(in) :: u logical, intent(out) :: lval character(80) :: buffer read (u, "(A)") buffer buffer = adjustl (buffer(scan (buffer, "=") + 1:)) read (buffer, *) lval end subroutine read_lval @ %def read_rval read_ival read_sval read_lval @ Configure. We adjust the number of [[n_calls]], if it is lower than [[n_calls_min_per_channel]] times [[b_channel]], and print a warning message. <>= procedure :: configure => pass_configure <>= subroutine pass_configure (pass, n_it, n_calls, n_calls_min) class(pass_t), intent(inout) :: pass integer, intent(in) :: n_it integer, intent(in) :: n_calls integer, intent(in) :: n_calls_min pass%n_it = n_it pass%n_calls = max (n_calls, n_calls_min) if (pass%n_calls /= n_calls) then write (msg_buffer, "(A,I0)") "VAMP2: too few calls, resetting " & // "n_calls to ", pass%n_calls call msg_warning () end if allocate (pass%calls (n_it), source = 0) allocate (pass%calls_valid (n_it), source = 0) allocate (pass%integral (n_it), source = 0._default) allocate (pass%error (n_it), source = 0._default) allocate (pass%efficiency (n_it), source = 0._default) end subroutine pass_configure @ %def pass_configure @ Given two pass objects, compare them. All parameters must match. Where integrations are done in both (number of calls nonzero), the results must be equal (up to numerical noise). The allocated array sizes might be different, but should match up to the common [[n_it]] value. <>= interface operator (.matches.) module procedure pass_matches end interface operator (.matches.) <>= function pass_matches (pass, ref) result (ok) type(pass_t), intent(in) :: pass, ref integer :: n logical :: ok ok = .true. if (ok) ok = pass%i_pass == ref%i_pass if (ok) ok = pass%i_first_it == ref%i_first_it if (ok) ok = pass%n_it == ref%n_it if (ok) ok = pass%n_calls == ref%n_calls if (ok) ok = pass%adapt_grids .eqv. ref%adapt_grids if (ok) ok = pass%adapt_weights .eqv. ref%adapt_weights if (ok) ok = pass%integral_defined .eqv. ref%integral_defined if (pass%integral_defined) then n = pass%n_it if (ok) ok = all (pass%calls(:n) == ref%calls(:n)) if (ok) ok = all (pass%calls_valid(:n) == ref%calls_valid(:n)) if (ok) ok = all (pass%integral(:n) .matches. ref%integral(:n)) if (ok) ok = all (pass%error(:n) .matches. ref%error(:n)) if (ok) ok = all (pass%efficiency(:n) .matches. ref%efficiency(:n)) end if end function pass_matches @ %def pass_matches @ Update a pass object, given a reference. The parameters must match, except for the [[n_it]] entry. The number of complete iterations must be less or equal to the reference, and the number of complete iterations in the reference must be no larger than [[n_it]]. Where results are present in both passes, they must match. Where results are present in the reference only, the pass is updated accordingly. <>= procedure :: update => pass_update <>= subroutine pass_update (pass, ref, ok) class(pass_t), intent(inout) :: pass type(pass_t), intent(in) :: ref logical, intent(out) :: ok integer :: n, n_ref ok = .true. if (ok) ok = pass%i_pass == ref%i_pass if (ok) ok = pass%i_first_it == ref%i_first_it if (ok) ok = pass%n_calls == ref%n_calls if (ok) ok = pass%adapt_grids .eqv. ref%adapt_grids if (ok) ok = pass%adapt_weights .eqv. ref%adapt_weights if (ok) then if (ref%integral_defined) then if (.not. allocated (pass%calls)) then allocate (pass%calls (pass%n_it), source = 0) allocate (pass%calls_valid (pass%n_it), source = 0) allocate (pass%integral (pass%n_it), source = 0._default) allocate (pass%error (pass%n_it), source = 0._default) allocate (pass%efficiency (pass%n_it), source = 0._default) end if n = count (pass%calls /= 0) n_ref = count (ref%calls /= 0) ok = n <= n_ref .and. n_ref <= pass%n_it if (ok) ok = all (pass%calls(:n) == ref%calls(:n)) if (ok) ok = all (pass%calls_valid(:n) == ref%calls_valid(:n)) if (ok) ok = all (pass%integral(:n) .matches. ref%integral(:n)) if (ok) ok = all (pass%error(:n) .matches. ref%error(:n)) if (ok) ok = all (pass%efficiency(:n) .matches. ref%efficiency(:n)) if (ok) then pass%calls(n+1:n_ref) = ref%calls(n+1:n_ref) pass%calls_valid(n+1:n_ref) = ref%calls_valid(n+1:n_ref) pass%integral(n+1:n_ref) = ref%integral(n+1:n_ref) pass%error(n+1:n_ref) = ref%error(n+1:n_ref) pass%efficiency(n+1:n_ref) = ref%efficiency(n+1:n_ref) pass%integral_defined = any (pass%calls /= 0) end if end if end if end subroutine pass_update @ %def pass_update @ Match two real numbers: they are equal up to a tolerance, which is $10^{-8}$, matching the number of digits that are output by [[pass_write]]. In particular, if one number is exactly zero, the other one must also be zero. <>= interface operator (.matches.) module procedure real_matches end interface operator (.matches.) <>= elemental function real_matches (x, y) result (ok) real(default), intent(in) :: x, y logical :: ok real(default), parameter :: tolerance = 1.e-8_default ok = abs (x - y) <= tolerance * max (abs (x), abs (y)) end function real_matches @ %def real_matches @ Return the index of the most recent complete integration. If there is none, return zero. <>= procedure :: get_integration_index => pass_get_integration_index <>= function pass_get_integration_index (pass) result (n) class (pass_t), intent(in) :: pass integer :: n integer :: i n = 0 if (allocated (pass%calls)) then do i = 1, pass%n_it if (pass%calls(i) == 0) exit n = i end do end if end function pass_get_integration_index @ %def pass_get_integration_index @ Return the most recent integral and error, if available. <>= procedure :: get_calls => pass_get_calls procedure :: get_calls_valid => pass_get_calls_valid procedure :: get_integral => pass_get_integral procedure :: get_error => pass_get_error procedure :: get_efficiency => pass_get_efficiency <>= function pass_get_calls (pass) result (calls) class(pass_t), intent(in) :: pass integer :: calls integer :: n n = pass%get_integration_index () calls = 0 if (n /= 0) then calls = pass%calls(n) end if end function pass_get_calls function pass_get_calls_valid (pass) result (valid) class(pass_t), intent(in) :: pass integer :: valid integer :: n n = pass%get_integration_index () valid = 0 if (n /= 0) then valid = pass%calls_valid(n) end if end function pass_get_calls_valid function pass_get_integral (pass) result (integral) class(pass_t), intent(in) :: pass real(default) :: integral integer :: n n = pass%get_integration_index () integral = 0 if (n /= 0) then integral = pass%integral(n) end if end function pass_get_integral function pass_get_error (pass) result (error) class(pass_t), intent(in) :: pass real(default) :: error integer :: n n = pass%get_integration_index () error = 0 if (n /= 0) then error = pass%error(n) end if end function pass_get_error function pass_get_efficiency (pass) result (efficiency) class(pass_t), intent(in) :: pass real(default) :: efficiency integer :: n n = pass%get_integration_index () efficiency = 0 if (n /= 0) then efficiency = pass%efficiency(n) end if end function pass_get_efficiency @ %def pass_get_calls @ %def pass_get_calls_valid @ %def pass_get_integral @ %def pass_get_error @ %def pass_get_efficiency @ \subsection{Integrator} \label{sec:integrator} We store the different passes of integration, adaptation and actual sampling, in a linked list. We store the total number of calls [[n_calls]] and the minimal number of calls [[n_calls_min]]. The latter is calculated based on [[n_channel]] and [[min_calls_per_channel]]. If [[n_calls]] is smaller than [[n_calls_min]], then we replace [[n_calls]] with [[n_min_calls]]. <>= public :: mci_vamp2_t <>= type, extends(mci_t) :: mci_vamp2_t type(mci_vamp2_config_t) :: config type(vamp2_t) :: integrator type(vamp2_equivalences_t) :: equivalences logical :: integrator_defined = .false. logical :: integrator_from_file = .false. logical :: adapt_grids = .false. logical :: adapt_weights = .false. integer :: n_adapt_grids = 0 integer :: n_adapt_weights = 0 integer :: n_calls = 0 type(list_pass_t) :: list_pass logical :: rebuild = .true. logical :: check_grid_file = .true. logical :: integrator_filename_set = .false. logical :: negative_weights = .false. logical :: verbose = .false. logical :: pass_complete = .false. logical :: it_complete = .false. type(string_t) :: integrator_filename character(32) :: md5sum_adapted = "" contains <> end type mci_vamp2_t @ %def mci_vamp2_t @ Finalizer: call to base and list finalizer. <>= procedure, public :: final => mci_vamp2_final <>= subroutine mci_vamp2_final (object) class(mci_vamp2_t), intent(inout) :: object call object%list_pass%final () call object%base_final () end subroutine mci_vamp2_final @ %def mci_vamp2_final @ Output. Do not output the grids themselves, this may result in tons of data. <>= procedure, public :: write => mci_vamp2_write <>= subroutine mci_vamp2_write (object, unit, pacify, md5sum_version) class(mci_vamp2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify logical, intent(in), optional :: md5sum_version integer :: u, i u = given_output_unit (unit) write (u, "(1X,A)") "VAMP2 integrator:" call object%base_write (u, pacify, md5sum_version) write (u, "(1X,A)") "Grid config:" call object%config%write (u) write (u, "(3X,A,L1)") "Integrator defined = ", object%integrator_defined write (u, "(3X,A,L1)") "Integrator from file = ", object%integrator_from_file write (u, "(3X,A,L1)") "Adapt grids = ", object%adapt_grids write (u, "(3X,A,L1)") "Adapt weights = ", object%adapt_weights write (u, "(3X,A,I0)") "No. of adapt grids = ", object%n_adapt_grids write (u, "(3X,A,I0)") "No. of adapt weights = ", object%n_adapt_weights write (u, "(3X,A,L1)") "Verbose = ", object%verbose if (object%config%equivalences) then call object%equivalences%write (u) end if call object%list_pass%write (u, pacify) if (object%md5sum_adapted /= "") then write (u, "(1X,A,A,A)") "MD5 sum (including results) = '", & & object%md5sum_adapted, "'" end if end subroutine mci_vamp2_write @ %def mci_vamp2_write @ Compute the (adapted) MD5 sum, including the configuration MD5 sum and the printout, which incorporates the current results. <>= procedure, public :: compute_md5sum => mci_vamp2_compute_md5sum <>= subroutine mci_vamp2_compute_md5sum (mci, pacify) class(mci_vamp2_t), intent(inout) :: mci logical, intent(in), optional :: pacify integer :: u mci%md5sum_adapted = "" u = free_unit () open (u, status = "scratch", action = "readwrite") write (u, "(A)") mci%md5sum call mci%write (u, pacify, md5sum_version = .true.) rewind (u) mci%md5sum_adapted = md5sum (u) close (u) end subroutine mci_vamp2_compute_md5sum @ %def mci_vamp2_compute_md5sum @ Return the MD5 sum: If available, return the adapted one. <>= procedure, public :: get_md5sum => mci_vamp2_get_md5sum <>= pure function mci_vamp2_get_md5sum (mci) result (md5sum) class(mci_vamp2_t), intent(in) :: mci character(32) :: md5sum if (mci%md5sum_adapted /= "") then md5sum = mci%md5sum_adapted else md5sum = mci%md5sum end if end function mci_vamp2_get_md5sum @ %def mci_vamp_get_md5sum @ Startup message: short version. Make a call to the base function and print additional information about the multi-channel parameters. <>= procedure, public :: startup_message => mci_vamp2_startup_message <>= subroutine mci_vamp2_startup_message (mci, unit, n_calls) class(mci_vamp2_t), intent(in) :: mci integer, intent(in), optional :: unit, n_calls integer :: num_calls, n_bins num_calls = 0; if (present (n_calls)) num_calls = n_calls n_bins = mci%config%n_bins_max call mci%base_startup_message (unit = unit, n_calls = n_calls) if (mci%config%equivalences) then write (msg_buffer, "(A)") & "Integrator: Using VAMP2 channel equivalences" call msg_message (unit = unit) end if write (msg_buffer, "(A,2(1x,I0,1x,A),L1)") & "Integrator:", num_calls, & "initial calls,", n_bins, & "max. bins, stratified = ", & mci%config%stratified call msg_message (unit = unit) write (msg_buffer, "(A,2(1x,I0,1x,A))") & "Integrator: VAMP2" call msg_message (unit = unit) end subroutine mci_vamp2_startup_message @ %def mci_vamp2_startup_message @ Log entry: just headline. <>= procedure, public :: write_log_entry => mci_vamp2_write_log_entry <>= subroutine mci_vamp2_write_log_entry (mci, u) class(mci_vamp2_t), intent(in) :: mci integer, intent(in) :: u write (u, "(1x,A)") "MC Integrator is VAMP2" call write_separator (u) if (mci%config%equivalences) then call mci%equivalences%write (u) else write (u, "(3x,A)") "No channel equivalences have been used." end if call write_separator (u) call mci%write_chain_weights (u) end subroutine mci_vamp2_write_log_entry @ %def mci_vamp2_write_log_entry @ Set the MCI index (necessary for processes with multiple components). We append the index to the grid filename, just before the final dotted suffix. <>= procedure, public :: record_index => mci_vamp2_record_index <>= subroutine mci_vamp2_record_index (mci, i_mci) class(mci_vamp2_t), intent(inout) :: mci integer, intent(in) :: i_mci type(string_t) :: basename, suffix character(32) :: buffer if (mci%integrator_filename_set) then basename = mci%integrator_filename call split (basename, suffix, ".", back=.true.) write (buffer, "(I0)") i_mci if (basename /= "") then mci%integrator_filename = basename // ".m" // trim (buffer) // "." // suffix else mci%integrator_filename = suffix // ".m" // trim (buffer) // ".vg2" end if end if end subroutine mci_vamp2_record_index @ %def mci_vamp2_record_index @ Set the configuration object. We adjust the maximum number of bins [[n_bins_max]] according to [[n_calls]] <>= procedure, public :: set_config => mci_vamp2_set_config <>= subroutine mci_vamp2_set_config (mci, config) class(mci_vamp2_t), intent(inout) :: mci type(mci_vamp2_config_t), intent(in) :: config mci%config = config end subroutine mci_vamp2_set_config @ %def mci_vamp2_set_config @ Set the the rebuild flag, also the for checking the grid. <>= procedure, public :: set_rebuild_flag => mci_vamp2_set_rebuild_flag <>= subroutine mci_vamp2_set_rebuild_flag (mci, rebuild, check_grid_file) class(mci_vamp2_t), intent(inout) :: mci logical, intent(in) :: rebuild logical, intent(in) :: check_grid_file mci%rebuild = rebuild mci%check_grid_file = check_grid_file end subroutine mci_vamp2_set_rebuild_flag @ %def mci_vegaa_set_rebuild_flag @ Set the filename. <>= procedure, public :: set_integrator_filename => mci_vamp2_set_integrator_filename <>= subroutine mci_vamp2_set_integrator_filename (mci, name, run_id) class(mci_vamp2_t), intent(inout) :: mci type(string_t), intent(in) :: name type(string_t), intent(in), optional :: run_id mci%integrator_filename = name // ".vg2" if (present (run_id)) then mci%integrator_filename = name // "." // run_id // ".vg2" end if mci%integrator_filename_set = .true. end subroutine mci_vamp2_set_integrator_filename @ %def mci_vamp2_set_integrator_filename @ To simplify the interface, we prepend a grid path in a separate subroutine. <>= procedure :: prepend_integrator_path => mci_vamp2_prepend_integrator_path <>= subroutine mci_vamp2_prepend_integrator_path (mci, prefix) class(mci_vamp2_t), intent(inout) :: mci type(string_t), intent(in) :: prefix if (.not. mci%integrator_filename_set) then call msg_warning ("Cannot add prefix to invalid integrator filename!") end if mci%integrator_filename = prefix // "/" // mci%integrator_filename end subroutine mci_vamp2_prepend_integrator_path @ %def mci_vamp2_prepend_integrator_path -@ TODO: Not implemented. +@ Not implemented. <>= procedure, public :: declare_flat_dimensions => mci_vamp2_declare_flat_dimensions <>= subroutine mci_vamp2_declare_flat_dimensions (mci, dim_flat) class(mci_vamp2_t), intent(inout) :: mci integer, dimension(:), intent(in) :: dim_flat end subroutine mci_vamp2_declare_flat_dimensions @ %def mci_vamp2_declare_flat_dimensions -@ TODO: Not implemented. +@ <>= procedure, public :: declare_equivalences => mci_vamp2_declare_equivalences <>= subroutine mci_vamp2_declare_equivalences (mci, channel, dim_offset) class(mci_vamp2_t), intent(inout) :: mci type(phs_channel_t), dimension(:), intent(in) :: channel integer, intent(in) :: dim_offset integer, dimension(:), allocatable :: perm, mode integer :: n_channels, n_dim, n_equivalences integer :: c, i, j, dest, src n_channels = mci%n_channel n_dim = mci%n_dim n_equivalences = 0 do c = 1, n_channels n_equivalences = n_equivalences + size (channel(c)%eq) end do mci%equivalences = vamp2_equivalences_t (& n_eqv = n_equivalences, n_channel = n_channels, n_dim = n_dim) allocate (perm (n_dim)) allocate (mode (n_dim)) perm(1:dim_offset) = [(i, i = 1, dim_offset)] mode(1:dim_offset) = 0 c = 1 j = 0 do i = 1, n_equivalences if (j < size (channel(c)%eq)) then j = j + 1 else c = c + 1 j = 1 end if associate (eq => channel(c)%eq(j)) dest = c src = eq%c perm(dim_offset+1:) = eq%perm + dim_offset mode(dim_offset+1:) = eq%mode call mci%equivalences%set_equivalence & (i, dest, src, perm, mode) end associate end do call mci%equivalences%freeze () end subroutine mci_vamp2_declare_equivalences @ %def mci_vamp2_declare_quivalences @ Allocate instance with matching type. <>= procedure, public :: allocate_instance => mci_vamp2_allocate_instance <>= subroutine mci_vamp2_allocate_instance (mci, mci_instance) class(mci_vamp2_t), intent(in) :: mci class(mci_instance_t), intent(out), pointer :: mci_instance allocate (mci_vamp2_instance_t :: mci_instance) end subroutine mci_vamp2_allocate_instance @ %def mci_vamp2_allocate_instance @ Allocate a new integration pass. We can preset everything that does not depend on the number of iterations and calls. This is postponed to the integrate method. In the final pass, we do not check accuracy goal etc., since we can assume that the user wants to perform and average all iterations in this pass. <>= procedure, public :: add_pass => mci_vamp2_add_pass <>= subroutine mci_vamp2_add_pass (mci, adapt_grids, adapt_weights, final_pass) class(mci_vamp2_t), intent(inout) :: mci logical, intent(in), optional :: adapt_grids, adapt_weights, final_pass call mci%list_pass%add (adapt_grids, adapt_weights, final_pass) end subroutine mci_vamp2_add_pass @ %def mci_vamp2_add_pass @ Update the list of integration passes. <>= procedure, public :: update_from_ref => mci_vamp2_update_from_ref <>= subroutine mci_vamp2_update_from_ref (mci, mci_ref, success) class(mci_vamp2_t), intent(inout) :: mci class(mci_t), intent(in) :: mci_ref logical, intent(out) :: success select type (mci_ref) type is (mci_vamp2_t) call mci%list_pass%update_from_ref (mci_ref%list_pass, success) if (mci%list_pass%current%integral_defined) then mci%integral = mci%list_pass%current%get_integral () mci%error = mci%list_pass%current%get_error () mci%efficiency = mci%list_pass%current%get_efficiency () mci%integral_known = .true. mci%error_known = .true. mci%efficiency_known = .true. end if end select end subroutine mci_vamp2_update_from_ref @ %def mci_vamp2_update_from_ref @ Update the MCI record (i.e., the integration passes) by reading from input stream. The stream should contain a write output from a previous run. We first check the MD5 sum of the configuration parameters. If that matches, we proceed directly to the stored integration passes. If successful, we may continue to read the file; the position will be after a blank line that must follow the MCI record. <>= procedure, public :: update => mci_vamp2_update <>= subroutine mci_vamp2_update (mci, u, success) class(mci_vamp2_t), intent(inout) :: mci integer, intent(in) :: u logical, intent(out) :: success character(80) :: buffer character(32) :: md5sum_file type(mci_vamp2_t) :: mci_file integer :: n_pass, n_it call read_sval (u, md5sum_file) success = .true.; if (mci%check_grid_file) & & success = (md5sum_file == mci%md5sum) if (success) then read (u, *) read (u, "(A)") buffer if (trim (adjustl (buffer)) /= "VAMP2 integrator:") then call msg_fatal ("VAMP2: reading grid file: corrupted data") end if n_pass = 0 n_it = 0 do read (u, "(A)") buffer select case (trim (adjustl (buffer))) case ("") exit case ("Integration pass:") call mci_file%list_pass%add () call mci_file%list_pass%current%read (u, n_pass, n_it) n_pass = n_pass + 1 n_it = n_it + mci_file%list_pass%current%n_it end select end do call mci%update_from_ref (mci_file, success) call mci_file%final () end if end subroutine mci_vamp2_update @ %def mci_vamp2_update @ Read / write grids from / to file. We split the reading process in two parts. First, we check on the header where we check (and update) all relevant pass data using [[mci_vamp2_update]]. In the second part we only read the integrator data. We implement [[mci_vamp2_read]] for completeness. <>= procedure :: write_grids => mci_vamp2_write_grids procedure :: read_header => mci_vamp2_read_header procedure :: read_data => mci_vamp2_read_data procedure :: read_grids => mci_vamp2_read_grids <>= subroutine mci_vamp2_write_grids (mci) class(mci_vamp2_t), intent(in) :: mci integer :: u if (.not. mci%integrator_filename_set) then call msg_bug ("VAMP2: write grids: filename undefined") end if if (.not. mci%integrator_defined) then call msg_bug ("VAMP2: write grids: grids undefined") end if u = free_unit () open (u, file = char (mci%integrator_filename), & action = "write", status = "replace") write (u, "(1X,A,A,A)") "MD5sum = '", mci%md5sum, "'" write (u, *) call mci%write (u) write (u, *) write (u, "(1X,A)") "VAMP2 grids:" call mci%integrator%write_grids (u) close (u) end subroutine mci_vamp2_write_grids subroutine mci_vamp2_read_header (mci, success) class(mci_vamp2_t), intent(inout) :: mci logical, intent(out) :: success logical :: exist integer :: u success = .false. if (.not. mci%integrator_filename_set) then call msg_bug ("VAMP2: read grids: filename undefined") end if inquire (file = char (mci%integrator_filename), exist = exist) if (exist) then u = free_unit () open (u, file = char (mci%integrator_filename), & action = "read", status = "old") call mci%update (u, success) close (u) if (.not. success) then write (msg_buffer, "(A,A,A)") & "VAMP2: header: parameter mismatch, discarding grid file '", & char (mci%integrator_filename), "'" call msg_message () end if end if end subroutine mci_vamp2_read_header subroutine mci_vamp2_read_data (mci) class(mci_vamp2_t), intent(inout) :: mci integer :: u character(80) :: buffer if (mci%integrator_defined) then call msg_bug ("VAMP2: read grids: grids already defined") end if u = free_unit () open (u, file = char (mci%integrator_filename), & action = "read", status = "old") do read (u, "(A)") buffer if (trim (adjustl (buffer)) == "VAMP2 grids:") exit end do call mci%integrator%read_grids (u) close (u) mci%integrator_defined = .true. end subroutine mci_vamp2_read_data subroutine mci_vamp2_read_grids (mci, success) class(mci_vamp2_t), intent(inout) :: mci logical, intent(out) :: success logical :: exist integer :: u character(80) :: buffer success = .false. if (.not. mci%integrator_filename_set) then call msg_bug ("VAMP2: read grids: filename undefined") end if if (mci%integrator_defined) then call msg_bug ("VAMP2: read grids: grids already defined") end if inquire (file = char (mci%integrator_filename), exist = exist) if (exist) then u = free_unit () open (u, file = char (mci%integrator_filename), & action = "read", status = "old") call mci%update (u, success) if (success) then read (u, "(A)") buffer if (trim (adjustl (buffer)) /= "VAMP2 grids:") then call msg_fatal ("VAMP2: reading grid file: & &corrupted grid data") end if call mci%integrator%read_grids (u) else write (msg_buffer, "(A,A,A)") & "VAMP2: read grids: parameter mismatch, discarding grid file '", & char (mci%integrator_filename), "'" call msg_message () end if close (u) mci%integrator_defined = success end if end subroutine mci_vamp2_read_grids @ %def mci_vamp2_write_grids @ %def mci_vamp2_read_header @ %def mci_vamp2_read_data @ %def mci_vamp2_read_grids @ \subsubsection{Interface: VAMP2} \label{sec:interface-vamp2} We define the interfacing procedures, as such, initialising the VAMP2 integrator or resetting the results. Initialise the VAMP2 integrator which is stored within the [[mci]] object, using the data of the current integration pass. Furthermore, reset the counters that track this set of integrator. <>= procedure, public :: init_integrator => mci_vamp2_init_integrator <>= subroutine mci_vamp2_init_integrator (mci) class(mci_vamp2_t), intent(inout) :: mci type (pass_t), pointer :: current integer :: ch, vegas_mode current => mci%list_pass%current vegas_mode = merge (VEGAS_MODE_IMPORTANCE, VEGAS_MODE_IMPORTANCE_ONLY,& & mci%config%stratified) mci%n_adapt_grids = 0 mci%n_adapt_weights = 0 if (mci%integrator_defined) then call msg_bug ("[MCI VAMP2]: init integrator: & & integrator is already initialised.") end if mci%integrator = vamp2_t (mci%n_channel, mci%n_dim, & & n_bins_max = mci%config%n_bins_max, & & iterations = 1, & & mode = vegas_mode) if (mci%has_chains ()) call mci%integrator%set_chain (mci%n_chain, mci%chain) call mci%integrator%set_config (mci%config) mci%integrator_defined = .true. end subroutine mci_vamp2_init_integrator @ %def mci_vamp2_init_integrator @ Reset a grid set. Purge the accumulated results. <>= procedure, public :: reset_result => mci_vamp2_reset_result <>= subroutine mci_vamp2_reset_result (mci) class(mci_vamp2_t), intent(inout) :: mci if (.not. mci%integrator_defined) then call msg_bug ("[MCI VAMP2] reset results: integrator undefined") end if call mci%integrator%reset_result () end subroutine mci_vamp2_reset_result @ %def mci_vamp2_reset_result @ Set calls per channel. The number of calls to each channel is defined by the channel weight \begin{equation} \alpha_i = \frac{N_i}{\sum N_i}. \end{equation} <>= procedure, public :: set_calls => mci_vamp2_set_calls <>= subroutine mci_vamp2_set_calls (mci, n_calls) class(mci_vamp2_t), intent(inout) :: mci integer :: n_calls if (.not. mci%integrator_defined) then call msg_bug ("[MCI VAMP2] set calls: grids undefined") end if call mci%integrator%set_calls (n_calls) end subroutine mci_vamp2_set_calls @ %def mci_vamp2_set_calls \subsubsection{Integration} Initialize. We prepare the integrator from a previous pass, or from file, or with new objects. At the emd, set the number of calls for the current, if the integrator is not read from file. <>= procedure, private :: init_integration => mci_vamp2_init_integration <>= subroutine mci_vamp2_init_integration (mci, n_it, n_calls, instance) class(mci_vamp2_t), intent(inout) :: mci integer, intent(in) :: n_it integer, intent(in) :: n_calls class(mci_instance_t), intent(inout) :: instance logical :: from_file, success if (.not. associated (mci%list_pass%current)) then call msg_bug ("MCI integrate: current_pass object not allocated") end if associate (current_pass => mci%list_pass%current) current_pass%integral_defined = .false. mci%config%n_calls_min = mci%config%n_calls_min_per_channel * mci%config%n_channel call current_pass%configure (n_it, n_calls, mci%config%n_calls_min) mci%adapt_grids = current_pass%adapt_grids mci%adapt_weights = current_pass%adapt_weights mci%pass_complete = .false. mci%it_complete = .false. from_file = .false. if (.not. mci%integrator_defined .or. mci%integrator_from_file) then if (mci%integrator_filename_set .and. .not. mci%rebuild) then call mci%read_header (success) from_file = success if (.not. mci%integrator_defined .and. success) & & call mci%read_data () end if end if if (from_file) then if (.not. mci%check_grid_file) & & call msg_warning ("Reading grid file: MD5 sum check disabled") call msg_message ("VAMP2: " & // "using grids and results from file ’" & // char (mci%integrator_filename) // "’") else if (.not. mci%integrator_defined) then call mci%init_integrator () end if mci%integrator_from_file = from_file if (.not. mci%integrator_from_file) then call mci%integrator%set_calls (current_pass%n_calls) end if call mci%integrator%set_equivalences (mci%equivalences) end associate end subroutine mci_vamp2_init_integration @ %def mci_vamp2_init @ Integrate. Perform a new integration pass (possibly reusing previous results), which may consist of several iterations. We reinitialise the sampling new each time and set the workspace again. Note: we record the integral once per iteration. The integral stored in the mci record itself is the last integral of the current iteration, no averaging done. The results record may average results. Note: recording the efficiency is not supported yet. <>= procedure, public :: integrate => mci_vamp2_integrate <>= subroutine mci_vamp2_integrate (mci, instance, sampler, & n_it, n_calls, results, pacify) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler integer, intent(in) :: n_it integer, intent(in) :: n_calls class(mci_results_t), intent(inout), optional :: results logical, intent(in), optional :: pacify integer :: it logical :: from_file, success <> <> call mci%init_integration (n_it, n_calls, instance) from_file = mci%integrator_from_file select type (instance) type is (mci_vamp2_instance_t) call instance%set_workspace (sampler) end select associate (current_pass => mci%list_pass%current) do it = 1, current_pass%n_it if (signal_is_pending ()) return mci%integrator_from_file = from_file .and. & it <= current_pass%get_integration_index () if (.not. mci%integrator_from_file) then mci%it_complete = .false. select type (instance) type is (mci_vamp2_instance_t) call mci%integrator%integrate (instance%func, mci%rng, & & iterations = 1, & & opt_reset_result = .true., & & opt_refine_grid = mci%adapt_grids, & & opt_adapt_weight = mci%adapt_weights, & & opt_verbose = mci%verbose) end select if (signal_is_pending ()) return mci%it_complete = .true. integral = mci%integrator%get_integral () calls = mci%integrator%get_n_calls () select type (instance) type is (mci_vamp2_instance_t) calls_valid = instance%func%get_n_calls () call instance%func%reset_n_calls () end select error = sqrt (mci%integrator%get_variance ()) efficiency = mci%integrator%get_efficiency () <> if (integral /= 0) then current_pass%integral(it) = integral current_pass%calls(it) = calls current_pass%calls_valid(it) = calls_valid current_pass%error(it) = error current_pass%efficiency(it) = efficiency end if current_pass%integral_defined = .true. end if if (present (results)) then if (mci%has_chains ()) then call mci%collect_chain_weights (instance%w) call results%record (1, & n_calls = current_pass%calls(it), & n_calls_valid = current_pass%calls_valid(it), & integral = current_pass%integral(it), & error = current_pass%error(it), & efficiency = current_pass%efficiency(it), & efficiency_pos = current_pass%efficiency(it), & efficiency_neg = 0._default, & chain_weights = mci%chain_weights, & suppress = pacify) else call results%record (1, & n_calls = current_pass%calls(it), & n_calls_valid = current_pass%calls_valid(it), & integral = current_pass%integral(it), & error = current_pass%error(it), & efficiency = current_pass%efficiency(it), & efficiency_pos = current_pass%efficiency(it), & efficiency_neg = 0._default, & suppress = pacify) end if end if if (.not. mci%integrator_from_file & .and. mci%integrator_filename_set) then <> call mci%write_grids () end if if (.not. current_pass%is_final_pass) then call check_goals (it, success) if (success) exit end if end do if (signal_is_pending ()) return mci%pass_complete = .true. mci%integral = current_pass%get_integral() mci%error = current_pass%get_error() mci%efficiency = current_pass%get_efficiency() mci%integral_known = .true. mci%error_known = .true. mci%efficiency_known = .true. call mci%compute_md5sum (pacify) end associate contains <> end subroutine mci_vamp2_integrate @ %def mci_vamp2_integrate <>= real(default) :: integral, error, efficiency integer :: calls, calls_valid @ <>= @ <>= @ <>= @ <>= integer :: rank, n_size type(MPI_Request), dimension(6) :: request @ MPI procedure-specific initialization. <>= call MPI_Comm_size (MPI_COMM_WORLD, n_size) call MPI_Comm_rank (MPI_COMM_WORLD, rank) @ We broadcast the current results to all worker, such that they can store them in to the pass list. <>= call MPI_Ibcast (integral, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, request(1)) call MPI_Ibcast (calls, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, request(2)) call MPI_Ibcast (calls_valid, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, request(3)) call MPI_Ibcast (error, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, request(4)) call MPI_Ibcast (efficiency, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, request(5)) call MPI_Waitall (5, request, MPI_STATUSES_IGNORE) @ We only allow the master to write the grids to file. <>= if (rank == 0) @ Check whether we are already finished with this pass. <>= subroutine check_goals (it, success) integer, intent(in) :: it logical, intent(out) :: success success = .false. associate (current_pass => mci%list_pass%current) if (error_reached (it)) then current_pass%n_it = it call msg_message ("[MCI VAMP2] error goal reached; & &skipping iterations") success = .true. return end if if (rel_error_reached (it)) then current_pass%n_it = it call msg_message ("[MCI VAMP2] relative error goal reached; & &skipping iterations") success = .true. return end if if (accuracy_reached (it)) then current_pass%n_it = it call msg_message ("[MCI VAMP2] accuracy goal reached; & &skipping iterations") success = .true. return end if end associate end subroutine check_goals @ %def mci_vamp2_check_goals @ Return true if the error, relative error or accurary goals hase been reached, if any. <>= function error_reached (it) result (flag) integer, intent(in) :: it logical :: flag real(default) :: error_goal, error error_goal = mci%config%error_goal flag = .false. associate (current_pass => mci%list_pass%current) if (error_goal > 0 .and. current_pass%integral_defined) then error = abs (current_pass%error(it)) flag = error < error_goal end if end associate end function error_reached function rel_error_reached (it) result (flag) integer, intent(in) :: it logical :: flag real(default) :: rel_error_goal, rel_error rel_error_goal = mci%config%rel_error_goal flag = .false. associate (current_pass => mci%list_pass%current) if (rel_error_goal > 0 .and. current_pass%integral_defined) then rel_error = abs (current_pass%error(it) / current_pass%integral(it)) flag = rel_error < rel_error_goal end if end associate end function rel_error_reached function accuracy_reached (it) result (flag) integer, intent(in) :: it logical :: flag real(default) :: accuracy_goal, accuracy accuracy_goal = mci%config%accuracy_goal flag = .false. associate (current_pass => mci%list_pass%current) if (accuracy_goal > 0 .and. current_pass%integral_defined) then if (current_pass%integral(it) /= 0) then accuracy = abs (current_pass%error(it) / current_pass%integral(it)) & * sqrt (real (current_pass%calls(it), default)) flag = accuracy < accuracy_goal else flag = .true. end if end if end associate end function accuracy_reached @ %def error_reached, rel_error_reached, accuracy_reached @ \subsection{Event generation} Prepare simulation. We check the grids and reread them from file, if necessary. <>= procedure, public :: prepare_simulation => mci_vamp2_prepare_simulation <>= subroutine mci_vamp2_prepare_simulation (mci) class(mci_vamp2_t), intent(inout) :: mci logical :: success if (.not. mci%integrator_filename_set) then call msg_bug ("VAMP2: preapre simulation: integrator filename not set.") end if call mci%read_header (success) call mci%compute_md5sum () if (.not. success) then call msg_fatal ("Simulate: " & // "reading integration grids from file ’" & // char (mci%integrator_filename) // "’ failed") end if if (.not. mci%integrator_defined) then call mci%read_data () end if end subroutine mci_vamp2_prepare_simulation @ %def mci_vamp2_prepare_simulation @ Generate an unweighted event. We only set the workspace again before generating an event. <>= procedure, public :: generate_weighted_event => mci_vamp2_generate_weighted_event <>= subroutine mci_vamp2_generate_weighted_event (mci, instance, sampler) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler if (.not. mci%integrator_defined) then call msg_bug ("VAMP2: generate weighted event: undefined integrator") end if select type (instance) type is (mci_vamp2_instance_t) instance%event_generated = .false. call instance%set_workspace (sampler) call mci%integrator%generate_weighted (& & instance%func, mci%rng, instance%event_x) instance%event_weight = mci%integrator%get_evt_weight () instance%event_excess = 0 instance%n_events = instance%n_events + 1 instance%event_generated = .true. end select end subroutine mci_vamp2_generate_weighted_event @ %def mci_vamp2_generate_weighted_event @ We apply an additional rescaling factor for [[f_max]] (either for the positive or negative distribution). <>= procedure, public :: generate_unweighted_event => mci_vamp2_generate_unweighted_event <>= subroutine mci_vamp2_generate_unweighted_event (mci, instance, sampler) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler if (.not. mci%integrator_defined) then call msg_bug ("VAMP2: generate unweighted event: undefined integrator") end if select type (instance) type is (mci_vamp2_instance_t) instance%event_generated = .false. call instance%set_workspace (sampler) generate: do call mci%integrator%generate_unweighted (& & instance%func, mci%rng, instance%event_x, & & opt_event_rescale = instance%event_rescale_f_max) instance%event_excess = mci%integrator%get_evt_weight_excess () if (signal_is_pending ()) return if (sampler%is_valid ()) exit generate end do generate if (mci%integrator%get_evt_weight () < 0.) then if (.not. mci%negative_weights) then call msg_fatal ("MCI VAMP2 cannot sample negative weights!") end if instance%event_weight = -1._default else instance%event_weight = 1._default end if instance%n_events = instance%n_events + 1 instance%event_generated = .true. end select end subroutine mci_vamp2_generate_unweighted_event @ %def mci_vamp2_generate_unweighted_event @ <>= procedure, public :: rebuild_event => mci_vamp2_rebuild_event <>= subroutine mci_vamp2_rebuild_event (mci, instance, sampler, state) class(mci_vamp2_t), intent(inout) :: mci class(mci_instance_t), intent(inout) :: instance class(mci_sampler_t), intent(inout) :: sampler class(mci_state_t), intent(in) :: state call msg_bug ("MCI VAMP2 rebuild event not implemented yet.") end subroutine mci_vamp2_rebuild_event @ %def mci_vamp2_rebuild_event @ \subsection{Integrator instance} \label{sec:nistance} We store all information relevant for simulation. The event weight is stored, when a weighted event is generated, and the event excess, when a larger weight occurs than actual stored max. weight. We give the possibility to rescale the [[f_max]] within the integrator object with [[event_rescale_f_max]]. <>= public :: mci_vamp2_instance_t <>= type, extends (mci_instance_t) :: mci_vamp2_instance_t class(mci_vamp2_func_t), allocatable :: func real(default), dimension(:), allocatable :: gi integer :: n_events = 0 logical :: event_generated = .false. real(default) :: event_weight = 0. real(default) :: event_excess = 0. real(default) :: event_rescale_f_max = 1. real(default), dimension(:), allocatable :: event_x contains <> end type mci_vamp2_instance_t @ %def mci_vamp2_instance_t @ Output. <>= procedure, public :: write => mci_vamp2_instance_write <>= subroutine mci_vamp2_instance_write (object, unit, pacify) class(mci_vamp2_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: pacify integer :: u, ch, j character(len=7) :: fmt call pac_fmt (fmt, FMT_17, FMT_14, pacify) u = given_output_unit (unit) write (u, "(1X,A)") "MCI VAMP2 instance:" write (u, "(1X,A,I0)") & & "Selected channel = ", object%selected_channel write (u, "(1X,A25,1X," // fmt // ")") & & "Integrand = ", object%integrand write (u, "(1X,A25,1X," // fmt // ")") & & "MCI weight = ", object%mci_weight write (u, "(1X,A,L1)") & & "Valid = ", object%valid write (u, "(1X,A)") "MCI a-priori weight:" do ch = 1, size (object%w) write (u, "(3X,I25,1X," // fmt // ")") ch, object%w(ch) end do write (u, "(1X,A)") "MCI jacobian:" do ch = 1, size (object%w) write (u, "(3X,I25,1X," // fmt // ")") ch, object%f(ch) end do write (u, "(1X,A)") "MCI mapped x:" do ch = 1, size (object%w) do j = 1, size (object%x, 1) write (u, "(3X,2(1X,I8),1X," // fmt // ")") j, ch, object%x(j, ch) end do end do write (u, "(1X,A)") "MCI channel weight:" do ch = 1, size (object%w) write (u, "(3X,I25,1X," // fmt // ")") ch, object%gi(ch) end do write (u, "(1X,A,I0)") & & "Number of event = ", object%n_events write (u, "(1X,A,L1)") & & "Event generated = ", object%event_generated write (u, "(1X,A25,1X," // fmt // ")") & & "Event weight = ", object%event_weight write (u, "(1X,A25,1X," // fmt // ")") & & "Event excess = ", object%event_excess write (u, "(1X,A25,1X," // fmt // ")") & & "Event rescale f max = ", object%event_rescale_f_max write (u, "(1X,A,L1)") & & "Negative (event) weight = ", object%negative_weights write (u, "(1X,A)") "MCI event" do j = 1, size (object%event_x) write (u, "(3X,I25,1X," // fmt // ")") j, object%event_x(j) end do end subroutine mci_vamp2_instance_write @ %def mci_vamp2_instance_write @ Finalizer. We are only using allocatable, so there is nothing to do here. <>= procedure, public :: final => mci_vamp2_instance_final <>= subroutine mci_vamp2_instance_final (object) class(mci_vamp2_instance_t), intent(inout) :: object ! end subroutine mci_vamp2_instance_final @ %def mci_vamp2_instance_final @ Initializer. <>= procedure, public :: init => mci_vamp2_instance_init <>= subroutine mci_vamp2_instance_init (mci_instance, mci) class(mci_vamp2_instance_t), intent(out) :: mci_instance class(mci_t), intent(in), target :: mci call mci_instance%base_init (mci) allocate (mci_instance%gi(mci%n_channel), source=0._default) allocate (mci_instance%event_x(mci%n_dim), source=0._default) allocate (mci_vamp2_func_t :: mci_instance%func) call mci_instance%func%init (n_dim = mci%n_dim, n_channel = mci%n_channel) end subroutine mci_vamp2_instance_init @ %def mci_vamp2_instance_init @ Set workspace for [[mci_vamp2_func_t]]. <>= procedure, public :: set_workspace => mci_vamp2_instance_set_workspace <>= subroutine mci_vamp2_instance_set_workspace (instance, sampler) class(mci_vamp2_instance_t), intent(inout), target :: instance class(mci_sampler_t), intent(inout), target :: sampler call instance%func%set_workspace (instance, sampler) end subroutine mci_vamp2_instance_set_workspace @ %def mci_vmp2_instance_set_workspace @ \subsubsection{Evaluation} Compute multi-channel weight. The computation of the multi-channel weight is done by the VAMP2 function. We retrieve the information. <>= procedure, public :: compute_weight => mci_vamp2_instance_compute_weight <>= subroutine mci_vamp2_instance_compute_weight (mci, c) class(mci_vamp2_instance_t), intent(inout) :: mci integer, intent(in) :: c mci%gi = mci%func%get_probabilities () mci%mci_weight = mci%func%get_weight () end subroutine mci_vamp2_instance_compute_weight @ %def mci_vamp2_instance_compute_weight @ Record the integrand. <>= procedure, public :: record_integrand => mci_vamp2_instance_record_integrand <>= subroutine mci_vamp2_instance_record_integrand (mci, integrand) class(mci_vamp2_instance_t), intent(inout) :: mci real(default), intent(in) :: integrand mci%integrand = integrand call mci%func%set_integrand (integrand) end subroutine mci_vamp2_instance_record_integrand @ %def mci_vamp2_instance_record_integrand @ \subsubsection{Event simulation} In contrast to VAMP, we reset only counters and set the safety factor, which will then will be applied each time a event is generated. In that way we do not rescale the actual values in the integrator, but more the current value! <>= procedure, public :: init_simulation => mci_vamp2_instance_init_simulation <>= subroutine mci_vamp2_instance_init_simulation (instance, safety_factor) class(mci_vamp2_instance_t), intent(inout) :: instance real(default), intent(in), optional :: safety_factor if (present (safety_factor)) instance%event_rescale_f_max = safety_factor instance%n_events = 0 instance%event_generated = .false. if (instance%event_rescale_f_max /= 1) then write (msg_buffer, "(A,ES10.3,A)") "Simulate: & &applying safety factor ", instance%event_rescale_f_max, & & " to event rejection." call msg_message () end if end subroutine mci_vamp2_instance_init_simulation @ %def mci_vamp2_instance_init_simulation @ <>= procedure, public :: final_simulation => mci_vamp2_instance_final_simulation <>= subroutine mci_vamp2_instance_final_simulation (instance) class(mci_vamp2_instance_t), intent(inout) :: instance ! end subroutine mci_vamp2_instance_final_simulation @ %def mci_vamp2_instance_final @ <>= procedure, public :: get_event_weight => mci_vamp2_instance_get_event_weight <>= function mci_vamp2_instance_get_event_weight (mci) result (weight) class(mci_vamp2_instance_t), intent(in) :: mci real(default) :: weight if (.not. mci%event_generated) then call msg_bug ("MCI VAMP2: get event weight: no event generated") end if weight = mci%event_weight end function mci_vamp2_instance_get_event_weight @ %def mci_vamp2_instance_get_event_weight @ <>= procedure, public :: get_event_excess => mci_vamp2_instance_get_event_excess <>= function mci_vamp2_instance_get_event_excess (mci) result (excess) class(mci_vamp2_instance_t), intent(in) :: mci real(default) :: excess if (.not. mci%event_generated) then call msg_bug ("MCI VAMP2: get event excess: no event generated") end if excess = mci%event_excess end function mci_vamp2_instance_get_event_excess @ %def mci_vamp2_instance_get_event_excess @ \clearpage \subsection{Unit tests} \label{sec:mic-vamp2-ut} Test module, followed by the corresponding implementation module. <<[[mci_vamp2_ut.f90]]>>= <> module mci_vamp2_ut use unit_tests use mci_vamp2_uti <> <> contains <> end module mci_vamp2_ut @ %def mci_vamp2_ut @ <<[[mci_vamp2_uti.f90]]>>= <> module mci_vamp2_uti <> <> use io_units use constants, only: PI, TWOPI use rng_base use rng_tao use rng_stream use mci_base use mci_vamp2 <> <> <> contains <> end module mci_vamp2_uti @ %def mci_vamp2_uti @ API: driver for the unit tests below. <>= public :: mci_vamp2_test <>= subroutine mci_vamp2_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine mci_vamp2_test @ %def mci_vamp2_test @ \subsubsection{Test sampler} \label{sec:mci-vamp2-test-sampler} A test sampler object should implement a function with known integral that we can use to check the integrator. In mode [[1]], the function is $f(x) = 3 x^2$ with integral $\int_0^1 f(x)\,dx=1$ and maximum $f(1)=3$. If the integration dimension is greater than one, the function is extended as a constant in the other dimension(s). In mode [[2]], the function is $11 x^{10}$, also with integral $1$. Mode [[4]] includes ranges of zero and negative function value, the integral is negative. The results should be identical to the results of [[mci_midpoint_4]], where the same function is evaluated. The function is $f(x) = (1 - 3 x^2)\,\theta(x-1/2)$ with integral $\int_0^1 f(x)\,dx=-3/8$, minimum $f(1)=-2$ and maximum $f(1/2)=1/4$. <>= type, extends (mci_sampler_t) :: test_sampler_1_t real(default), dimension(:), allocatable :: x real(default) :: val integer :: mode = 1 contains <> end type test_sampler_1_t @ %def test_sampler_1_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure, public :: write => test_sampler_1_write <>= subroutine test_sampler_1_write (object, unit, testflag) class(test_sampler_1_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) select case (object%mode) case (1) write (u, "(1x,A)") "Test sampler: f(x) = 3 x^2" case (2) write (u, "(1x,A)") "Test sampler: f(x) = 11 x^10" case (3) write (u, "(1x,A)") "Test sampler: f(x) = 11 x^10 * 2 * cos^2 (2 pi y)" case (4) write (u, "(1x,A)") "Test sampler: f(x) = (1 - 3 x^2) theta(x - 1/2)" end select end subroutine test_sampler_1_write @ %def test_sampler_1_write @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure, public :: evaluate => test_sampler_1_evaluate <>= subroutine test_sampler_1_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in select case (sampler%mode) case (1) sampler%val = 3 * x_in(1) ** 2 case (2) sampler%val = 11 * x_in(1) ** 10 case (3) sampler%val = 11 * x_in(1) ** 10 * 2 * cos (twopi * x_in(2)) ** 2 case (4) if (x_in(1) >= .5_default) then sampler%val = 1 - 3 * x_in(1) ** 2 else sampler%val = 0 end if end select call sampler%fetch (val, x, f) end subroutine test_sampler_1_evaluate @ %def test_sampler_1_evaluate @ The point is always valid. <>= procedure, public :: is_valid => test_sampler_1_is_valid <>= function test_sampler_1_is_valid (sampler) result (valid) class(test_sampler_1_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_1_is_valid @ %def test_sampler_1_is_valid @ Rebuild: compute all but the function value. <>= procedure, public :: rebuild => test_sampler_1_rebuild <>= subroutine test_sampler_1_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_1_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f if (allocated (sampler%x)) deallocate (sampler%x) allocate (sampler%x (size (x_in))) sampler%x = x_in sampler%val = val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_rebuild @ %def test_sampler_1_rebuild @ Extract the results. <>= procedure, public :: fetch => test_sampler_1_fetch <>= subroutine test_sampler_1_fetch (sampler, val, x, f) class(test_sampler_1_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x(:,1) = sampler%x f = 1 end subroutine test_sampler_1_fetch @ %def test_sampler_1_fetch @ \subsubsection{Two-channel, two dimension test sampler} This sampler implements the function \begin{equation} f(x, y) = 4\sin^2(\pi x)\sin^2(\pi y) + 2\sin^2(\pi v) \end{equation} where \begin{align} x &= u^v &u &= xy \\ y &= u^{(1-v)} &v &= \frac12\left(1 + \frac{\log(x/y)}{\log xy}\right) \end{align} Each term contributes $1$ to the integral. The first term in the function is peaked along a cross aligned to the coordinates $x$ and $y$, while the second term is peaked along the diagonal $x=y$. The Jacobian is \begin{equation} \frac{\partial(x,y)}{\partial(u,v)} = |\log u| \end{equation} <>= type, extends (mci_sampler_t) :: test_sampler_2_t real(default), dimension(:,:), allocatable :: x real(default), dimension(:), allocatable :: f real(default) :: val contains <> end type test_sampler_2_t @ %def test_sampler_2_t @ Output: There is nothing stored inside, so just print an informative line. <>= procedure, public :: write => test_sampler_2_write <>= subroutine test_sampler_2_write (object, unit, testflag) class(test_sampler_2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Two-channel test sampler 2" end subroutine test_sampler_2_write @ %def test_sampler_2_write @ Kinematics: compute $x$ and Jacobians, given the input parameter array. <>= procedure, public :: compute => test_sampler_2_compute <>= subroutine test_sampler_2_compute (sampler, c, x_in) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default) :: xx, yy, uu, vv if (.not. allocated (sampler%x)) & allocate (sampler%x (size (x_in), 2)) if (.not. allocated (sampler%f)) & allocate (sampler%f (2)) select case (c) case (1) xx = x_in(1) yy = x_in(2) uu = xx * yy vv = (1 + log (xx/yy) / log (xx*yy)) / 2 case (2) uu = x_in(1) vv = x_in(2) xx = uu ** vv yy = uu ** (1 - vv) end select sampler%val = (2 * sin (pi * xx) * sin (pi * yy)) ** 2 & + 2 * sin (pi * vv) ** 2 sampler%f(1) = 1 sampler%f(2) = abs (log (uu)) sampler%x(:,1) = [xx, yy] sampler%x(:,2) = [uu, vv] end subroutine test_sampler_2_compute @ %def test_sampler_kinematics @ Evaluation: compute the function value. The output $x$ parameter (only one channel) is identical to the input $x$, and the Jacobian is 1. <>= procedure, public :: evaluate => test_sampler_2_evaluate <>= subroutine test_sampler_2_evaluate (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) call sampler%fetch (val, x, f) end subroutine test_sampler_2_evaluate @ %def test_sampler_2_evaluate @ The point is always valid. <>= procedure, public :: is_valid => test_sampler_2_is_valid <>= function test_sampler_2_is_valid (sampler) result (valid) class(test_sampler_2_t), intent(in) :: sampler logical :: valid valid = .true. end function test_sampler_2_is_valid @ %def test_sampler_2_is_valid @ Rebuild: compute all but the function value. <>= procedure, public :: rebuild => test_sampler_2_rebuild <>= subroutine test_sampler_2_rebuild (sampler, c, x_in, val, x, f) class(test_sampler_2_t), intent(inout) :: sampler integer, intent(in) :: c real(default), dimension(:), intent(in) :: x_in real(default), intent(in) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f call sampler%compute (c, x_in) x = sampler%x f = sampler%f end subroutine test_sampler_2_rebuild @ %def test_sampler_2_rebuild @ Extract the results. <>= procedure, public :: fetch => test_sampler_2_fetch <>= subroutine test_sampler_2_fetch (sampler, val, x, f) class(test_sampler_2_t), intent(in) :: sampler real(default), intent(out) :: val real(default), dimension(:,:), intent(out) :: x real(default), dimension(:), intent(out) :: f val = sampler%val x = sampler%x f = sampler%f end subroutine test_sampler_2_fetch @ %def test_sampler_2_fetch @ \subsubsection{One-dimensional integration} \label{sec:mci-vamp2-one-dim} Construct an integrator and use it for a one-dimensional sampler. <>= call test (mci_vamp2_1, "mci_vamp2_1", "one-dimensional integral", u, results) <>= public :: mci_vamp2_1 <>= subroutine mci_vamp2_1 (u) integer, intent(in) :: u type(mci_vamp2_config_t) :: config class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable, target :: mci_sampler class(rng_t), allocatable :: rng type(string_t) :: filename write (u, "(A)") "* Test output: mci_vamp2_1" write (u, "(A)") "* Purpose: integrate function in one dimension (single channel)" write (u, "(A)") write (u, "(A)") "* Initialise integrator" write (u, "(A)") allocate (mci_vamp2_t :: mci) call mci%set_dimensions (1, 1) filename = "mci_vamp2_1" select type (mci) type is (mci_vamp2_t) call mci%set_config (config) call mci%set_integrator_filename (filename) end select allocate (rng_stream_t :: rng) call rng%init () call mci%import_rng (rng) call mci%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Initialise instance" write (u, "(A)") call mci%allocate_instance (mci_instance) call mci_instance%init (mci) write (u, "(A)") write (u, "(A)") "* Initialise test sampler" write (u, "(A)") allocate (test_sampler_1_t :: mci_sampler) call mci_sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_calls = 1000" write (u, "(A)") " (lower precision to avoid" write (u, "(A)") " numerical noise)" write (u, "(A)") select type (mci) type is (mci_vamp2_t) call mci%add_pass () end select call mci%integrate (mci_instance, mci_sampler, 1, 1000, pacify = .true.) call mci%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Dump channel weights and grids to file" write (u, "(A)") mci%md5sum = "1234567890abcdef1234567890abcdef" select type (mci) type is (mci_vamp2_t) call mci%write_grids () end select write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp2_1" end subroutine mci_vamp2_1 @ %def mci_vamp2_test1 @ \subsubsection{Multiple iterations} Construct an integrator and use it for a one-dimensional sampler. Integrate with five iterations without grid adaptation. <>= call test (mci_vamp2_2, "mci_vamp2_2", & "multiple iterations", & u, results) <>= public :: mci_vamp2_2 <>= subroutine mci_vamp2_2 (u) type(mci_vamp2_config_t) :: config integer, intent(in) :: u class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng type(string_t) :: filename write (u, "(A)") "* Test output: mci_vamp2_2" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel), but multiple iterations." write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp2_t :: mci) call mci%set_dimensions (1, 1) filename = "mci_vamp2_2" select type (mci) type is (mci_vamp2_t) call mci%set_config (config) call mci%set_integrator_filename (filename) end select allocate (rng_stream_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 2 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 100" write (u, "(A)") select type (mci) type is (mci_vamp2_t) call mci%add_pass (adapt_grids = .false.) end select call mci%integrate (mci_instance, sampler, 3, 1000, pacify = .true.) call mci%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Dump channel weights and grids to file" write (u, "(A)") mci%md5sum = "1234567890abcdef1234567890abcdef" select type (mci) type is (mci_vamp2_t) call mci%write_grids () end select write (u, "(A)") write (u, "(A)") "* Cleanup" call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp2_2" end subroutine mci_vamp2_2 @ %def mci_vamp2_2 @ \subsubsection{Grid adaptation} Construct an integrator and use it for a one-dimensional sampler. Integrate with three iterations and in-between grid adaptations. <>= call test (mci_vamp2_3, "mci_vamp2_3", & "grid adaptation", & u, results) <>= public :: mci_vamp2_3 <>= subroutine mci_vamp2_3 (u) integer, intent(in) :: u type(mci_vamp2_config_t) :: config class(mci_t), allocatable, target :: mci class(mci_instance_t), pointer :: mci_instance => null () class(mci_sampler_t), allocatable :: sampler class(rng_t), allocatable :: rng type(string_t) :: filename write (u, "(A)") "* Test output: mci_vamp2_3" write (u, "(A)") "* Purpose: integrate function in one dimension & &(single channel)" write (u, "(A)") "* and adapt grid" write (u, "(A)") write (u, "(A)") "* Initialize integrator, sampler, instance" write (u, "(A)") allocate (mci_vamp2_t :: mci) call mci%set_dimensions (1, 1) filename = "mci_vamp2_3" select type (mci) type is (mci_vamp2_t) call mci%set_integrator_filename (filename) call mci%set_config (config) end select allocate (rng_stream_t :: rng) call rng%init () call mci%import_rng (rng) call mci%allocate_instance (mci_instance) call mci_instance%init (mci) allocate (test_sampler_1_t :: sampler) select type (sampler) type is (test_sampler_1_t) sampler%mode = 2 end select call sampler%write (u) write (u, "(A)") write (u, "(A)") "* Integrate with n_it = 3 and n_calls = 100" write (u, "(A)") select type (mci) type is (mci_vamp2_t) call mci%add_pass (adapt_grids = .true.) end select call mci%integrate (mci_instance, sampler, 3, 1000, pacify = .true.) call mci%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Contents of mci_instance:" write (u, "(A)") call mci_instance%write (u, pacify = .true.) write (u, "(A)") write (u, "(A)") "* Dump channel weights and grids to file" write (u, "(A)") mci%md5sum = "1234567890abcdef1234567890abcdef" select type (mci) type is (mci_vamp2_t) call mci%write_grids () end select write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") call mci_instance%final () call mci%final () write (u, "(A)") write (u, "(A)") "* Test output end: mci_vamp2_3" end subroutine mci_vamp2_3 @ %def mci_vamp2_3 @ \section{Dispatch} @ <<[[dispatch_mci.f90]]>>= <> module dispatch_mci <> use diagnostics use os_interface use variables use mci_base use mci_none use mci_midpoint use mci_vamp use mci_vamp2 <> <> <> contains <> end module dispatch_mci @ %def dispatch_mci @ Allocate an integrator according to the variable [[$integration_method]]. <>= public :: dispatch_mci_s <>= subroutine dispatch_mci_s (mci, var_list, process_id, is_nlo) class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo type(string_t) :: run_id type(string_t) :: integration_method type(grid_parameters_t) :: grid_par type(history_parameters_t) :: history_par type(mci_vamp2_config_t) :: mci_vamp2_config logical :: rebuild_grids, check_grid_file, negative_weights, verbose logical :: dispatch_nlo type(string_t) :: grid_path dispatch_nlo = .false.; if (present (is_nlo)) dispatch_nlo = is_nlo integration_method = & var_list%get_sval (var_str ("$integration_method")) select case (char (integration_method)) case ("none") allocate (mci_none_t :: mci) case ("midpoint") allocate (mci_midpoint_t :: mci) case ("vamp", "default") call unpack_options_vamp () allocate (mci_vamp_t :: mci) select type (mci) type is (mci_vamp_t) call mci%set_grid_parameters (grid_par) if (run_id /= "") then call mci%set_grid_filename (process_id, run_id) else call mci%set_grid_filename (process_id) end if grid_path = var_list%get_sval (var_str ("$integrate_workspace")) if (grid_path /= "") then call setup_grid_path (grid_path) call mci%prepend_grid_path (grid_path) end if call mci%set_history_parameters (history_par) call mci%set_rebuild_flag (rebuild_grids, check_grid_file) mci%negative_weights = negative_weights mci%verbose = verbose end select case ("vamp2") call unpack_options_vamp2 () allocate (mci_vamp2_t :: mci) select type (mci) type is (mci_vamp2_t) call mci%set_config (mci_vamp2_config) if (run_id /= "") then call mci%set_integrator_filename (process_id, run_id) else call mci%set_integrator_filename (process_id) end if grid_path = var_list%get_sval (var_str ("$integrate_workspace")) if (grid_path /= "") then call setup_grid_path (grid_path) call mci%prepend_integrator_path (grid_path) end if call mci%set_rebuild_flag (rebuild_grids, check_grid_file) mci%negative_weights = negative_weights mci%verbose = verbose end select case default call msg_fatal ("Integrator '" & // char (integration_method) // "' not implemented") end select contains <> end subroutine dispatch_mci_s @ %def dispatch_mci_s @ <>= subroutine unpack_options_vamp () grid_par%threshold_calls = & var_list%get_ival (var_str ("threshold_calls")) grid_par%min_calls_per_channel = & var_list%get_ival (var_str ("min_calls_per_channel")) grid_par%min_calls_per_bin = & var_list%get_ival (var_str ("min_calls_per_bin")) grid_par%min_bins = & var_list%get_ival (var_str ("min_bins")) grid_par%max_bins = & var_list%get_ival (var_str ("max_bins")) grid_par%stratified = & var_list%get_lval (var_str ("?stratified")) if (.not. dispatch_nlo) then grid_par%use_vamp_equivalences = & var_list%get_lval (var_str ("?use_vamp_equivalences")) else grid_par%use_vamp_equivalences = .false. end if grid_par%channel_weights_power = & var_list%get_rval (var_str ("channel_weights_power")) grid_par%accuracy_goal = & var_list%get_rval (var_str ("accuracy_goal")) grid_par%error_goal = & var_list%get_rval (var_str ("error_goal")) grid_par%rel_error_goal = & var_list%get_rval (var_str ("relative_error_goal")) history_par%global = & var_list%get_lval (var_str ("?vamp_history_global")) history_par%global_verbose = & var_list%get_lval (var_str ("?vamp_history_global_verbose")) history_par%channel = & var_list%get_lval (var_str ("?vamp_history_channels")) history_par%channel_verbose = & var_list%get_lval (var_str ("?vamp_history_channels_verbose")) verbose = & var_list%get_lval (var_str ("?vamp_verbose")) check_grid_file = & var_list%get_lval (var_str ("?check_grid_file")) run_id = & var_list%get_sval (var_str ("$run_id")) rebuild_grids = & var_list%get_lval (var_str ("?rebuild_grids")) negative_weights = & var_list%get_lval (var_str ("?negative_weights")) .or. dispatch_nlo end subroutine unpack_options_vamp subroutine unpack_options_vamp2 () mci_vamp2_config%n_bins_max = & var_list%get_ival (var_str ("max_bins")) mci_vamp2_config%n_calls_min_per_channel = & var_list%get_ival (var_str ("min_calls_per_channel")) mci_vamp2_config%n_calls_threshold = & var_list%get_ival (var_str ("threshold_calls")) mci_vamp2_config%beta = & var_list%get_rval (var_str ("channel_weights_power")) mci_vamp2_config%stratified = & var_list%get_lval (var_str ("?stratified")) if (.not. dispatch_nlo) then mci_vamp2_config%equivalences = & var_list%get_lval (var_str ("?use_vamp_equivalences")) else mci_vamp2_config%equivalences = .false. end if mci_vamp2_config%accuracy_goal = & var_list%get_rval (var_str ("accuracy_goal")) mci_vamp2_config%error_goal = & var_list%get_rval (var_str ("error_goal")) mci_vamp2_config%rel_error_goal = & var_list%get_rval (var_str ("relative_error_goal")) verbose = & var_list%get_lval (var_str ("?vamp_verbose")) check_grid_file = & var_list%get_lval (var_str ("?check_grid_file")) run_id = & var_list%get_sval (var_str ("$run_id")) rebuild_grids = & var_list%get_lval (var_str ("?rebuild_grids")) negative_weights = & var_list%get_lval (var_str ("?negative_weights")) .or. dispatch_nlo end subroutine unpack_options_vamp2 @ @ Make sure that the VAMP grid subdirectory, if requested, exists before it is used. Also include a sanity check on the directory name. <>= character(*), parameter :: ALLOWED_IN_DIRNAME = & "abcdefghijklmnopqrstuvwxyz& &ABCDEFGHIJKLMNOPQRSTUVWXYZ& &1234567890& &.,_-+=" @ %def ALLOWED_IN_DIRNAME <>= public :: setup_grid_path <>= subroutine setup_grid_path (grid_path) type(string_t), intent(in) :: grid_path if (verify (grid_path, ALLOWED_IN_DIRNAME) == 0) then call msg_message ("Integrator: preparing VAMP grid directory '" & // char (grid_path) // "'") call os_system_call ("mkdir -p '" // grid_path // "'") else call msg_fatal ("Integrator: VAMP grid_path '" & // char (grid_path) // "' contains illegal characters") end if end subroutine setup_grid_path @ %def setup_grid_path @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[dispatch_mci_ut.f90]]>>= <> module dispatch_mci_ut use unit_tests use dispatch_mci_uti <> <> contains <> end module dispatch_mci_ut @ %def dispatch_mci_ut @ <<[[dispatch_mci_uti.f90]]>>= <> module dispatch_mci_uti <> <> use variables use mci_base use mci_none use mci_midpoint use mci_vamp use dispatch_mci <> <> contains <> end module dispatch_mci_uti @ %def dispatch_mci_ut @ API: driver for the unit tests below. <>= public ::dispatch_mci_test <>= subroutine dispatch_mci_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine dispatch_mci_test @ %def dispatch_mci_test @ \subsubsection{Select type: integrator core} <>= call test (dispatch_mci_1, "dispatch_mci_1", & "integration method", & u, results) <>= public :: dispatch_mci_1 <>= subroutine dispatch_mci_1 (u) integer, intent(in) :: u type(var_list_t) :: var_list class(mci_t), allocatable :: mci type(string_t) :: process_id write (u, "(A)") "* Test output: dispatch_mci_1" write (u, "(A)") "* Purpose: select integration method" write (u, "(A)") call var_list%init_defaults (0) process_id = "dispatch_mci_1" write (u, "(A)") "* Allocate MCI as none_t" write (u, "(A)") call var_list%set_string (& var_str ("$integration_method"), & var_str ("none"), is_known = .true.) call dispatch_mci_s (mci, var_list, process_id) select type (mci) type is (mci_none_t) call mci%write (u) end select call mci%final () deallocate (mci) write (u, "(A)") write (u, "(A)") "* Allocate MCI as midpoint_t" write (u, "(A)") call var_list%set_string (& var_str ("$integration_method"), & var_str ("midpoint"), is_known = .true.) call dispatch_mci_s (mci, var_list, process_id) select type (mci) type is (mci_midpoint_t) call mci%write (u) end select call mci%final () deallocate (mci) write (u, "(A)") write (u, "(A)") "* Allocate MCI as vamp_t" write (u, "(A)") call var_list%set_string (& var_str ("$integration_method"), & var_str ("vamp"), is_known = .true.) call var_list%set_int (var_str ("threshold_calls"), & 1, is_known = .true.) call var_list%set_int (var_str ("min_calls_per_channel"), & 2, is_known = .true.) call var_list%set_int (var_str ("min_calls_per_bin"), & 3, is_known = .true.) call var_list%set_int (var_str ("min_bins"), & 4, is_known = .true.) call var_list%set_int (var_str ("max_bins"), & 5, is_known = .true.) call var_list%set_log (var_str ("?stratified"), & .false., is_known = .true.) call var_list%set_log (var_str ("?use_vamp_equivalences"),& .false., is_known = .true.) call var_list%set_real (var_str ("channel_weights_power"),& 4._default, is_known = .true.) call var_list%set_log (& var_str ("?vamp_history_global_verbose"), & .true., is_known = .true.) call var_list%set_log (& var_str ("?vamp_history_channels"), & .true., is_known = .true.) call var_list%set_log (& var_str ("?vamp_history_channels_verbose"), & .true., is_known = .true.) call var_list%set_log (var_str ("?stratified"), & .false., is_known = .true.) call dispatch_mci_s (mci, var_list, process_id) select type (mci) type is (mci_vamp_t) call mci%write (u) call mci%write_history_parameters (u) end select call mci%final () deallocate (mci) write (u, "(A)") write (u, "(A)") "* Allocate MCI as vamp_t, allow for negative weights" write (u, "(A)") call var_list%set_string (& var_str ("$integration_method"), & var_str ("vamp"), is_known = .true.) call var_list%set_log (var_str ("?negative_weights"), & .true., is_known = .true.) call dispatch_mci_s (mci, var_list, process_id) select type (mci) type is (mci_vamp_t) call mci%write (u) call mci%write_history_parameters (u) end select call mci%final () deallocate (mci) call var_list%final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_mci_1" end subroutine dispatch_mci_1 @ %def dispatch_mci_1 Index: trunk/circe2/TODO =================================================================== --- trunk/circe2/TODO (revision 0) +++ trunk/circe2/TODO (revision 8235) @@ -0,0 +1,8 @@ +CIRCE2 +* fix multi channel distributions with singularities at x = 0 + +* find a better way to test distributions with delta contributions + +* update the documentation + +* add sensible installcheck for the library (and sample data files)