Index: trunk/src/process_integration/process_integration.nw =================================================================== --- trunk/src/process_integration/process_integration.nw (revision 8226) +++ trunk/src/process_integration/process_integration.nw (revision 8227) @@ -1,19157 +1,19157 @@ % -*- 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 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 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 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 [[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. <>= 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 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 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 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). <>= 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 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%fac_scale) + 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). <>= 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 evalutaed 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 8226) +++ trunk/src/fks/fks.nw (revision 8227) @@ -1,9619 +1,9621 @@ % -*- 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) - + \left(\log\frac{\sqrt{s}}{2E_{em}} + \log\xi_{max}\right) + + 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(\frac{Q^2}{k_{res}^2} - 2 \log\xi_{max}\right) \gamma(\mathcal{I}_k)\right]. + + \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$. +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 - associate (xi_cut => xi_max * virt%settings%fks_template%xi_cut, delta_zero => virt%settings%fks_template%delta_zero) + ! 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 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 / z / fac_scale2) / onemz + two * log (onemz) / onemz factor_soft = log (sb * template%delta_i / 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 / 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 @