Index: trunk/src/beams/beams.nw =================================================================== --- trunk/src/beams/beams.nw (revision 8778) +++ trunk/src/beams/beams.nw (revision 8779) @@ -1,25483 +1,25481 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: beams and beam structure %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Beams} \includemodulegraph{beams} These modules implement beam configuration and beam structure, the latter in abstract terms. \begin{description} \item[beam\_structures] The [[beam_structure_t]] type is a messenger type that communicates the user settings to the \whizard\ core. \item[beams] Beam configuration. \item[sf\_aux] Tools for handling structure functions and splitting \item[sf\_mappings] Mapping functions, useful for structure function implementation \item[sf\_base] The abstract structure-function interaction and structure-function chain types. \end{description} These are the implementation modules, the concrete counterparts of [[sf_base]]: \begin{description} \item[sf\_isr] ISR structure function (photon radiation inclusive and resummed in collinear and IR regions). \item[sf\_epa] Effective Photon Approximation. \item[sf\_ewa] Effective $W$ (and $Z$) approximation. \item[sf\_escan] Energy spectrum that emulates a uniform energy scan. \item[sf\_gaussian] Gaussian beam spread \item[sf\_beam\_events] Beam-event generator that reads its input from an external file. \item[sf\_circe1] CIRCE1 beam spectra for electrons and photons. \item[sf\_circe2] CIRCE2 beam spectra for electrons and photons. \item[hoppet\_interface] Support for $b$-quark matching, addon to PDF modules. \item[sf\_pdf\_builtin] Direct support for selected hadron PDFs. \item[sf\_lhapdf] LHAPDF library support. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Beam structure} This module stores the beam structure definition as it is declared in the SINDARIN script. The structure definition is not analyzed, just recorded for later use. We do not capture any numerical parameters, just names of particles and structure functions. <<[[beam_structures.f90]]>>= <> module beam_structures <> <> use io_units use format_defs, only: FMT_19 use diagnostics use lorentz use polarizations <> <> <> <> contains <> end module beam_structures @ %def beam_structures @ \subsection{Beam structure elements} An entry in a beam-structure record consists of a string that denotes a type of structure function. <>= type :: beam_structure_entry_t logical :: is_valid = .false. type(string_t) :: name contains <> end type beam_structure_entry_t @ %def beam_structure_entry_t @ Output. <>= procedure :: to_string => beam_structure_entry_to_string <>= function beam_structure_entry_to_string (object) result (string) class(beam_structure_entry_t), intent(in) :: object type(string_t) :: string if (object%is_valid) then string = object%name else string = "none" end if end function beam_structure_entry_to_string @ %def beam_structure_entry_to_string @ A record in the beam-structure sequence denotes either a structure-function entry, a pair of such entries, or a pair spectrum. <>= type :: beam_structure_record_t type(beam_structure_entry_t), dimension(:), allocatable :: entry end type beam_structure_record_t @ %def beam_structure_record_t @ \subsection{Beam structure type} The beam-structure object contains the beam particle(s) as simple strings. The sequence of records indicates the structure functions by name. No numerical parameters are stored. <>= public :: beam_structure_t <>= type :: beam_structure_t private integer :: n_beam = 0 type(string_t), dimension(:), allocatable :: prt type(beam_structure_record_t), dimension(:), allocatable :: record type(smatrix_t), dimension(:), allocatable :: smatrix real(default), dimension(:), allocatable :: pol_f real(default), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: theta real(default), dimension(:), allocatable :: phi contains <> end type beam_structure_t @ %def beam_structure_t @ The finalizer deletes all contents explicitly, so we can continue with an empty beam record. (It is not needed for deallocation.) We have distinct finalizers for the independent parts of the beam structure. <>= procedure :: final_sf => beam_structure_final_sf <>= subroutine beam_structure_final_sf (object) class(beam_structure_t), intent(inout) :: object if (allocated (object%prt)) deallocate (object%prt) if (allocated (object%record)) deallocate (object%record) object%n_beam = 0 end subroutine beam_structure_final_sf @ %def beam_structure_final_sf @ Output. The actual information fits in a single line, therefore we can provide a [[to_string]] method. The [[show]] method also lists the current values of relevant global variables. <>= procedure :: write => beam_structure_write procedure :: to_string => beam_structure_to_string <>= subroutine beam_structure_write (object, unit) class(beam_structure_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A,A)") "Beam structure: ", char (object%to_string ()) if (allocated (object%smatrix)) then do i = 1, size (object%smatrix) write (u, "(3x,A,I0,A)") "polarization (beam ", i, "):" call object%smatrix(i)%write (u, indent=2) end do end if if (allocated (object%pol_f)) then write (u, "(3x,A,F10.7,:,',',F10.7)") "polarization degree =", & object%pol_f end if if (allocated (object%p)) then write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // & ")") "momentum =", object%p end if if (allocated (object%theta)) then write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // & ")") "angle th =", object%theta end if if (allocated (object%phi)) then write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // & ")") "angle ph =", object%phi end if end subroutine beam_structure_write function beam_structure_to_string (object, sf_only) result (string) class(beam_structure_t), intent(in) :: object logical, intent(in), optional :: sf_only type(string_t) :: string integer :: i, j logical :: with_beams with_beams = .true.; if (present (sf_only)) with_beams = .not. sf_only select case (object%n_beam) case (1) if (with_beams) then string = object%prt(1) else string = "" end if case (2) if (with_beams) then string = object%prt(1) // ", " // object%prt(2) else string = "" end if if (allocated (object%record)) then if (size (object%record) > 0) then if (with_beams) string = string // " => " do i = 1, size (object%record) if (i > 1) string = string // " => " do j = 1, size (object%record(i)%entry) if (j > 1) string = string // ", " string = string // object%record(i)%entry(j)%to_string () end do end do end if end if case default string = "[any particles]" end select end function beam_structure_to_string @ %def beam_structure_write beam_structure_to_string @ Initializer: dimension the beam structure record. Each array element denotes the number of entries for a record within the beam-structure sequence. The number of entries is either one or two, while the number of records is unlimited. <>= procedure :: init_sf => beam_structure_init_sf <>= subroutine beam_structure_init_sf (beam_structure, prt, dim_array) class(beam_structure_t), intent(inout) :: beam_structure type(string_t), dimension(:), intent(in) :: prt integer, dimension(:), intent(in), optional :: dim_array integer :: i call beam_structure%final_sf () beam_structure%n_beam = size (prt) allocate (beam_structure%prt (size (prt))) beam_structure%prt = prt if (present (dim_array)) then allocate (beam_structure%record (size (dim_array))) do i = 1, size (dim_array) allocate (beam_structure%record(i)%entry (dim_array(i))) end do else allocate (beam_structure%record (0)) end if end subroutine beam_structure_init_sf @ %def beam_structure_init_sf @ Set an entry, specified by record number and entry number. <>= procedure :: set_sf => beam_structure_set_sf <>= subroutine beam_structure_set_sf (beam_structure, i, j, name) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i, j type(string_t), intent(in) :: name associate (entry => beam_structure%record(i)%entry(j)) entry%name = name entry%is_valid = .true. end associate end subroutine beam_structure_set_sf @ %def beam_structure_set_sf @ Expand the beam-structure object. (i) For a pair spectrum, keep the entry. (ii) For a single-particle structure function written as a single entry, replace this by a record with two entries. (ii) For a record with two nontrivial entries, separate this into two records with one trivial entry each. To achieve this, we need a function that tells us whether an entry is a spectrum or a structure function. It returns 0 for a trivial entry, 1 for a single-particle structure function, and 2 for a two-particle spectrum. <>= abstract interface function strfun_mode_fun (name) result (n) import type(string_t), intent(in) :: name integer :: n end function strfun_mode_fun end interface @ %def is_spectrum_t @ Algorithm: (1) Mark entries as invalid where necessary. (2) Count the number of entries that we will need. (3) Expand and copy entries to a new record array. (4) Replace the old array by the new one. <>= procedure :: expand => beam_structure_expand <>= subroutine beam_structure_expand (beam_structure, strfun_mode) class(beam_structure_t), intent(inout) :: beam_structure procedure(strfun_mode_fun) :: strfun_mode type(beam_structure_record_t), dimension(:), allocatable :: new integer :: n_record, i, j if (.not. allocated (beam_structure%record)) return do i = 1, size (beam_structure%record) associate (entry => beam_structure%record(i)%entry) do j = 1, size (entry) select case (strfun_mode (entry(j)%name)) case (0); entry(j)%is_valid = .false. end select end do end associate end do n_record = 0 do i = 1, size (beam_structure%record) associate (entry => beam_structure%record(i)%entry) select case (size (entry)) case (1) if (entry(1)%is_valid) then select case (strfun_mode (entry(1)%name)) case (1); n_record = n_record + 2 case (2); n_record = n_record + 1 end select end if case (2) do j = 1, 2 if (entry(j)%is_valid) then select case (strfun_mode (entry(j)%name)) case (1); n_record = n_record + 1 case (2) call beam_structure%write () call msg_fatal ("Pair spectrum used as & &single-particle structure function") end select end if end do end select end associate end do allocate (new (n_record)) n_record = 0 do i = 1, size (beam_structure%record) associate (entry => beam_structure%record(i)%entry) select case (size (entry)) case (1) if (entry(1)%is_valid) then select case (strfun_mode (entry(1)%name)) case (1) n_record = n_record + 1 allocate (new(n_record)%entry (2)) new(n_record)%entry(1) = entry(1) n_record = n_record + 1 allocate (new(n_record)%entry (2)) new(n_record)%entry(2) = entry(1) case (2) n_record = n_record + 1 allocate (new(n_record)%entry (1)) new(n_record)%entry(1) = entry(1) end select end if case (2) do j = 1, 2 if (entry(j)%is_valid) then n_record = n_record + 1 allocate (new(n_record)%entry (2)) new(n_record)%entry(j) = entry(j) end if end do end select end associate end do call move_alloc (from = new, to = beam_structure%record) end subroutine beam_structure_expand @ %def beam_structure_expand @ \subsection{Polarization} To record polarization, we provide an allocatable array of [[smatrix]] objects, sparse matrices. The polarization structure is independent of the structure-function setup, they are combined only when an actual beam object is constructed. <>= procedure :: final_pol => beam_structure_final_pol procedure :: init_pol => beam_structure_init_pol <>= subroutine beam_structure_final_pol (beam_structure) class(beam_structure_t), intent(inout) :: beam_structure if (allocated (beam_structure%smatrix)) deallocate (beam_structure%smatrix) if (allocated (beam_structure%pol_f)) deallocate (beam_structure%pol_f) end subroutine beam_structure_final_pol subroutine beam_structure_init_pol (beam_structure, n) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: n if (allocated (beam_structure%smatrix)) deallocate (beam_structure%smatrix) allocate (beam_structure%smatrix (n)) if (.not. allocated (beam_structure%pol_f)) & allocate (beam_structure%pol_f (n), source = 1._default) end subroutine beam_structure_init_pol @ %def beam_structure_final_pol @ %def beam_structure_init_pol @ Check if polarized beams are used. <>= procedure :: has_polarized_beams => beam_structure_has_polarized_beams <>= elemental function beam_structure_has_polarized_beams (beam_structure) result (pol) logical :: pol class(beam_structure_t), intent(in) :: beam_structure if (allocated (beam_structure%pol_f)) then pol = any (beam_structure%pol_f /= 0) else pol = .false. end if end function beam_structure_has_polarized_beams @ %def beam_structure_has_polarized_beams @ Directly copy the spin density matrices. <>= procedure :: set_smatrix => beam_structure_set_smatrix <>= subroutine beam_structure_set_smatrix (beam_structure, i, smatrix) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i type(smatrix_t), intent(in) :: smatrix beam_structure%smatrix(i) = smatrix end subroutine beam_structure_set_smatrix @ %def beam_structure_set_smatrix @ Initialize one of the spin density matrices manually. <>= procedure :: init_smatrix => beam_structure_init_smatrix <>= subroutine beam_structure_init_smatrix (beam_structure, i, n_entry) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i integer, intent(in) :: n_entry call beam_structure%smatrix(i)%init (2, n_entry) end subroutine beam_structure_init_smatrix @ %def beam_structure_init_smatrix @ Set a polarization entry. <>= procedure :: set_sentry => beam_structure_set_sentry <>= subroutine beam_structure_set_sentry & (beam_structure, i, i_entry, index, value) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i integer, intent(in) :: i_entry integer, dimension(:), intent(in) :: index complex(default), intent(in) :: value call beam_structure%smatrix(i)%set_entry (i_entry, index, value) end subroutine beam_structure_set_sentry @ %def beam_structure_set_sentry @ Set the array of polarization fractions. <>= procedure :: set_pol_f => beam_structure_set_pol_f <>= subroutine beam_structure_set_pol_f (beam_structure, f) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: f if (allocated (beam_structure%pol_f)) deallocate (beam_structure%pol_f) allocate (beam_structure%pol_f (size (f)), source = f) end subroutine beam_structure_set_pol_f @ %def beam_structure_set_pol_f @ \subsection{Beam momenta} By default, beam momenta are deduced from the [[sqrts]] value or from the mass of the decaying particle, assuming a c.m.\ setup. Here we set them explicitly. <>= procedure :: final_mom => beam_structure_final_mom <>= subroutine beam_structure_final_mom (beam_structure) class(beam_structure_t), intent(inout) :: beam_structure if (allocated (beam_structure%p)) deallocate (beam_structure%p) if (allocated (beam_structure%theta)) deallocate (beam_structure%theta) if (allocated (beam_structure%phi)) deallocate (beam_structure%phi) end subroutine beam_structure_final_mom @ %def beam_structure_final_mom <>= procedure :: set_momentum => beam_structure_set_momentum procedure :: set_theta => beam_structure_set_theta procedure :: set_phi => beam_structure_set_phi <>= subroutine beam_structure_set_momentum (beam_structure, p) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: p if (allocated (beam_structure%p)) deallocate (beam_structure%p) allocate (beam_structure%p (size (p)), source = p) end subroutine beam_structure_set_momentum subroutine beam_structure_set_theta (beam_structure, theta) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: theta if (allocated (beam_structure%theta)) deallocate (beam_structure%theta) allocate (beam_structure%theta (size (theta)), source = theta) end subroutine beam_structure_set_theta subroutine beam_structure_set_phi (beam_structure, phi) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: phi if (allocated (beam_structure%phi)) deallocate (beam_structure%phi) allocate (beam_structure%phi (size (phi)), source = phi) end subroutine beam_structure_set_phi @ %def beam_structure_set_momentum @ %def beam_structure_set_theta @ %def beam_structure_set_phi @ \subsection{Get contents} Look at the incoming particles. We may also have the case that beam particles are not specified, but polarization. <>= procedure :: is_set => beam_structure_is_set procedure :: get_n_beam => beam_structure_get_n_beam procedure :: get_prt => beam_structure_get_prt <>= function beam_structure_is_set (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag flag = beam_structure%n_beam > 0 .or. beam_structure%asymmetric () end function beam_structure_is_set function beam_structure_get_n_beam (beam_structure) result (n) class(beam_structure_t), intent(in) :: beam_structure integer :: n n = beam_structure%n_beam end function beam_structure_get_n_beam function beam_structure_get_prt (beam_structure) result (prt) class(beam_structure_t), intent(in) :: beam_structure type(string_t), dimension(:), allocatable :: prt allocate (prt (size (beam_structure%prt))) prt = beam_structure%prt end function beam_structure_get_prt @ %def beam_structure_is_set @ %def beam_structure_get_n_beam @ %def beam_structure_get_prt @ Return the number of records. <>= procedure :: get_n_record => beam_structure_get_n_record <>= function beam_structure_get_n_record (beam_structure) result (n) class(beam_structure_t), intent(in) :: beam_structure integer :: n if (allocated (beam_structure%record)) then n = size (beam_structure%record) else n = 0 end if end function beam_structure_get_n_record @ %def beam_structure_get_n_record @ Return an array consisting of the beam indices affected by the valid entries within a record. After expansion, there should be exactly one valid entry per record. <>= procedure :: get_i_entry => beam_structure_get_i_entry <>= function beam_structure_get_i_entry (beam_structure, i) result (i_entry) class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: i integer, dimension(:), allocatable :: i_entry associate (record => beam_structure%record(i)) select case (size (record%entry)) case (1) if (record%entry(1)%is_valid) then allocate (i_entry (2), source = [1, 2]) else allocate (i_entry (0)) end if case (2) if (all (record%entry%is_valid)) then allocate (i_entry (2), source = [1, 2]) else if (record%entry(1)%is_valid) then allocate (i_entry (1), source = [1]) else if (record%entry(2)%is_valid) then allocate (i_entry (1), source = [2]) else allocate (i_entry (0)) end if end select end associate end function beam_structure_get_i_entry @ %def beam_structure_get_i_entry @ Return the name of the first valid entry within a record. After expansion, there should be exactly one valid entry per record. <>= procedure :: get_name => beam_structure_get_name <>= function beam_structure_get_name (beam_structure, i) result (name) type(string_t) :: name class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: i associate (record => beam_structure%record(i)) if (record%entry(1)%is_valid) then name = record%entry(1)%name else if (size (record%entry) == 2) then name = record%entry(2)%name end if end associate end function beam_structure_get_name @ %def beam_structure_get_name @ <>= procedure :: has_pdf => beam_structure_has_pdf <>= function beam_structure_has_pdf (beam_structure) result (has_pdf) logical :: has_pdf class(beam_structure_t), intent(in) :: beam_structure integer :: i type(string_t) :: name has_pdf = .false. do i = 1, beam_structure%get_n_record () name = beam_structure%get_name (i) has_pdf = has_pdf .or. name == var_str ("pdf_builtin") .or. name == var_str ("lhapdf") end do end function beam_structure_has_pdf @ %def beam_structure_has_pdf @ Return true if the beam structure contains a particular structure function identifier (such as [[lhapdf]], [[isr]], etc.) <>= procedure :: contains => beam_structure_contains <>= function beam_structure_contains (beam_structure, name) result (flag) class(beam_structure_t), intent(in) :: beam_structure character(*), intent(in) :: name logical :: flag integer :: i, j flag = .false. if (allocated (beam_structure%record)) then do i = 1, size (beam_structure%record) do j = 1, size (beam_structure%record(i)%entry) flag = beam_structure%record(i)%entry(j)%name == name if (flag) return end do end do end if end function beam_structure_contains @ %def beam_structure_contains @ Return polarization data. <>= procedure :: polarized => beam_structure_polarized procedure :: get_smatrix => beam_structure_get_smatrix procedure :: get_pol_f => beam_structure_get_pol_f procedure :: asymmetric => beam_structure_asymmetric <>= function beam_structure_polarized (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag flag = allocated (beam_structure%smatrix) end function beam_structure_polarized function beam_structure_get_smatrix (beam_structure) result (smatrix) class(beam_structure_t), intent(in) :: beam_structure type(smatrix_t), dimension(:), allocatable :: smatrix allocate (smatrix (size (beam_structure%smatrix)), & source = beam_structure%smatrix) end function beam_structure_get_smatrix function beam_structure_get_pol_f (beam_structure) result (pol_f) class(beam_structure_t), intent(in) :: beam_structure real(default), dimension(:), allocatable :: pol_f allocate (pol_f (size (beam_structure%pol_f)), & source = beam_structure%pol_f) end function beam_structure_get_pol_f function beam_structure_asymmetric (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag flag = allocated (beam_structure%p) & .or. allocated (beam_structure%theta) & .or. allocated (beam_structure%phi) end function beam_structure_asymmetric @ %def beam_structure_polarized @ %def beam_structure_get_smatrix @ %def beam_structure_get_pol_f @ %def beam_structure_asymmetric @ Return the beam momenta (the space part, i.e., three-momenta). This is meaningful only if momenta and, optionally, angles have been set. <>= procedure :: get_momenta => beam_structure_get_momenta <>= function beam_structure_get_momenta (beam_structure) result (p) class(beam_structure_t), intent(in) :: beam_structure type(vector3_t), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: theta, phi integer :: n, i if (allocated (beam_structure%p)) then n = size (beam_structure%p) if (allocated (beam_structure%theta)) then if (size (beam_structure%theta) == n) then allocate (theta (n), source = beam_structure%theta) else call msg_fatal ("Beam structure: mismatch in momentum vs. & &angle theta specification") end if else allocate (theta (n), source = 0._default) end if if (allocated (beam_structure%phi)) then if (size (beam_structure%phi) == n) then allocate (phi (n), source = beam_structure%phi) else call msg_fatal ("Beam structure: mismatch in momentum vs. & &angle phi specification") end if else allocate (phi (n), source = 0._default) end if allocate (p (n)) do i = 1, n p(i) = beam_structure%p(i) * vector3_moving ([ & sin (theta(i)) * cos (phi(i)), & sin (theta(i)) * sin (phi(i)), & cos (theta(i))]) end do if (n == 2) p(2) = - p(2) else call msg_fatal ("Beam structure: angle theta/phi specified but & &momentum/a p undefined") end if end function beam_structure_get_momenta @ %def beam_structure_get_momenta @ Check for a complete beam structure. The [[applies]] flag tells if the beam structure should actually be used for a process with the given [[n_in]] number of incoming particles. It set if the beam structure matches the process as either decay or scattering. It is unset if beam structure references a scattering setup but the process is a decay. It is also unset if the beam structure itself is empty. If the beam structure cannot be used, terminate with fatal error. <>= procedure :: check_against_n_in => beam_structure_check_against_n_in <>= subroutine beam_structure_check_against_n_in (beam_structure, n_in, applies) class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: n_in logical, intent(out) :: applies if (beam_structure%is_set ()) then if (n_in == beam_structure%get_n_beam ()) then applies = .true. else if (beam_structure%get_n_beam () == 0) then call msg_fatal & ("Asymmetric beams: missing beam particle specification") applies = .false. else call msg_fatal & ("Mismatch of process and beam setup (scattering/decay)") applies = .false. end if else applies = .false. end if end subroutine beam_structure_check_against_n_in @ %def beam_structure_check_against_n_in @ \subsection{Unit Tests} Test module, followed by the corresponding implementation module. <<[[beam_structures_ut.f90]]>>= <> module beam_structures_ut use unit_tests use beam_structures_uti <> <> contains <> end module beam_structures_ut @ %def beam_structures_ut @ <<[[beam_structures_uti.f90]]>>= <> module beam_structures_uti <> <> use beam_structures <> <> contains <> <> end module beam_structures_uti @ %def beam_structures_ut @ API: driver for the unit tests below. <>= public :: beam_structures_test <>= subroutine beam_structures_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine beam_structures_test @ %def beam_structures_tests @ \subsubsection{Empty structure} <>= call test (beam_structures_1, "beam_structures_1", & "empty beam structure record", & u, results) <>= public :: beam_structures_1 <>= subroutine beam_structures_1 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure write (u, "(A)") "* Test output: beam_structures_1" write (u, "(A)") "* Purpose: display empty beam structure record" write (u, "(A)") call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_1" end subroutine beam_structures_1 @ %def beam_structures_1 @ \subsubsection{Nontrivial configurations} <>= call test (beam_structures_2, "beam_structures_2", & "beam structure records", & u, results) <>= public :: beam_structures_2 <>= subroutine beam_structures_2 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure integer, dimension(0) :: empty_array type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_2" write (u, "(A)") "* Purpose: setup beam structure records" write (u, "(A)") s = "s" call beam_structure%init_sf ([s], empty_array) call beam_structure%write (u) write (u, "(A)") call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%write (u) write (u, "(A)") call beam_structure%init_sf ([s, s], [2]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (1, 2, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%init_sf ([s, s], [2, 1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (1, 2, var_str ("b")) call beam_structure%set_sf (2, 1, var_str ("c")) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_2" end subroutine beam_structures_2 @ %def beam_structures_2 @ \subsubsection{Expansion} Provide a function that tells, for the dummy structure function names used here, whether they are considered a two-particle spectrum or a single-particle structure function: <>= function test_strfun_mode (name) result (n) type(string_t), intent(in) :: name integer :: n select case (char (name)) case ("a"); n = 2 case ("b"); n = 1 case default; n = 0 end select end function test_strfun_mode @ %def test_ist_pair_spectrum @ <>= call test (beam_structures_3, "beam_structures_3", & "beam structure expansion", & u, results) <>= public :: beam_structures_3 <>= subroutine beam_structures_3 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_3" write (u, "(A)") "* Purpose: expand beam structure records" write (u, "(A)") s = "s" write (u, "(A)") "* Pair spectrum (keep as-is)" write (u, "(A)") call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Structure function pair (expand)" write (u, "(A)") call beam_structure%init_sf ([s, s], [2]) call beam_structure%set_sf (1, 1, var_str ("b")) call beam_structure%set_sf (1, 2, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Structure function (separate and expand)" write (u, "(A)") call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Combination" write (u, "(A)") call beam_structure%init_sf ([s, s], [1, 1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (2, 1, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_3" end subroutine beam_structures_3 @ %def beam_structures_3 @ \subsubsection{Public methods} Check the methods that can be called to get the beam-structure contents. <>= call test (beam_structures_4, "beam_structures_4", & "beam structure contents", & u, results) <>= public :: beam_structures_4 <>= subroutine beam_structures_4 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure type(string_t) :: s type(string_t), dimension(2) :: prt integer :: i write (u, "(A)") "* Test output: beam_structures_4" write (u, "(A)") "* Purpose: check the API" write (u, "(A)") s = "s" write (u, "(A)") "* Structure-function combination" write (u, "(A)") call beam_structure%init_sf ([s, s], [1, 2, 2]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (2, 1, var_str ("b")) call beam_structure%set_sf (3, 2, var_str ("c")) call beam_structure%write (u) write (u, *) write (u, "(1x,A,I0)") "n_beam = ", beam_structure%get_n_beam () prt = beam_structure%get_prt () write (u, "(1x,A,2(1x,A))") "prt =", char (prt(1)), char (prt(2)) write (u, *) write (u, "(1x,A,I0)") "n_record = ", beam_structure%get_n_record () do i = 1, 3 write (u, "(A)") write (u, "(1x,A,I0,A,A)") "name(", i, ") = ", & char (beam_structure%get_name (i)) write (u, "(1x,A,I0,A,2(1x,I0))") "i_entry(", i, ") =", & beam_structure%get_i_entry (i) end do write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_4" end subroutine beam_structures_4 @ %def beam_structures_4 @ \subsubsection{Polarization} The polarization properties are independent from the structure-function setup. <>= call test (beam_structures_5, "beam_structures_5", & "polarization", & u, results) <>= public :: beam_structures_5 <>= subroutine beam_structures_5 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure integer, dimension(0) :: empty_array type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_5" write (u, "(A)") "* Purpose: setup polarization in beam structure records" write (u, "(A)") s = "s" call beam_structure%init_sf ([s], empty_array) call beam_structure%init_pol (1) call beam_structure%init_smatrix (1, 1) call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default)) call beam_structure%set_pol_f ([0.5_default]) call beam_structure%write (u) write (u, "(A)") call beam_structure%final_sf () call beam_structure%final_pol () call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 2) call beam_structure%set_sentry (1, 1, [-1,1], (0.5_default,-0.5_default)) call beam_structure%set_sentry (1, 2, [ 1,1], (1._default, 0._default)) call beam_structure%init_smatrix (2, 0) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_5" end subroutine beam_structures_5 @ %def beam_structures_5 @ \subsubsection{Momenta} The momenta are independent from the structure-function setup. <>= call test (beam_structures_6, "beam_structures_6", & "momenta", & u, results) <>= public :: beam_structures_6 <>= subroutine beam_structures_6 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure integer, dimension(0) :: empty_array type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_6" write (u, "(A)") "* Purpose: setup momenta in beam structure records" write (u, "(A)") s = "s" call beam_structure%init_sf ([s], empty_array) call beam_structure%set_momentum ([500._default]) call beam_structure%write (u) write (u, "(A)") call beam_structure%final_sf () call beam_structure%final_mom () call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_momentum ([500._default, 700._default]) call beam_structure%set_theta ([0._default, 0.1_default]) call beam_structure%set_phi ([0._default, 1.51_default]) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_6" end subroutine beam_structures_6 @ %def beam_structures_6 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Beams for collisions and decays} <<[[beams.f90]]>>= <> module beams <> <> use io_units use format_defs, only: FMT_19 use numeric_utils use diagnostics use md5 use lorentz use model_data use flavors use quantum_numbers use state_matrices use interactions use polarizations use beam_structures <> <> <> <> contains <> end module beams @ %def beams @ \subsection{Beam data} The beam data type contains beam data for one or two beams, depending on whether we are dealing with beam collisions or particle decay. In addition, it holds the c.m.\ energy [[sqrts]], the Lorentz transformation [[L]] that transforms the c.m.\ system into the lab system, and the pair of c.m.\ momenta. <>= public :: beam_data_t <>= type :: beam_data_t logical :: initialized = .false. integer :: n = 0 type(flavor_t), dimension(:), allocatable :: flv real(default), dimension(:), allocatable :: mass type(pmatrix_t), dimension(:), allocatable :: pmatrix logical :: lab_is_cm = .true. type(vector4_t), dimension(:), allocatable :: p_cm type(vector4_t), dimension(:), allocatable :: p type(lorentz_transformation_t), allocatable :: L_cm_to_lab real(default) :: sqrts = 0 character(32) :: md5sum = "" contains <> end type beam_data_t @ %def beam_data_t @ Generic initializer. This is called by the specific initializers below. Initialize either for decay or for collision. <>= subroutine beam_data_init (beam_data, n) type(beam_data_t), intent(out) :: beam_data integer, intent(in) :: n beam_data%n = n allocate (beam_data%flv (n)) allocate (beam_data%mass (n)) allocate (beam_data%pmatrix (n)) allocate (beam_data%p_cm (n)) allocate (beam_data%p (n)) beam_data%initialized = .true. end subroutine beam_data_init @ %def beam_data_init @ Finalizer: needed for the polarization components of the beams. <>= procedure :: final => beam_data_final <>= subroutine beam_data_final (beam_data) class(beam_data_t), intent(inout) :: beam_data beam_data%initialized = .false. end subroutine beam_data_final @ %def beam_data_final @ The verbose (default) version is for debugging. The short version is for screen output in the UI. <>= procedure :: write => beam_data_write <>= subroutine beam_data_write (beam_data, unit, verbose, write_md5sum) class(beam_data_t), intent(in) :: beam_data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, write_md5sum integer :: prt_name_len logical :: verb, write_md5 integer :: u u = given_output_unit (unit); if (u < 0) return verb = .false.; if (present (verbose)) verb = verbose write_md5 = verb; if (present (write_md5sum)) write_md5 = write_md5sum if (.not. beam_data%initialized) then write (u, "(1x,A)") "Beam data: [undefined]" return end if prt_name_len = maxval (len (beam_data%flv%get_name ())) select case (beam_data%n) case (1) write (u, "(1x,A)") "Beam data (decay):" if (verb) then call write_prt (1) call beam_data%pmatrix(1)%write (u) write (u, *) "R.f. momentum:" call vector4_write (beam_data%p_cm(1), u) write (u, *) "Lab momentum:" call vector4_write (beam_data%p(1), u) else call write_prt (1) end if case (2) write (u, "(1x,A)") "Beam data (collision):" if (verb) then call write_prt (1) call beam_data%pmatrix(1)%write (u) call write_prt (2) call beam_data%pmatrix(2)%write (u) call write_sqrts write (u, *) "C.m. momenta:" call vector4_write (beam_data%p_cm(1), u) call vector4_write (beam_data%p_cm(2), u) write (u, *) "Lab momenta:" call vector4_write (beam_data%p(1), u) call vector4_write (beam_data%p(2), u) else call write_prt (1) call write_prt (2) call write_sqrts end if end select if (allocated (beam_data%L_cm_to_lab)) then if (verb) then call lorentz_transformation_write (beam_data%L_cm_to_lab, u) else write (u, "(1x,A)") "Beam structure: lab and c.m. frame differ" end if end if if (write_md5) then write (u, *) "MD5 sum: ", beam_data%md5sum end if contains subroutine write_sqrts character(80) :: sqrts_str write (sqrts_str, "(" // FMT_19 // ")") beam_data%sqrts write (u, "(3x,A)") "sqrts = " // trim (adjustl (sqrts_str)) // " GeV" end subroutine write_sqrts subroutine write_prt (i) integer, intent(in) :: i character(80) :: name_str, mass_str write (name_str, "(A)") char (beam_data%flv(i)%get_name ()) write (mass_str, "(ES13.7)") beam_data%mass(i) write (u, "(3x,A)", advance="no") & name_str(:prt_name_len) // " (mass = " & // trim (adjustl (mass_str)) // " GeV)" if (beam_data%pmatrix(i)%is_polarized ()) then write (u, "(2x,A)") "polarized" else write (u, *) end if end subroutine write_prt end subroutine beam_data_write @ %def beam_data_write @ Return initialization status: <>= procedure :: are_valid => beam_data_are_valid <>= function beam_data_are_valid (beam_data) result (flag) class(beam_data_t), intent(in) :: beam_data logical :: flag flag = beam_data%initialized end function beam_data_are_valid @ %def beam_data_are_valid @ Check whether beam data agree with the current values of relevant parameters. <>= procedure :: check_scattering => beam_data_check_scattering <>= subroutine beam_data_check_scattering (beam_data, sqrts) class(beam_data_t), intent(in) :: beam_data real(default), intent(in), optional :: sqrts if (beam_data_are_valid (beam_data)) then if (present (sqrts)) then if (.not. nearly_equal (sqrts, beam_data%sqrts)) then call msg_error ("Current setting of sqrts is inconsistent " & // "with beam setup (ignored).") end if end if else call msg_bug ("Beam setup: invalid beam data") end if end subroutine beam_data_check_scattering @ %def beam_data_check_scattering @ Return the number of beams (1 for decays, 2 for collisions). <>= procedure :: get_n_in => beam_data_get_n_in <>= function beam_data_get_n_in (beam_data) result (n_in) class(beam_data_t), intent(in) :: beam_data integer :: n_in n_in = beam_data%n end function beam_data_get_n_in @ %def beam_data_get_n_in @ Return the beam flavor <>= procedure :: get_flavor => beam_data_get_flavor <>= function beam_data_get_flavor (beam_data) result (flv) class(beam_data_t), intent(in) :: beam_data type(flavor_t), dimension(:), allocatable :: flv allocate (flv (beam_data%n)) flv = beam_data%flv end function beam_data_get_flavor @ %def beam_data_get_flavor @ Return the beam energies <>= procedure :: get_energy => beam_data_get_energy <>= function beam_data_get_energy (beam_data) result (e) class(beam_data_t), intent(in) :: beam_data real(default), dimension(:), allocatable :: e integer :: i allocate (e (beam_data%n)) if (beam_data%initialized) then do i = 1, beam_data%n e(i) = energy (beam_data%p(i)) end do else e = 0 end if end function beam_data_get_energy @ %def beam_data_get_energy @ Return the c.m.\ energy. <>= procedure :: get_sqrts => beam_data_get_sqrts <>= function beam_data_get_sqrts (beam_data) result (sqrts) class(beam_data_t), intent(in) :: beam_data real(default) :: sqrts sqrts = beam_data%sqrts end function beam_data_get_sqrts @ %def beam_data_get_sqrts @ Return the polarization in case it is just two degrees <>= procedure :: get_polarization => beam_data_get_polarization <>= function beam_data_get_polarization (beam_data) result (pol) class(beam_data_t), intent(in) :: beam_data real(default), dimension(beam_data%n) :: pol pol = beam_data%pmatrix%get_simple_pol () end function beam_data_get_polarization @ %def beam_data_get_polarization @ <>= procedure :: get_helicity_state_matrix => beam_data_get_helicity_state_matrix <>= function beam_data_get_helicity_state_matrix (beam_data) result (state_hel) type(state_matrix_t) :: state_hel class(beam_data_t), intent(in) :: beam_data type(polarization_t), dimension(:), allocatable :: pol integer :: i allocate (pol (beam_data%n)) do i = 1, beam_data%n call pol(i)%init_pmatrix (beam_data%pmatrix(i)) end do call combine_polarization_states (pol, state_hel) end function beam_data_get_helicity_state_matrix @ %def beam_data_get_helicity_state_matrix @ <>= procedure :: is_initialized => beam_data_is_initialized <>= function beam_data_is_initialized (beam_data) result (initialized) logical :: initialized class(beam_data_t), intent(in) :: beam_data initialized = any (beam_data%pmatrix%exists ()) end function beam_data_is_initialized @ %def beam_data_is_initialized @ Return a MD5 checksum for beam data. If no checksum is present (because beams have not been initialized), compute the checksum of the sqrts value. <>= procedure :: get_md5sum => beam_data_get_md5sum <>= function beam_data_get_md5sum (beam_data, sqrts) result (md5sum_beams) class(beam_data_t), intent(in) :: beam_data real(default), intent(in) :: sqrts character(32) :: md5sum_beams character(80) :: buffer if (beam_data%md5sum /= "") then md5sum_beams = beam_data%md5sum else write (buffer, *) sqrts md5sum_beams = md5sum (buffer) end if end function beam_data_get_md5sum @ %def beam_data_get_md5sum @ \subsection{Initializers: beam structure} Initialize the beam data object from a beam structure object, given energy and model. <>= procedure :: init_structure => beam_data_init_structure <>= subroutine beam_data_init_structure & (beam_data, structure, sqrts, model, decay_rest_frame) class(beam_data_t), intent(out) :: beam_data type(beam_structure_t), intent(in) :: structure integer :: n_beam real(default), intent(in) :: sqrts class(model_data_t), intent(in), target :: model logical, intent(in), optional :: decay_rest_frame type(flavor_t), dimension(:), allocatable :: flv n_beam = structure%get_n_beam () allocate (flv (n_beam)) call flv%init (structure%get_prt (), model) if (structure%asymmetric ()) then if (structure%polarized ()) then call beam_data%init_momenta (structure%get_momenta (), flv, & structure%get_smatrix (), structure%get_pol_f ()) else call beam_data%init_momenta (structure%get_momenta (), flv) end if else select case (n_beam) case (1) if (structure%polarized ()) then call beam_data%init_decay (flv, & structure%get_smatrix (), structure%get_pol_f (), & rest_frame = decay_rest_frame) else call beam_data%init_decay (flv, & rest_frame = decay_rest_frame) end if case (2) if (structure%polarized ()) then call beam_data%init_sqrts (sqrts, flv, & structure%get_smatrix (), structure%get_pol_f ()) else call beam_data%init_sqrts (sqrts, flv) end if case default call msg_bug ("Beam data: invalid beam structure object") end select end if end subroutine beam_data_init_structure @ %def beam_data_init_structure @ \subsection{Initializers: collisions} This is the simplest one: just the two flavors, c.m.\ energy, polarization. Color is inferred from flavor. Beam momenta and c.m.\ momenta coincide. <>= procedure :: init_sqrts => beam_data_init_sqrts <>= subroutine beam_data_init_sqrts (beam_data, sqrts, flv, smatrix, pol_f) class(beam_data_t), intent(out) :: beam_data real(default), intent(in) :: sqrts type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f real(default), dimension(size(flv)) :: E, p call beam_data_init (beam_data, size (flv)) beam_data%sqrts = sqrts beam_data%lab_is_cm = .true. select case (beam_data%n) case (1) E = sqrts; p = 0 beam_data%p_cm = vector4_moving (E, p, 3) beam_data%p = beam_data%p_cm case (2) beam_data%p_cm = colliding_momenta (sqrts, flv%get_mass ()) beam_data%p = colliding_momenta (sqrts, flv%get_mass ()) end select call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f) end subroutine beam_data_init_sqrts @ %def beam_data_init_sqrts @ This version sets beam momenta directly, assuming that they are asymmetric, i.e., lab frame and c.m.\ frame do not coincide. Polarization info is deferred to a common initializer. The Lorentz transformation that we compute here is not actually used in the calculation; instead, it will be recomputed for each event in the subroutine [[phs_set_incoming_momenta]]. We compute it here for the nominal beam setup nevertheless, so we can print it and, in particular, include it in the MD5 sum. <>= procedure :: init_momenta => beam_data_init_momenta <>= subroutine beam_data_init_momenta (beam_data, p3, flv, smatrix, pol_f) class(beam_data_t), intent(out) :: beam_data type(vector3_t), dimension(:), intent(in) :: p3 type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f type(vector4_t) :: p0 type(vector4_t), dimension(:), allocatable :: p, p_cm_rot real(default), dimension(size(p3)) :: e real(default), dimension(size(flv)) :: m type(lorentz_transformation_t) :: L_boost, L_rot call beam_data_init (beam_data, size (flv)) m = flv%get_mass () e = sqrt (p3 ** 2 + m ** 2) allocate (p (beam_data%n)) p = vector4_moving (e, p3) p0 = sum (p) beam_data%p = p beam_data%lab_is_cm = .false. beam_data%sqrts = p0 ** 1 L_boost = boost (p0, beam_data%sqrts) allocate (p_cm_rot (beam_data%n)) p_cm_rot = inverse (L_boost) * p allocate (beam_data%L_cm_to_lab) select case (beam_data%n) case (1) beam_data%L_cm_to_lab = L_boost beam_data%p_cm = vector4_at_rest (beam_data%sqrts) case (2) L_rot = rotation_to_2nd (3, space_part (p_cm_rot(1))) beam_data%L_cm_to_lab = L_boost * L_rot beam_data%p_cm = & colliding_momenta (beam_data%sqrts, flv%get_mass ()) end select call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f) end subroutine beam_data_init_momenta @ %def beam_data_init_momenta @ Final steps: If requested, rotate the beams in the lab frame, and set the beam-data components. <>= subroutine beam_data_finish_initialization (beam_data, flv, smatrix, pol_f) type(beam_data_t), intent(inout) :: beam_data type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f integer :: i do i = 1, beam_data%n beam_data%flv(i) = flv(i) beam_data%mass(i) = flv(i)%get_mass () if (present (smatrix)) then if (size (smatrix) /= beam_data%n) & call msg_fatal ("Beam data: & &polarization density array has wrong dimension") beam_data%pmatrix(i) = smatrix(i) if (present (pol_f)) then if (size (pol_f) /= size (smatrix)) & call msg_fatal ("Beam data: & &polarization fraction array has wrong dimension") call beam_data%pmatrix(i)%normalize (flv(i), pol_f(i)) else call beam_data%pmatrix(i)%normalize (flv(i), 1._default) end if else call beam_data%pmatrix(i)%init (2, 0) call beam_data%pmatrix(i)%normalize (flv(i), 0._default) end if end do call beam_data%compute_md5sum () end subroutine beam_data_finish_initialization @ %def beam_data_finish_initialization @ The MD5 sum is stored within the beam-data record, so it can be checked for integrity in subsequent runs. <>= procedure :: compute_md5sum => beam_data_compute_md5sum <>= subroutine beam_data_compute_md5sum (beam_data) class(beam_data_t), intent(inout) :: beam_data integer :: unit unit = free_unit () open (unit = unit, status = "scratch", action = "readwrite") call beam_data%write (unit, write_md5sum = .false., & verbose = .true.) rewind (unit) beam_data%md5sum = md5sum (unit) close (unit) end subroutine beam_data_compute_md5sum @ %def beam_data_compute_md5sum @ \subsection{Initializers: decays} This is the simplest one: decay in rest frame. We need just flavor and polarization. Color is inferred from flavor. Beam momentum and c.m.\ momentum coincide. <>= procedure :: init_decay => beam_data_init_decay <>= subroutine beam_data_init_decay (beam_data, flv, smatrix, pol_f, rest_frame) class(beam_data_t), intent(out) :: beam_data type(flavor_t), dimension(1), intent(in) :: flv type(smatrix_t), dimension(1), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f logical, intent(in), optional :: rest_frame real(default), dimension(1) :: m m = flv%get_mass () if (present (smatrix)) then call beam_data%init_sqrts (m(1), flv, smatrix, pol_f) else call beam_data%init_sqrts (m(1), flv, smatrix, pol_f) end if if (present (rest_frame)) beam_data%lab_is_cm = rest_frame end subroutine beam_data_init_decay @ %def beam_data_init_decay @ \subsection{The beams type} Beam objects are interaction objects that contain the actual beam data including polarization and density matrix. For collisions, the beam object actually contains two beams. <>= public :: beam_t <>= type :: beam_t private type(interaction_t) :: int end type beam_t @ %def beam_t @ The constructor contains code that converts beam data into the (entangled) particle-pair quantum state. First, we set the number of particles and polarization mask. (The polarization mask is handed over to all later interactions, so if helicity is diagonal or absent, this fact is used when constructing the hard-interaction events.) Then, we construct the entangled state that combines helicity, flavor and color of the two particles (where flavor and color are unique, while several helicity states are possible). Then, we transfer this state together with the associated values from the spin density matrix into the [[interaction_t]] object. Calling the [[add_state]] method of the interaction object, we keep the entries of the helicity density matrix without adding them up. This ensures that for unpolarized states, we do not normalize but end up with an $1/N$ entry, where $N$ is the initial-state multiplicity. <>= public :: beam_init <>= subroutine beam_init (beam, beam_data) type(beam_t), intent(out) :: beam type(beam_data_t), intent(in), target :: beam_data logical, dimension(beam_data%n) :: polarized, diagonal type(quantum_numbers_mask_t), dimension(beam_data%n) :: mask, mask_d type(state_matrix_t), target :: state_hel, state_fc, state_tmp type(state_iterator_t) :: it_hel, it_tmp type(quantum_numbers_t), dimension(:), allocatable :: qn complex(default) :: value real(default), parameter :: tolerance = 100 * epsilon (1._default) polarized = beam_data%pmatrix%is_polarized () diagonal = beam_data%pmatrix%is_diagonal () mask = quantum_numbers_mask (.false., .false., & mask_h = .not. polarized, & mask_hd = diagonal) mask_d = quantum_numbers_mask (.false., .false., .false., & mask_hd = polarized .and. diagonal) call beam%int%basic_init & (0, 0, beam_data%n, mask = mask, store_values = .true.) state_hel = beam_data%get_helicity_state_matrix () allocate (qn (beam_data%n)) call qn%init (beam_data%flv, color_from_flavor (beam_data%flv, 1)) call state_fc%init () call state_fc%add_state (qn) call merge_state_matrices (state_hel, state_fc, state_tmp) call it_hel%init (state_hel) call it_tmp%init (state_tmp) do while (it_hel%is_valid ()) qn = it_tmp%get_quantum_numbers () value = it_hel%get_matrix_element () if (any (qn%are_redundant (mask_d))) then ! skip off-diagonal elements for diagonal polarization else if (abs (value) <= tolerance) then ! skip zero entries else call beam%int%add_state (qn, value = value) end if call it_hel%advance () call it_tmp%advance () end do call beam%int%freeze () call beam%int%set_momenta (beam_data%p, outgoing = .true.) call state_hel%final () call state_fc%final () call state_tmp%final () end subroutine beam_init @ %def beam_init @ Finalizer: <>= public :: beam_final <>= subroutine beam_final (beam) type(beam_t), intent(inout) :: beam call beam%int%final () end subroutine beam_final @ %def beam_final @ I/O: <>= public :: beam_write <>= subroutine beam_write (beam, unit, verbose, show_momentum_sum, show_mass, col_verbose) type(beam_t), intent(in) :: beam integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, show_momentum_sum, show_mass logical, intent(in), optional :: col_verbose integer :: u u = given_output_unit (unit); if (u < 0) return select case (beam%int%get_n_out ()) case (1); write (u, *) "Decaying particle:" case (2); write (u, *) "Colliding beams:" end select call beam%int%basic_write & (unit, verbose = verbose, show_momentum_sum = & show_momentum_sum, show_mass = show_mass, & col_verbose = col_verbose) end subroutine beam_write @ %def beam_write @ Defined assignment: deep copy <>= public :: assignment(=) <>= interface assignment(=) module procedure beam_assign end interface <>= subroutine beam_assign (beam_out, beam_in) type(beam_t), intent(out) :: beam_out type(beam_t), intent(in) :: beam_in beam_out%int = beam_in%int end subroutine beam_assign @ %def beam_assign @ \subsection{Inherited procedures} <>= public :: interaction_set_source_link <>= interface interaction_set_source_link module procedure interaction_set_source_link_beam end interface <>= subroutine interaction_set_source_link_beam (int, i, beam1, i1) type(interaction_t), intent(inout) :: int type(beam_t), intent(in), target :: beam1 integer, intent(in) :: i, i1 call int%set_source_link (i, beam1%int, i1) end subroutine interaction_set_source_link_beam @ %def interaction_set_source_link_beam @ \subsection{Accessing contents} Return the interaction component -- as a pointer, to avoid any copying. <>= public :: beam_get_int_ptr <>= function beam_get_int_ptr (beam) result (int) type(interaction_t), pointer :: int type(beam_t), intent(in), target :: beam int => beam%int end function beam_get_int_ptr @ %def beam_get_int_ptr @ Set beam momenta directly. (Used for cascade decays.) <>= public :: beam_set_momenta <>= subroutine beam_set_momenta (beam, p) type(beam_t), intent(inout) :: beam type(vector4_t), dimension(:), intent(in) :: p call beam%int%set_momenta (p) end subroutine beam_set_momenta @ %def beam_set_momenta @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[beams_ut.f90]]>>= <> module beams_ut use unit_tests use beams_uti <> <> contains <> end module beams_ut @ %def beams_ut @ <<[[beams_uti.f90]]>>= <> module beams_uti <> use lorentz use flavors use interactions, only: reset_interaction_counter use polarizations, only: smatrix_t use model_data use beam_structures use beams <> <> contains <> end module beams_uti @ %def beams_ut @ API: driver for the unit tests below. <>= public :: beams_test <>= subroutine beams_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine beams_test @ %def beams_test @ Test the basic beam setup. <>= call test (beam_1, "beam_1", & "check basic beam setup", & u, results) <>= public :: beam_1 <>= subroutine beam_1 (u) integer, intent(in) :: u type(beam_data_t), target :: beam_data type(beam_t) :: beam real(default) :: sqrts type(flavor_t), dimension(2) :: flv type(smatrix_t), dimension(2) :: smatrix real(default), dimension(2) :: pol_f type(model_data_t), target :: model write (u, "(A)") "* Test output: beam_1" write (u, "(A)") "* Purpose: test basic beam setup" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call reset_interaction_counter () call model%init_sm_test () write (u, "(A)") "* Unpolarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call beam_data%init_sqrts (sqrts, flv) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call beam_data%init_sqrts (sqrts, flv) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call beam_data%init_sqrts (sqrts, flv) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Polarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call smatrix(1)%init (2, 1) call smatrix(1)%set_entry (1, [1,1], (1._default, 0._default)) pol_f(1) = 0.5_default call smatrix(2)%init (2, 3) call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default)) call smatrix(2)%set_entry (2, [-1,-1], (1._default, 0._default)) call smatrix(2)%set_entry (3, [-1,1], (1._default, 0._default)) pol_f(2) = 1._default call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call smatrix(1)%init (2, 0) pol_f(1) = 0._default call smatrix(2)%init (2, 1) call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default)) pol_f(2) = 1._default call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call smatrix(1)%init (2, 0) pol_f(1) = 0._default call smatrix(2)%init (2, 1) call smatrix(2)%set_entry (1, [0,0], (1._default, 0._default)) pol_f(2) = 1._default call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call beam_data%init_decay (flv(1:1)) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Polarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call smatrix(1)%init (2, 1) call smatrix(1)%set_entry (1, [0,0], (1._default, 0._default)) pol_f(1) = 0.4_default call beam_data%init_decay (flv(1:1), smatrix(1:1), pol_f(1:1)) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call beam_final (beam) call beam_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: beam_1" end subroutine beam_1 @ %def beam_1 @ Test advanced beam setup. <>= call test (beam_2, "beam_2", & "beam initialization", & u, results) <>= public :: beam_2 <>= subroutine beam_2 (u) integer, intent(in) :: u type(beam_data_t), target :: beam_data type(beam_t) :: beam real(default) :: sqrts type(flavor_t), dimension(2) :: flv integer, dimension(0) :: no_records type(beam_structure_t) :: beam_structure type(model_data_t), target :: model write (u, "(A)") "* Test output: beam_2" write (u, "(A)") "* Purpose: transfer beam polarization using & &beam structure" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call model%init_sm_test () write (u, "(A)") "* Unpolarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Polarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 1) call beam_structure%set_sentry (1, 1, [1,1], (1._default, 0._default)) call beam_structure%init_smatrix (2, 3) call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default)) call beam_structure%set_sentry (2, 2, [-1,-1], (1._default, 0._default)) call beam_structure%set_sentry (2, 3, [-1,1], (1._default, 0._default)) call beam_structure%set_pol_f ([0.5_default, 1._default]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, *) call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () call beam_structure%final_pol () call beam_structure%final_sf () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 0) call beam_structure%init_smatrix (2, 1) call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default)) call beam_structure%set_pol_f ([0._default, 1._default]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 0) call beam_structure%init_smatrix (2, 1) call beam_structure%set_sentry (2, 1, [0,0], (1._default, 0._default)) call beam_structure%write (u) write (u, "(A)") call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call beam_structure%init_sf ([flv(1)%get_name ()], no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, "(A)") call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Polarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call beam_structure%init_sf ([flv(1)%get_name ()], no_records) call beam_structure%init_pol (1) call beam_structure%init_smatrix (1, 1) call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default)) call beam_structure%set_pol_f ([0.4_default]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call beam_final (beam) call beam_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: beam_2" end subroutine beam_2 @ %def beam_2 @ Test advanced beam setup, completely arbitrary momenta. <>= call test (beam_3, "beam_3", & "generic beam momenta", & u, results) <>= public :: beam_3 <>= subroutine beam_3 (u) integer, intent(in) :: u type(beam_data_t), target :: beam_data type(beam_t) :: beam type(flavor_t), dimension(2) :: flv integer, dimension(0) :: no_records type(model_data_t), target :: model type(beam_structure_t) :: beam_structure type(vector3_t), dimension(2) :: p3 type(vector4_t), dimension(2) :: p write (u, "(A)") "* Test output: beam_3" write (u, "(A)") "* Purpose: set up beams with generic momenta" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call reset_interaction_counter () call model%init_sm_test () write (u, "(A)") "* 1: Scattering process" write (u, "(A)") call flv%init ([2212,2212], model) p3(1) = vector3_moving ([5._default, 0._default, 10._default]) p3(2) = -vector3_moving ([1._default, 1._default, -10._default]) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%set_momentum (p3 ** 1) call beam_structure%set_theta (polar_angle (p3)) call beam_structure%set_phi (azimuthal_angle (p3)) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, 0._default, model) call pacify (beam_data%l_cm_to_lab, 1e-20_default) call beam_data%compute_md5sum () call beam_data%write (u, verbose = .true.) write (u, *) write (u, "(1x,A)") "Beam momenta reconstructed from LT:" p = beam_data%L_cm_to_lab * beam_data%p_cm call pacify (p, 1e-12_default) call vector4_write (p(1), u) call vector4_write (p(2), u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () call beam_structure%final_sf () call beam_structure%final_mom () write (u, "(A)") write (u, "(A)") "* 2: Decay" write (u, "(A)") call flv(1)%init (23, model) p3(1) = vector3_moving ([10._default, 5._default, 50._default]) call beam_structure%init_sf ([flv(1)%get_name ()], no_records) call beam_structure%set_momentum ([p3(1) ** 1]) call beam_structure%set_theta ([polar_angle (p3(1))]) call beam_structure%set_phi ([azimuthal_angle (p3(1))]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, 0._default, model) call beam_data%write (u, verbose = .true.) write (u, "(A)") write (u, "(1x,A)") "Beam momentum reconstructed from LT:" p(1) = beam_data%L_cm_to_lab * beam_data%p_cm(1) call pacify (p(1), 1e-12_default) call vector4_write (p(1), u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call beam_final (beam) call beam_data%final () call beam_structure%final_sf () call beam_structure%final_mom () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: beam_3" end subroutine beam_3 @ %def beam_3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Tools} This module contains auxiliary procedures that can be accessed by the structure function code. <<[[sf_aux.f90]]>>= <> module sf_aux <> use io_units use constants, only: twopi use numeric_utils use lorentz <> <> <> <> contains <> end module sf_aux @ %def sf_aux @ \subsection{Momentum splitting} Let us consider first an incoming parton with momentum $k$ and invariant mass squared $s=k^2$ that splits into two partons with momenta $q,p$ and invariant masses $t=q^2$ and $u=p^2$. (This is an abuse of the Mandelstam notation. $t$ is actually the momentum transfer, assuming that $p$ is radiated and $q$ initiates the hard process.) The energy is split among the partons such that if $E=k^0$, we have $q^0 = xE$ and $p^0=\bar x E$, where $\bar x\equiv 1-x$. We define the angle $\theta$ as the polar angle of $p$ w.r.t.\ the momentum axis of the incoming momentum $k$. Ignoring azimuthal angle, we can write the four-momenta in the basis $(E,p_T,p_L)$ as \begin{equation} k = \begin{pmatrix} E \\ 0 \\ p \end{pmatrix}, \qquad p = \begin{pmatrix} \bar x E \\ \bar x\bar p\sin\theta \\ \bar x\bar p\cos\theta \end{pmatrix}, \qquad q = \begin{pmatrix} x E \\ -\bar x\bar p\sin\theta \\ p - \bar x\bar p\cos\theta \end{pmatrix}, \end{equation} where the first two mass-shell conditions are \begin{equation} p^2 = E^2 - s, \qquad \bar p^2 = E^2 - \frac{u}{\bar x^2}. \end{equation} The second condition implies that, for positive $u$, $\bar x^2 > u/E^2$, or equivalently \begin{equation} x < 1 - \sqrt{u} / E. \end{equation} We are interested in the third mass-shell conditions: $s$ and $u$ are fixed, so we need $t$ as a function of $\cos\theta$: \begin{equation} t = -2\bar x \left(E^2 - p\bar p\cos\theta\right) + s + u. \end{equation} Solving for $\cos\theta$, we get \begin{equation} \cos\theta = \frac{2\bar x E^2 + t - s - u}{2\bar x p\bar p}. \end{equation} We can compute $\sin\theta$ numerically as $\sin^2\theta=1-\cos^2\theta$, but it is important to reexpress this in view of numerical stability. To this end, we first determine the bounds for $t$. The cosine must be between $-1$ and $1$, so the bounds are \begin{align} t_0 &= -2\bar x\left(E^2 + p\bar p\right) + s + u, \\ t_1 &= -2\bar x\left(E^2 - p\bar p\right) + s + u. \end{align} Computing $\sin^2\theta$ from $\cos\theta$ above, we observe that the numerator is a quadratic polynomial in $t$ which has the zeros $t_0$ and $t_1$, while the common denominator is given by $(2\bar x p\bar p)^2$. Hence, we can write \begin{equation} \sin^2\theta = -\frac{(t - t_0)(t - t_1)}{(2\bar x p\bar p)^2} \qquad\text{and}\qquad \cos\theta = \frac{(t-t_0) + (t-t_1)}{4\bar x p\bar p}, \end{equation} which is free of large cancellations near $t=t_0$ or $t=t_1$. If all is massless, i.e., $s=u=0$, this simplifies to \begin{align} t_0 &= -4\bar x E^2, & t_1 &= 0, \\ \sin^2\theta &= -\frac{t}{\bar x E^2} \left(1 + \frac{t}{4\bar x E^2}\right), & \cos\theta &= 1 + \frac{t}{2\bar x E^2}. \end{align} Here is the implementation. First, we define a container for the kinematical integration limits and some further data. Note: contents are public only for easy access in unit test. <>= public :: splitting_data_t <>= type :: splitting_data_t ! private logical :: collinear = .false. real(default) :: x0 = 0 real(default) :: x1 real(default) :: t0 real(default) :: t1 real(default) :: phi0 = 0 real(default) :: phi1 = twopi real(default) :: E, p, s, u, m2 real(default) :: x, xb, pb real(default) :: t = 0 real(default) :: phi = 0 contains <> end type splitting_data_t @ %def splitting_data_t @ I/O for debugging: <>= procedure :: write => splitting_data_write <>= subroutine splitting_data_write (d, unit) class(splitting_data_t), intent(in) :: d integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(A)") "Splitting data:" write (u, "(2x,A,L1)") "collinear = ", d%collinear 1 format (2x,A,1x,ES15.8) write (u, 1) "x0 =", d%x0 write (u, 1) "x =", d%x write (u, 1) "xb =", d%xb write (u, 1) "x1 =", d%x1 write (u, 1) "t0 =", d%t0 write (u, 1) "t =", d%t write (u, 1) "t1 =", d%t1 write (u, 1) "phi0 =", d%phi0 write (u, 1) "phi =", d%phi write (u, 1) "phi1 =", d%phi1 write (u, 1) "E =", d%E write (u, 1) "p =", d%p write (u, 1) "pb =", d%pb write (u, 1) "s =", d%s write (u, 1) "u =", d%u write (u, 1) "m2 =", d%m2 end subroutine splitting_data_write @ %def splitting_data_write @ \subsection{Constant data} This is the initializer for the data. The input consists of the incoming momentum, its invariant mass squared, and the invariant mass squared of the radiated particle. $m2$ is the \emph{physical} mass squared of the outgoing particle. The $t$ bounds depend on the chosen $x$ value and cannot be determined yet. <>= procedure :: init => splitting_data_init <>= subroutine splitting_data_init (d, k, mk2, mr2, mo2, collinear) class(splitting_data_t), intent(out) :: d type(vector4_t), intent(in) :: k real(default), intent(in) :: mk2, mr2, mo2 logical, intent(in), optional :: collinear if (present (collinear)) d%collinear = collinear d%E = energy (k) d%x1 = 1 - sqrt (max (mr2, 0._default)) / d%E d%p = sqrt (d%E**2 - mk2) d%s = mk2 d%u = mr2 d%m2 = mo2 end subroutine splitting_data_init @ %def splitting_data_init @ Retrieve the $x$ bounds, if needed for $x$ sampling. Generating an $x$ value is done by the caller, since this is the part that depends on the nature of the structure function. <>= procedure :: get_x_bounds => splitting_get_x_bounds <>= function splitting_get_x_bounds (d) result (x) class(splitting_data_t), intent(in) :: d real(default), dimension(2) :: x x = [ d%x0, d%x1 ] end function splitting_get_x_bounds @ %def splitting_get_x_bounds @ Now set the momentum fraction and compute $t_0$ and $t_1$. [The calculation of $t_1$ is subject to numerical problems. The exact formula is ($s=m_i^2$, $u=m_r^2$) \begin{equation} t_1 = -2\bar x E^2 + m_i^2 + m_r^2 + 2\bar x \sqrt{E^2-m_i^2}\,\sqrt{E^2 - m_r^2/\bar x^2}. \end{equation} The structure-function paradigm is useful only if $E\gg m_i,m_r$. In a Taylor expansion for large $E$, the leading term cancels. The expansion of the square roots (to subleading order) yields \begin{equation} t_1 = xm_i^2 - \frac{x}{\bar x}m_r^2. \end{equation} There are two cases of interest: $m_i=m_o$ and $m_r=0$, \begin{equation} t_1 = xm_o^2 \end{equation} and $m_i=m_r$ and $m_o=0$, \begin{equation} t_1 = -\frac{x^2}{\bar x}m_i^2. \end{equation} In both cases, $t_1\leq m_o^2$.] That said, it turns out that taking the $t_1$ evaluation at face value leads to less problems than the approximation. We express the angles in terms of $t-t_0$ and $t-t_1$. Numerical noise in $t_1$ can then be tolerated. <>= procedure :: set_t_bounds => splitting_set_t_bounds <>= elemental subroutine splitting_set_t_bounds (d, x, xb) class(splitting_data_t), intent(inout) :: d real(default), intent(in), optional :: x, xb real(default) :: tp, tm if (present (x)) d%x = x if (present (xb)) d%xb = xb if (vanishes (d%u)) then d%pb = d%E else if (.not. vanishes (d%xb)) then d%pb = sqrt (max (d%E**2 - d%u / d%xb**2, 0._default)) else d%pb = 0 end if end if tp = -2 * d%xb * d%E**2 + d%s + d%u tm = -2 * d%xb * d%p * d%pb d%t0 = tp + tm d%t1 = tp - tm d%t = d%t1 end subroutine splitting_set_t_bounds @ %def splitting_set_t_bounds @ \subsection{Sampling recoil} Compute a value for the momentum transfer $t$, using a random number $r$. We assume a logarithmic distribution for $t-m^2$, corresponding to the propagator $1/(t-m^2)$ with the physical mass $m$ for the outgoing particle. Optionally, we can narrow the kinematical bounds. If all three masses in the splitting vanish, the upper limit for $t$ is zero. In that case, the $t$ value is set to zero and the splitting will be collinear. <>= procedure :: sample_t => splitting_sample_t <>= subroutine splitting_sample_t (d, r, t0, t1) class(splitting_data_t), intent(inout) :: d real(default), intent(in) :: r real(default), intent(in), optional :: t0, t1 real(default) :: tt0, tt1, tt0m, tt1m if (d%collinear) then d%t = d%t1 else tt0 = d%t0; if (present (t0)) tt0 = max (t0, tt0) tt1 = d%t1; if (present (t1)) tt1 = min (t1, tt1) tt0m = tt0 - d%m2 tt1m = tt1 - d%m2 if (tt0m < 0 .and. tt1m < 0 .and. abs(tt0m) > & epsilon(tt0m) .and. abs(tt1m) > epsilon(tt0m)) then d%t = d%m2 + tt0m * exp (r * log (tt1m / tt0m)) else d%t = tt1 end if end if end subroutine splitting_sample_t @ %def splitting_sample_t @ The inverse operation: Given $t$, we recover the value of $r$ that would have produced this value. <>= procedure :: inverse_t => splitting_inverse_t <>= subroutine splitting_inverse_t (d, r, t0, t1) class(splitting_data_t), intent(in) :: d real(default), intent(out) :: r real(default), intent(in), optional :: t0, t1 real(default) :: tt0, tt1, tt0m, tt1m if (d%collinear) then r = 0 else tt0 = d%t0; if (present (t0)) tt0 = max (t0, tt0) tt1 = d%t1; if (present (t1)) tt1 = min (t1, tt1) tt0m = tt0 - d%m2 tt1m = tt1 - d%m2 if (tt0m < 0 .and. tt1m < 0) then r = log ((d%t - d%m2) / tt0m) / log (tt1m / tt0m) else r = 0 end if end if end subroutine splitting_inverse_t @ %def splitting_inverse_t @ This is trivial, but provided for convenience: <>= procedure :: sample_phi => splitting_sample_phi <>= subroutine splitting_sample_phi (d, r) class(splitting_data_t), intent(inout) :: d real(default), intent(in) :: r if (d%collinear) then d%phi = 0 else d%phi = (1-r) * d%phi0 + r * d%phi1 end if end subroutine splitting_sample_phi @ %def splitting_sample_phi @ Inverse: <>= procedure :: inverse_phi => splitting_inverse_phi <>= subroutine splitting_inverse_phi (d, r) class(splitting_data_t), intent(in) :: d real(default), intent(out) :: r if (d%collinear) then r = 0 else r = (d%phi - d%phi0) / (d%phi1 - d%phi0) end if end subroutine splitting_inverse_phi @ %def splitting_inverse_phi @ \subsection{Splitting} In this function, we actually perform the splitting. The incoming momentum $k$ is split into (if no recoil) $q_1=(1-x)k$ and $q_2=xk$. Apart from the splitting data, we need the incoming momentum $k$, the momentum transfer $t$, and the azimuthal angle $\phi$. The momentum fraction $x$ is already known here. Alternatively, we can split without recoil. The azimuthal angle is irrelevant, and the momentum transfer is always equal to the upper limit $t_1$, so the polar angle is zero. Obviously, if there are nonzero masses it is not possible to keep both energy-momentum conservation and at the same time all particles on shell. We choose for dropping the on-shell condition here. <>= procedure :: split_momentum => splitting_split_momentum <>= function splitting_split_momentum (d, k) result (q) class(splitting_data_t), intent(in) :: d type(vector4_t), dimension(2) :: q type(vector4_t), intent(in) :: k real(default) :: st2, ct2, st, ct, cp, sp type(lorentz_transformation_t) :: rot real(default) :: tt0, tt1, den type(vector3_t) :: kk, q1, q2 if (d%collinear) then if (vanishes (d%s) .and. vanishes(d%u)) then q(1) = d%xb * k q(2) = d%x * k else kk = space_part (k) q1 = d%xb * (d%pb / d%p) * kk q2 = kk - q1 q(1) = vector4_moving (d%xb * d%E, q1) q(2) = vector4_moving (d%x * d%E, q2) end if else den = 2 * d%xb * d%p * d%pb tt0 = max (d%t - d%t0, 0._default) tt1 = min (d%t - d%t1, 0._default) if (den**2 <= epsilon(den)) then st2 = 0 else st2 = - (tt0 * tt1) / den ** 2 end if if (st2 > 1) then st2 = 1 end if ct2 = 1 - st2 st = sqrt (max (st2, 0._default)) ct = sqrt (max (ct2, 0._default)) if ((d%t - d%t0 + d%t - d%t1) < 0) then ct = - ct end if sp = sin (d%phi) cp = cos (d%phi) rot = rotation_to_2nd (3, space_part (k)) q1 = vector3_moving (d%xb * d%pb * [st * cp, st * sp, ct]) q2 = vector3_moving (d%p, 3) - q1 q(1) = rot * vector4_moving (d%xb * d%E, q1) q(2) = rot * vector4_moving (d%x * d%E, q2) end if end function splitting_split_momentum @ %def splitting_split_momentum @ Momenta generated by splitting will in general be off-shell. They are on-shell only if they are collinear and massless. This subroutine puts them on shell by brute force, violating either momentum or energy conservation. The direction of three-momentum is always retained. If the energy is below mass shell, we return a zero momentum. <>= integer, parameter, public :: KEEP_ENERGY = 0, KEEP_MOMENTUM = 1 @ %def KEEP_ENERGY KEEP_MOMENTUM <>= public :: on_shell <>= elemental subroutine on_shell (p, m2, keep) type(vector4_t), intent(inout) :: p real(default), intent(in) :: m2 integer, intent(in) :: keep real(default) :: E, E2, pn select case (keep) case (KEEP_ENERGY) E = energy (p) E2 = E ** 2 if (E2 >= m2) then pn = sqrt (E2 - m2) p = vector4_moving (E, pn * direction (space_part (p))) else p = vector4_null end if case (KEEP_MOMENTUM) E = sqrt (space_part (p) ** 2 + m2) p = vector4_moving (E, space_part (p)) end select end subroutine on_shell @ %def on_shell @ \subsection{Recovering the splitting} This is the inverse problem. We have on-shell momenta and want to deduce the splitting parameters $x$, $t$, and $\phi$. Update 2018-08-22: As a true inverse to [[splitting_split_momentum]], we now use not just a single momentum [[q2]] as before, but the momentum pair [[q1]], [[q2]] for recovering $x$ and $\bar x$ separately. If $x$ happens to be close to $1$, we would completely lose the tiny $\bar x$ value, otherwise, and thus get a meaningless result. <>= procedure :: recover => splitting_recover <>= subroutine splitting_recover (d, k, q, keep) class(splitting_data_t), intent(inout) :: d type(vector4_t), intent(in) :: k type(vector4_t), dimension(2), intent(in) :: q integer, intent(in) :: keep type(lorentz_transformation_t) :: rot type(vector4_t) :: k0 type(vector4_t), dimension(2) :: q0 real(default) :: p1, p2, p3, pt2, pp2, pl real(default) :: aux, den, norm real(default) :: st2, ct2, ct rot = inverse (rotation_to_2nd (3, space_part (k))) q0 = rot * q p1 = vector4_get_component (q0(2), 1) p2 = vector4_get_component (q0(2), 2) p3 = vector4_get_component (q0(2), 3) pt2 = p1 ** 2 + p2 ** 2 pp2 = p1 ** 2 + p2 ** 2 + p3 ** 2 pl = abs (p3) k0 = vector4_moving (d%E, d%p, 3) select case (keep) case (KEEP_ENERGY) d%x = energy (q0(2)) / d%E d%xb = energy (q0(1)) / d%E call d%set_t_bounds () if (.not. d%collinear) then aux = (d%xb * d%pb) ** 2 * pp2 - d%p ** 2 * pt2 den = d%p ** 2 - (d%xb * d%pb) ** 2 if (aux >= 0 .and. den > 0) then norm = (d%p * pl + sqrt (aux)) / den else norm = 1 end if end if case (KEEP_MOMENTUM) d%xb = sqrt (space_part (q0(1)) ** 2 + d%u) / d%E d%x = 1 - d%xb call d%set_t_bounds () norm = 1 end select if (d%collinear) then d%t = d%t1 d%phi = 0 else if ((d%xb * d%pb * norm)**2 < epsilon(d%xb)) then st2 = 1 else st2 = pt2 / (d%xb * d%pb * norm ) ** 2 end if if (st2 > 1) then st2 = 1 end if ct2 = 1 - st2 ct = sqrt (max (ct2, 0._default)) if (.not. vanishes (1 + ct)) then d%t = d%t1 - 2 * d%xb * d%p * d%pb * st2 / (1 + ct) else d%t = d%t0 end if if (.not. vanishes (p1) .or. .not. vanishes (p2)) then d%phi = atan2 (-p2, -p1) else d%phi = 0 end if end if end subroutine splitting_recover @ %def splitting_recover @ \subsection{Extract data} <>= procedure :: get_x => splitting_get_x procedure :: get_xb => splitting_get_xb <>= function splitting_get_x (sd) result (x) class(splitting_data_t), intent(in) :: sd real(default) :: x x = sd%x end function splitting_get_x function splitting_get_xb (sd) result (xb) class(splitting_data_t), intent(in) :: sd real(default) :: xb xb = sd%xb end function splitting_get_xb @ %def splitting_get_x @ %def splitting_get_xb @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_aux_ut.f90]]>>= <> module sf_aux_ut use unit_tests use sf_aux_uti <> <> contains <> end module sf_aux_ut @ %def sf_aux_ut @ <<[[sf_aux_uti.f90]]>>= <> module sf_aux_uti <> use numeric_utils, only: pacify use lorentz use sf_aux <> <> contains <> end module sf_aux_uti @ %def sf_aux_ut @ API: driver for the unit tests below. <>= public :: sf_aux_test <>= subroutine sf_aux_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_aux_test @ %def sf_aux_test @ \subsubsection{Momentum splitting: massless radiation} Compute momentum splitting for generic kinematics. It turns out that for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and lower bounds (this can be directly seen from the logarithmic distribution in the function [[sample_t]] for $r \equiv x = 1 - x = 0.5$), we arrive at an exact number $t=-0.15$ for the given input values. <>= call test (sf_aux_1, "sf_aux_1", & "massless radiation", & u, results) <>= public :: sf_aux_1 <>= subroutine sf_aux_1 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q, q0 real(default) :: E, mk, mp, mq real(default) :: x, r1, r2, r1o, r2o real(default) :: k2, q0_2, q1_2, q2_2 write (u, "(A)") "* Test output: sf_aux_1" write (u, "(A)") "* Purpose: compute momentum splitting" write (u, "(A)") " (massless radiated particle)" write (u, "(A)") E = 1 mk = 0.3_default mp = 0 mq = mk k = vector4_moving (E, sqrt (E**2 - mk**2), 3) k2 = k ** 2; call pacify (k2, 1e-10_default) x = 0.6_default r1 = 0.5_default r2 = 0.125_default write (u, "(A)") "* (1) Non-collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%sample_t (r1) call sd%sample_phi (r2) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "Extract: x, 1-x" write (u, "(2(1x,F11.8))") sd%get_x (), sd%get_xb () write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, 1 - x) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_1" end subroutine sf_aux_1 @ %def sf_aux_1 @ \subsubsection{Momentum splitting: massless parton} Compute momentum splitting for generic kinematics. It turns out that for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and lower bounds, we arrive at an exact number $t=-0.36$ for the given input values. <>= call test (sf_aux_2, "sf_aux_2", & "massless parton", & u, results) <>= public :: sf_aux_2 <>= subroutine sf_aux_2 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q, q0 real(default) :: E, mk, mp, mq real(default) :: x, r1, r2, r1o, r2o real(default) :: k2, q02_2, q1_2, q2_2 write (u, "(A)") "* Test output: sf_aux_2" write (u, "(A)") "* Purpose: compute momentum splitting" write (u, "(A)") " (massless outgoing particle)" write (u, "(A)") E = 1 mk = 0.3_default mp = mk mq = 0 k = vector4_moving (E, sqrt (E**2 - mk**2), 3) k2 = k ** 2; call pacify (k2, 1e-10_default) x = 0.6_default r1 = 0.5_default r2 = 0.125_default write (u, "(A)") "* (1) Non-collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%sample_t (r1) call sd%sample_phi (r2) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, 1 - x) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_2" end subroutine sf_aux_2 @ %def sf_aux_2 @ \subsubsection{Momentum splitting: all massless} Compute momentum splitting for massless kinematics. In the non-collinear case, we need a lower cutoff for $|t|$, otherwise a logarithmic distribution is not possible. <>= call test (sf_aux_3, "sf_aux_3", & "massless parton", & u, results) <>= public :: sf_aux_3 <>= subroutine sf_aux_3 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q, q0 real(default) :: E, mk, mp, mq, qmin, qmax real(default) :: x, r1, r2, r1o, r2o real(default) :: k2, q02_2, q1_2, q2_2 write (u, "(A)") "* Test output: sf_aux_3" write (u, "(A)") "* Purpose: compute momentum splitting" write (u, "(A)") " (all massless, q cuts)" write (u, "(A)") E = 1 mk = 0 mp = 0 mq = 0 qmin = 1e-2_default qmax = 1e0_default k = vector4_moving (E, sqrt (E**2 - mk**2), 3) k2 = k ** 2; call pacify (k2, 1e-10_default) x = 0.6_default r1 = 0.5_default r2 = 0.125_default write (u, "(A)") "* (1) Non-collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%sample_t (r1, t1 = - qmin ** 2, t0 = - qmax **2) call sd%sample_phi (r2) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o, t1 = - qmin ** 2, t0 = - qmax **2) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o, t1 = - qmin ** 2, t0 = - qmax **2) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, 1 - x) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_3" end subroutine sf_aux_3 @ %def sf_aux_3 @ \subsubsection{Endpoint stability} Compute momentum splitting for collinear kinematics close to both endpoints. In particular, check both directions $x\to$ momenta and momenta $\to x$. For purely massless collinear splitting, the [[KEEP_XXX]] flag is irrelevant. We choose [[KEEP_ENERGY]] here. <>= call test (sf_aux_4, "sf_aux_4", & "endpoint numerics", & u, results) <>= public :: sf_aux_4 <>= subroutine sf_aux_4 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E, mk, mp, mq, qmin, qmax real(default) :: x, xb write (u, "(A)") "* Test output: sf_aux_4" write (u, "(A)") "* Purpose: compute massless collinear splitting near endpoint" E = 1 mk = 0 mp = 0 mq = 0 qmin = 1e-2_default qmax = 1e0_default k = vector4_moving (E, sqrt (E**2 - mk**2), 3) x = 0.1_default xb = 1 - x write (u, "(A)") write (u, "(A)") "* (1) Collinear setup, moderate kinematics" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%write (u) q = sd%split_momentum (k) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momenta" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%recover (k, q, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") xb, sd%xb write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Close to x=0" write (u, "(A)") x = 1e-9_default xb = 1 - x call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%write (u) q = sd%split_momentum (k) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momenta" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%recover (k, q, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") xb, sd%xb write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (3) Close to x=1" write (u, "(A)") xb = 1e-9_default x = 1 - xb call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%write (u) q = sd%split_momentum (k) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momenta" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%recover (k, q, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") xb, sd%xb write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_4" end subroutine sf_aux_4 @ %def sf_aux_4 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Mappings for structure functions} In this module, we provide a wrapper for useful mappings of the unit (hyper-)square that we can apply to a set of structure functions. In some cases it is useful, or even mandatory, to map the MC input parameters nontrivially onto a set of structure functions for the two beams. In all cases considered here, instead of $x_1,x_2,\ldots$ as parameters for the beams, we generate one parameter that is equal, or related to, the product $x_1x_2\cdots$ (so it directly corresponds to $\sqrt{s}$). The other parameters describe the distribution of energy (loss) between beams and radiations. <<[[sf_mappings.f90]]>>= <> module sf_mappings <> use kinds, only: double use io_units use constants, only: pi, zero, one use numeric_utils use diagnostics <> <> <> <> <> contains <> end module sf_mappings @ %def sf_mappings @ \subsection{Base type} First, we define an abstract base type for the mapping. In all cases we need to store the indices of the parameters on which the mapping applies. Additional parameters can be stored in the extensions of this type. <>= public :: sf_mapping_t <>= type, abstract :: sf_mapping_t integer, dimension(:), allocatable :: i contains <> end type sf_mapping_t @ %def sf_mapping_t @ The output routine is deferred: <>= procedure (sf_mapping_write), deferred :: write <>= abstract interface subroutine sf_mapping_write (object, unit) import class(sf_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_mapping_write end interface @ %def sf_mapping_write @ Initializer for the base type. The array of parameter indices is allocated but initialized to zero. <>= procedure :: base_init => sf_mapping_base_init <>= subroutine sf_mapping_base_init (mapping, n_par) class(sf_mapping_t), intent(out) :: mapping integer, intent(in) :: n_par allocate (mapping%i (n_par)) mapping%i = 0 end subroutine sf_mapping_base_init @ %def sf_mapping_base_init @ Set an index value. <>= procedure :: set_index => sf_mapping_set_index <>= subroutine sf_mapping_set_index (mapping, j, i) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i end subroutine sf_mapping_set_index @ %def sf_mapping_set_index @ Retrieve an index value. <>= procedure :: get_index => sf_mapping_get_index <>= function sf_mapping_get_index (mapping, j) result (i) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: j integer :: i i = mapping%i(j) end function sf_mapping_get_index @ %def sf_mapping_get_index @ Return the dimensionality, i.e., the number of parameters. <>= procedure :: get_n_dim => sf_mapping_get_n_dim <>= function sf_mapping_get_n_dim (mapping) result (n) class(sf_mapping_t), intent(in) :: mapping integer :: n n = size (mapping%i) end function sf_mapping_get_n_dim @ %def sf_mapping_get_n_dim @ Computation: the values [[p]] are the input parameters, the values [[r]] are the output parameters. The values [[rb]] are defined as $\bar r = 1 - r$, but provided explicitly. They allow us to avoid numerical problems near $r=1$. The extra parameter [[x_free]] indicates that the total energy has already been renormalized by this factor. We have to take such a factor into account in a resonance or on-shell mapping. The Jacobian is [[f]]. We modify only the two parameters indicated by the indices [[i]]. <>= procedure (sf_mapping_compute), deferred :: compute <>= abstract interface subroutine sf_mapping_compute (mapping, r, rb, f, p, pb, x_free) import class(sf_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_mapping_compute end interface @ %def sf_mapping_compute @ The inverse mapping. Use [[r]] and/or [[rb]] to reconstruct [[p]] and also compute [[f]]. <>= procedure (sf_mapping_inverse), deferred :: inverse <>= abstract interface subroutine sf_mapping_inverse (mapping, r, rb, f, p, pb, x_free) import class(sf_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_mapping_inverse end interface @ %def sf_mapping_inverse @ \subsection{Methods for self-tests} This is a shorthand for: inject parameters, compute the mapping, display results, compute the inverse, display again. We provide an output format for the parameters and, optionally, a different output format for the Jacobians. <>= procedure :: check => sf_mapping_check <>= subroutine sf_mapping_check (mapping, u, p_in, pb_in, fmt_p, fmt_f) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: u real(default), dimension(:), intent(in) :: p_in, pb_in character(*), intent(in) :: fmt_p character(*), intent(in), optional :: fmt_f real(default), dimension(size(p_in)) :: p, pb, r, rb real(default) :: f, tolerance tolerance = 1.5E-17 p = p_in pb= pb_in call mapping%compute (r, rb, f, p, pb) call pacify (p, tolerance) call pacify (pb, tolerance) call pacify (r, tolerance) call pacify (rb, tolerance) write (u, "(3x,A,9(1x," // fmt_p // "))") "p =", p write (u, "(3x,A,9(1x," // fmt_p // "))") "pb=", pb write (u, "(3x,A,9(1x," // fmt_p // "))") "r =", r write (u, "(3x,A,9(1x," // fmt_p // "))") "rb=", rb if (present (fmt_f)) then write (u, "(3x,A,9(1x," // fmt_f // "))") "f =", f else write (u, "(3x,A,9(1x," // fmt_p // "))") "f =", f end if write (u, *) call mapping%inverse (r, rb, f, p, pb) call pacify (p, tolerance) call pacify (pb, tolerance) call pacify (r, tolerance) call pacify (rb, tolerance) write (u, "(3x,A,9(1x," // fmt_p // "))") "p =", p write (u, "(3x,A,9(1x," // fmt_p // "))") "pb=", pb write (u, "(3x,A,9(1x," // fmt_p // "))") "r =", r write (u, "(3x,A,9(1x," // fmt_p // "))") "rb=", rb if (present (fmt_f)) then write (u, "(3x,A,9(1x," // fmt_f // "))") "f =", f else write (u, "(3x,A,9(1x," // fmt_p // "))") "f =", f end if write (u, *) write (u, "(3x,A,9(1x," // fmt_p // "))") "*r=", product (r) end subroutine sf_mapping_check @ %def sf_mapping_check @ This is a consistency check for the self-tests: the integral over the unit square should be unity. We estimate this by a simple binning and adding up the values; this should be sufficient for a self-test. The argument is the requested number of sampling points. We take the square root for binning in both dimensions, so the precise number might be different. <>= procedure :: integral => sf_mapping_integral <>= function sf_mapping_integral (mapping, n_calls) result (integral) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: n_calls real(default) :: integral integer :: n_dim, n_bin, k real(default), dimension(:), allocatable :: p, pb, r, rb integer, dimension(:), allocatable :: ii real(default) :: dx, f, s n_dim = mapping%get_n_dim () allocate (p (n_dim)) allocate (pb(n_dim)) allocate (r (n_dim)) allocate (rb(n_dim)) allocate (ii(n_dim)) n_bin = nint (real (n_calls, default) ** (1._default / n_dim)) dx = 1._default / n_bin s = 0 ii = 1 SAMPLE: do do k = 1, n_dim p(k) = ii(k) * dx - dx/2 pb(k) = (n_bin - ii(k)) * dx + dx/2 end do call mapping%compute (r, rb, f, p, pb) s = s + f INCR: do k = 1, n_dim ii(k) = ii(k) + 1 if (ii(k) <= n_bin) then exit INCR else if (k < n_dim) then ii(k) = 1 else exit SAMPLE end if end do INCR end do SAMPLE integral = s / real (n_bin, default) ** n_dim end function sf_mapping_integral @ %def sf_mapping_integral @ \subsection{Implementation: standard mapping} This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. <>= public :: sf_s_mapping_t <>= type, extends (sf_mapping_t) :: sf_s_mapping_t logical :: power_set = .false. real(default) :: power = 1 contains <> end type sf_s_mapping_t @ %def sf_s_mapping_t @ Output. <>= procedure :: write => sf_s_mapping_write <>= subroutine sf_s_mapping_write (object, unit) class(sf_s_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A)") ": standard (", object%power, ")" end subroutine sf_s_mapping_write @ %def sf_s_mapping_write @ Initialize: index pair and power parameter. <>= procedure :: init => sf_s_mapping_init <>= subroutine sf_s_mapping_init (mapping, power) class(sf_s_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: power call mapping%base_init (2) if (present (power)) then mapping%power_set = .true. mapping%power = power end if end subroutine sf_s_mapping_init @ %def sf_s_mapping_init @ Apply mapping. <>= procedure :: compute => sf_s_mapping_compute <>= subroutine sf_s_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_s_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2 integer :: j if (mapping%power_set) then call map_unit_square (r2, f, p(mapping%i), mapping%power) else call map_unit_square (r2, f, p(mapping%i)) end if r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_s_mapping_compute @ %def sf_s_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_s_mapping_inverse <>= subroutine sf_s_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_s_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: p2 integer :: j if (mapping%power_set) then call map_unit_square_inverse (r(mapping%i), f, p2, mapping%power) else call map_unit_square_inverse (r(mapping%i), f, p2) end if p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_s_mapping_inverse @ %def sf_s_mapping_inverse @ \subsection{Implementation: resonance pair mapping} This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio, then it maps $p_1$ to itself according to a Breit-Wigner shape, i.e., a flat prior distribution in $p_1$ results in a Breit-Wigner distribution. Mass and width of the BW are rescaled by the energy, thus dimensionless fractions. <>= public :: sf_res_mapping_t <>= type, extends (sf_mapping_t) :: sf_res_mapping_t real(default) :: m = 0 real(default) :: w = 0 contains <> end type sf_res_mapping_t @ %def sf_res_mapping_t @ Output. <>= procedure :: write => sf_res_mapping_write <>= subroutine sf_res_mapping_write (object, unit) class(sf_res_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,', ',F7.5,A)") ": resonance (", object%m, object%w, ")" end subroutine sf_res_mapping_write @ %def sf_res_mapping_write @ Initialize: index pair and dimensionless mass and width parameters. <>= procedure :: init => sf_res_mapping_init <>= subroutine sf_res_mapping_init (mapping, m, w) class(sf_res_mapping_t), intent(out) :: mapping real(default), intent(in) :: m, w call mapping%base_init (2) mapping%m = m mapping%w = w end subroutine sf_res_mapping_init @ %def sf_res_mapping_init @ Apply mapping. <>= procedure :: compute => sf_res_mapping_compute <>= subroutine sf_res_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, p2 real(default) :: fbw, f2, p1m integer :: j p2 = p(mapping%i) call map_breit_wigner & (p1m, fbw, p2(1), mapping%m, mapping%w, x_free) call map_unit_square (r2, f2, [p1m, p2(2)]) f = fbw * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_res_mapping_compute @ %def sf_res_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_res_mapping_inverse <>= subroutine sf_res_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: p2 real(default) :: fbw, f2, p1m call map_unit_square_inverse (r(mapping%i), f2, p2) call map_breit_wigner_inverse & (p2(1), fbw, p1m, mapping%m, mapping%w, x_free) p = r pb= rb p (mapping%i(1)) = p1m pb(mapping%i(1)) = 1 - p1m p (mapping%i(2)) = p2(2) pb(mapping%i(2)) = 1 - p2(2) f = fbw * f2 end subroutine sf_res_mapping_inverse @ %def sf_res_mapping_inverse @ \subsection{Implementation: resonance single mapping} While simpler, this is needed for structure-function setups only in exceptional cases. This maps the unit interval ($r_1$) to itself according to a Breit-Wigner shape, i.e., a flat prior distribution in $r_1$ results in a Breit-Wigner distribution. Mass and width of the BW are rescaled by the energy, thus dimensionless fractions. <>= public :: sf_res_mapping_single_t <>= type, extends (sf_mapping_t) :: sf_res_mapping_single_t real(default) :: m = 0 real(default) :: w = 0 contains <> end type sf_res_mapping_single_t @ %def sf_res_mapping_single_t @ Output. <>= procedure :: write => sf_res_mapping_single_write <>= subroutine sf_res_mapping_single_write (object, unit) class(sf_res_mapping_single_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,', ',F7.5,A)") ": resonance (", object%m, object%w, ")" end subroutine sf_res_mapping_single_write @ %def sf_res_mapping_single_write @ Initialize: single index (!) and dimensionless mass and width parameters. <>= procedure :: init => sf_res_mapping_single_init <>= subroutine sf_res_mapping_single_init (mapping, m, w) class(sf_res_mapping_single_t), intent(out) :: mapping real(default), intent(in) :: m, w call mapping%base_init (1) mapping%m = m mapping%w = w end subroutine sf_res_mapping_single_init @ %def sf_res_mapping_single_init @ Apply mapping. <>= procedure :: compute => sf_res_mapping_single_compute <>= subroutine sf_res_mapping_single_compute (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: r2, p2 real(default) :: fbw integer :: j p2 = p(mapping%i) call map_breit_wigner & (r2(1), fbw, p2(1), mapping%m, mapping%w, x_free) f = fbw r = p rb= pb r (mapping%i(1)) = r2(1) rb(mapping%i(1)) = 1 - r2(1) end subroutine sf_res_mapping_single_compute @ %def sf_res_mapping_single_compute @ Apply inverse. <>= procedure :: inverse => sf_res_mapping_single_inverse <>= subroutine sf_res_mapping_single_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: p2 real(default) :: fbw call map_breit_wigner_inverse & (r(mapping%i(1)), fbw, p2(1), mapping%m, mapping%w, x_free) p = r pb= rb p (mapping%i(1)) = p2(1) pb(mapping%i(1)) = 1 - p2(1) f = fbw end subroutine sf_res_mapping_single_inverse @ %def sf_res_mapping_single_inverse @ \subsection{Implementation: on-shell mapping} This is a degenerate version of the unit-square mapping where the product $r_1r_2$ is constant. This product is given by the rescaled squared mass. We introduce an artificial first parameter $p_1$ to keep the counting, but nothing depends on it. The second parameter is the same $p_2$ as for the standard unit-square mapping for $\alpha=1$, it parameterizes the ratio of $r_1$ and $r_2$. <>= public :: sf_os_mapping_t <>= type, extends (sf_mapping_t) :: sf_os_mapping_t real(default) :: m = 0 real(default) :: lm2 = 0 contains <> end type sf_os_mapping_t @ %def sf_os_mapping_t @ Output. <>= procedure :: write => sf_os_mapping_write <>= subroutine sf_os_mapping_write (object, unit) class(sf_os_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A)") ": on-shell (", object%m, ")" end subroutine sf_os_mapping_write @ %def sf_os_mapping_write @ Initialize: index pair and dimensionless mass parameter. <>= procedure :: init => sf_os_mapping_init <>= subroutine sf_os_mapping_init (mapping, m) class(sf_os_mapping_t), intent(out) :: mapping real(default), intent(in) :: m call mapping%base_init (2) mapping%m = m mapping%lm2 = abs (2 * log (mapping%m)) end subroutine sf_os_mapping_init @ %def sf_os_mapping_init @ Apply mapping. The [[x_free]] parameter rescales the total energy, which must be accounted for in the enclosed mapping. <>= procedure :: compute => sf_os_mapping_compute <>= subroutine sf_os_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, p2 integer :: j p2 = p(mapping%i) call map_on_shell (r2, f, p2, mapping%lm2, x_free) r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_os_mapping_compute @ %def sf_os_mapping_compute @ Apply inverse. The irrelevant parameter $p_1$ is always set zero. <>= procedure :: inverse => sf_os_mapping_inverse <>= subroutine sf_os_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: p2, r2 r2 = r(mapping%i) call map_on_shell_inverse (r2, f, p2, mapping%lm2, x_free) p = r pb= rb p (mapping%i(1)) = p2(1) pb(mapping%i(1)) = 1 - p2(1) p (mapping%i(2)) = p2(2) pb(mapping%i(2)) = 1 - p2(2) end subroutine sf_os_mapping_inverse @ %def sf_os_mapping_inverse @ \subsection{Implementation: on-shell single mapping} This is a degenerate version of the unit-interval mapping where the result $r$ is constant. The value is given by the rescaled squared mass. The input parameter $p_1$ is actually ignored, nothing depends on it. <>= public :: sf_os_mapping_single_t <>= type, extends (sf_mapping_t) :: sf_os_mapping_single_t real(default) :: m = 0 real(default) :: lm2 = 0 contains <> end type sf_os_mapping_single_t @ %def sf_os_mapping_single_t @ Output. <>= procedure :: write => sf_os_mapping_single_write <>= subroutine sf_os_mapping_single_write (object, unit) class(sf_os_mapping_single_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A)") ": on-shell (", object%m, ")" end subroutine sf_os_mapping_single_write @ %def sf_os_mapping_single_write @ Initialize: index pair and dimensionless mass parameter. <>= procedure :: init => sf_os_mapping_single_init <>= subroutine sf_os_mapping_single_init (mapping, m) class(sf_os_mapping_single_t), intent(out) :: mapping real(default), intent(in) :: m call mapping%base_init (1) mapping%m = m mapping%lm2 = abs (2 * log (mapping%m)) end subroutine sf_os_mapping_single_init @ %def sf_os_mapping_single_init @ Apply mapping. The [[x_free]] parameter rescales the total energy, which must be accounted for in the enclosed mapping. <>= procedure :: compute => sf_os_mapping_single_compute <>= subroutine sf_os_mapping_single_compute (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: r2, p2 integer :: j p2 = p(mapping%i) call map_on_shell_single (r2, f, p2, mapping%lm2, x_free) r = p rb= pb r (mapping%i(1)) = r2(1) rb(mapping%i(1)) = 1 - r2(1) end subroutine sf_os_mapping_single_compute @ %def sf_os_mapping_single_compute @ Apply inverse. The irrelevant parameter $p_1$ is always set zero. <>= procedure :: inverse => sf_os_mapping_single_inverse <>= subroutine sf_os_mapping_single_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: p2, r2 r2 = r(mapping%i) call map_on_shell_single_inverse (r2, f, p2, mapping%lm2, x_free) p = r pb= rb p (mapping%i(1)) = p2(1) pb(mapping%i(1)) = 1 - p2(1) end subroutine sf_os_mapping_single_inverse @ %def sf_os_mapping_single_inverse @ \subsection{Implementation: endpoint mapping} This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that any power-like singularity is caught. This is useful for beamstrahlung spectra. In addition, we allow for a delta-function singularity in $r_1$ and/or $r_2$. The singularity is smeared to an interval of width $\epsilon$. If nonzero, we distinguish the kinematical momentum fractions $r_i$ from effective values $x_i$, which should go into the structure-function evaluation. A bin of width $\epsilon$ in $r$ is mapped to $x=1$ exactly, while the interval $(0,1-\epsilon)$ is mapped to $(0,1)$ in $x$. The Jacobian reflects this distinction, and the logical [[in_peak]] allows for an unambiguous distinction. The delta-peak fraction is used only for the integration self-test. <>= public :: sf_ep_mapping_t <>= type, extends (sf_mapping_t) :: sf_ep_mapping_t real(default) :: a = 1 contains <> end type sf_ep_mapping_t @ %def sf_ep_mapping_t @ Output. <>= procedure :: write => sf_ep_mapping_write <>= subroutine sf_ep_mapping_write (object, unit) class(sf_ep_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,ES12.5,A)") ": endpoint (a =", object%a, ")" end subroutine sf_ep_mapping_write @ %def sf_ep_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ep_mapping_init <>= subroutine sf_ep_mapping_init (mapping, a) class(sf_ep_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a call mapping%base_init (2) if (present (a)) mapping%a = a end subroutine sf_ep_mapping_init @ %def sf_ep_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ep_mapping_compute <>= subroutine sf_ep_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ep_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, r2 real(default) :: f1, f2 integer :: j call map_endpoint_1 (px(1), f1, p(mapping%i(1)), mapping%a) call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a) call map_unit_square (r2, f, px) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_ep_mapping_compute @ %def sf_ep_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ep_mapping_inverse <>= subroutine sf_ep_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ep_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, px, p2 real(default) :: f1, f2 integer :: j do j = 1, 2 r2(j) = r(mapping%i(j)) end do call map_unit_square_inverse (r2, f, px) call map_endpoint_inverse_1 (px(1), f1, p2(1), mapping%a) call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a) f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_ep_mapping_inverse @ %def sf_ep_mapping_inverse @ \subsection{Implementation: endpoint mapping with resonance} Like the endpoint mapping for $p_2$, but replace the endpoint mapping by a Breit-Wigner mapping for $p_1$. This covers resonance production in the presence of beamstrahlung. If the flag [[resonance]] is unset, we skip the resonance mapping, so the parameter $p_1$ remains equal to $r_1r_2$, as in the standard s-channel mapping. <>= public :: sf_epr_mapping_t <>= type, extends (sf_mapping_t) :: sf_epr_mapping_t real(default) :: a = 1 real(default) :: m = 0 real(default) :: w = 0 logical :: resonance = .true. contains <> end type sf_epr_mapping_t @ %def sf_epr_mapping_t @ Output. <>= procedure :: write => sf_epr_mapping_write <>= subroutine sf_epr_mapping_write (object, unit) class(sf_epr_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if if (object%resonance) then write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)") ": ep/res (a = ", object%a, & " | ", object%m, object%w, ")" else write (u, "(A,F7.5,A)") ": ep/nores (a = ", object%a, ")" end if end subroutine sf_epr_mapping_write @ %def sf_epr_mapping_write @ Initialize: if mass and width are not given, we initialize a non-resonant version of the mapping. <>= procedure :: init => sf_epr_mapping_init <>= subroutine sf_epr_mapping_init (mapping, a, m, w) class(sf_epr_mapping_t), intent(out) :: mapping real(default), intent(in) :: a real(default), intent(in), optional :: m, w call mapping%base_init (2) mapping%a = a if (present (m) .and. present (w)) then mapping%m = m mapping%w = w else mapping%resonance = .false. end if end subroutine sf_epr_mapping_init @ %def sf_epr_mapping_init @ Apply mapping. <>= procedure :: compute => sf_epr_mapping_compute <>= subroutine sf_epr_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_epr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, r2 real(default) :: f1, f2 integer :: j if (mapping%resonance) then call map_breit_wigner & (px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free) else px(1) = p(mapping%i(1)) f1 = 1 end if call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a) call map_unit_square (r2, f, px) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_epr_mapping_compute @ %def sf_epr_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_epr_mapping_inverse <>= subroutine sf_epr_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_epr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, p2 real(default) :: f1, f2 integer :: j call map_unit_square_inverse (r(mapping%i), f, px) if (mapping%resonance) then call map_breit_wigner_inverse & (px(1), f1, p2(1), mapping%m, mapping%w, x_free) else p2(1) = px(1) f1 = 1 end if call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a) f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_epr_mapping_inverse @ %def sf_epr_mapping_inverse @ \subsection{Implementation: endpoint mapping for on-shell particle} Analogous to the resonance mapping, but the $p_1$ input is ignored altogether. This covers on-shell particle production in the presence of beamstrahlung. <>= public :: sf_epo_mapping_t <>= type, extends (sf_mapping_t) :: sf_epo_mapping_t real(default) :: a = 1 real(default) :: m = 0 real(default) :: lm2 = 0 contains <> end type sf_epo_mapping_t @ %def sf_epo_mapping_t @ Output. <>= procedure :: write => sf_epo_mapping_write <>= subroutine sf_epo_mapping_write (object, unit) class(sf_epo_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A)") ": ep/on-shell (a = ", object%a, & " | ", object%m, ")" end subroutine sf_epo_mapping_write @ %def sf_epo_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_epo_mapping_init <>= subroutine sf_epo_mapping_init (mapping, a, m) class(sf_epo_mapping_t), intent(out) :: mapping real(default), intent(in) :: a, m call mapping%base_init (2) mapping%a = a mapping%m = m mapping%lm2 = abs (2 * log (mapping%m)) end subroutine sf_epo_mapping_init @ %def sf_epo_mapping_init @ Apply mapping. <>= procedure :: compute => sf_epo_mapping_compute <>= subroutine sf_epo_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_epo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, r2 real(default) :: f2 integer :: j px(1) = 0 call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a) call map_on_shell (r2, f, px, mapping%lm2) f = f * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_epo_mapping_compute @ %def sf_epo_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_epo_mapping_inverse <>= subroutine sf_epo_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_epo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, p2 real(default) :: f2 integer :: j call map_on_shell_inverse (r(mapping%i), f, px, mapping%lm2) p2(1) = 0 call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a) f = f * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_epo_mapping_inverse @ %def sf_epo_mapping_inverse @ \subsection{Implementation: ISR endpoint mapping} Similar to the endpoint mapping above: This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is flattened. This would be easy in one dimension, but becomes nontrivial in two dimensions. <>= public :: sf_ip_mapping_t <>= type, extends (sf_mapping_t) :: sf_ip_mapping_t real(default) :: eps = 0 contains <> end type sf_ip_mapping_t @ %def sf_ip_mapping_t @ Output. <>= procedure :: write => sf_ip_mapping_write <>= subroutine sf_ip_mapping_write (object, unit) class(sf_ip_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,ES12.5,A)") ": isr (eps =", object%eps, ")" end subroutine sf_ip_mapping_write @ %def sf_ip_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ip_mapping_init <>= subroutine sf_ip_mapping_init (mapping, eps) class(sf_ip_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps call mapping%base_init (2) if (present (eps)) mapping%eps = eps if (mapping%eps <= 0) & call msg_fatal ("ISR mapping: regulator epsilon must not be zero") end subroutine sf_ip_mapping_init @ %def sf_ip_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ip_mapping_compute <>= subroutine sf_ip_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ip_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, pxb, r2, r2b real(default) :: f1, f2, xb, y, yb integer :: j call map_power_1 (xb, f1, pb(mapping%i(1)), 2 * mapping%eps) call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps) px(1) = 1 - xb pxb(1) = xb px(2) = y pxb(2) = yb call map_unit_square_prec (r2, r2b, f, px, pxb) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2 (j) rb(mapping%i(j)) = r2b(j) end do end subroutine sf_ip_mapping_compute @ %def sf_ip_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ip_mapping_inverse <>= subroutine sf_ip_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ip_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b real(default) :: f1, f2, xb, y, yb integer :: j do j = 1, 2 r2 (j) = r (mapping%i(j)) r2b(j) = rb(mapping%i(j)) end do call map_unit_square_inverse_prec (r2, r2b, f, px, pxb) xb = pxb(1) if (px(1) > 0) then y = px(2) yb = pxb(2) else y = 0.5_default yb = 0.5_default end if call map_power_inverse_1 (xb, f1, p2b(1), 2 * mapping%eps) call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps) p2 = 1 - p2b f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = p2b(j) end do end subroutine sf_ip_mapping_inverse @ %def sf_ip_mapping_inverse @ \subsection{Implementation: ISR endpoint mapping, resonant} Similar to the endpoint mapping above: This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is flattened. This would be easy in one dimension, but becomes nontrivial in two dimensions. The resonance can be turned off by the flag [[resonance]]. <>= public :: sf_ipr_mapping_t <>= type, extends (sf_mapping_t) :: sf_ipr_mapping_t real(default) :: eps = 0 real(default) :: m = 0 real(default) :: w = 0 logical :: resonance = .true. contains <> end type sf_ipr_mapping_t @ %def sf_ipr_mapping_t @ Output. <>= procedure :: write => sf_ipr_mapping_write <>= subroutine sf_ipr_mapping_write (object, unit) class(sf_ipr_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if if (object%resonance) then write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)") ": isr/res (eps = ", & object%eps, " | ", object%m, object%w, ")" else write (u, "(A,F7.5,A)") ": isr/res (eps = ", object%eps, ")" end if end subroutine sf_ipr_mapping_write @ %def sf_ipr_mapping_write @ Initialize: <>= procedure :: init => sf_ipr_mapping_init <>= subroutine sf_ipr_mapping_init (mapping, eps, m, w) class(sf_ipr_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps, m, w call mapping%base_init (2) if (present (eps)) mapping%eps = eps if (mapping%eps <= 0) & call msg_fatal ("ISR mapping: regulator epsilon must not be zero") if (present (m) .and. present (w)) then mapping%m = m mapping%w = w else mapping%resonance = .false. end if end subroutine sf_ipr_mapping_init @ %def sf_ipr_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ipr_mapping_compute <>= subroutine sf_ipr_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ipr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, pxb, r2, r2b real(default) :: f1, f2, y, yb integer :: j if (mapping%resonance) then call map_breit_wigner & (px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free) else px(1) = p(mapping%i(1)) f1 = 1 end if call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps) pxb(1) = 1 - px(1) px(2) = y pxb(2) = yb call map_unit_square_prec (r2, r2b, f, px, pxb) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2 (j) rb(mapping%i(j)) = r2b(j) end do end subroutine sf_ipr_mapping_compute @ %def sf_ipr_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ipr_mapping_inverse <>= subroutine sf_ipr_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ipr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b real(default) :: f1, f2, y, yb integer :: j do j = 1, 2 r2 (j) = r (mapping%i(j)) r2b(j) = rb(mapping%i(j)) end do call map_unit_square_inverse_prec (r2, r2b, f, px, pxb) if (px(1) > 0) then y = px(2) yb = pxb(2) else y = 0.5_default yb = 0.5_default end if if (mapping%resonance) then call map_breit_wigner_inverse & (px(1), f1, p2(1), mapping%m, mapping%w, x_free) else p2(1) = px(1) f1 = 1 end if call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps) p2b(1) = 1 - p2(1) p2 (2) = 1 - p2b(2) f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = p2b(j) end do end subroutine sf_ipr_mapping_inverse @ %def sf_ipr_mapping_inverse @ \subsection{Implementation: ISR on-shell mapping} Similar to the endpoint mapping above: This maps the unit square ($r_1,r_2$) such that $p_1$ is ignored while the product $r_1r_2$ is constant. $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is flattened. This would be easy in one dimension, but becomes nontrivial in two dimensions. <>= public :: sf_ipo_mapping_t <>= type, extends (sf_mapping_t) :: sf_ipo_mapping_t real(default) :: eps = 0 real(default) :: m = 0 contains <> end type sf_ipo_mapping_t @ %def sf_ipo_mapping_t @ Output. <>= procedure :: write => sf_ipo_mapping_write <>= subroutine sf_ipo_mapping_write (object, unit) class(sf_ipo_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A)") ": isr/os (eps = ", object%eps, & " | ", object%m, ")" end subroutine sf_ipo_mapping_write @ %def sf_ipo_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ipo_mapping_init <>= subroutine sf_ipo_mapping_init (mapping, eps, m) class(sf_ipo_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps, m call mapping%base_init (2) if (present (eps)) mapping%eps = eps if (mapping%eps <= 0) & call msg_fatal ("ISR mapping: regulator epsilon must not be zero") mapping%m = m end subroutine sf_ipo_mapping_init @ %def sf_ipo_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ipo_mapping_compute <>= subroutine sf_ipo_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ipo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, pxb, r2, r2b real(default) :: f1, f2, y, yb integer :: j call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps) px(1) = mapping%m ** 2 if (present (x_free)) px(1) = px(1) / x_free pxb(1) = 1 - px(1) px(2) = y pxb(2) = yb call map_unit_square_prec (r2, r2b, f1, px, pxb) f = f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2 (j) rb(mapping%i(j)) = r2b(j) end do end subroutine sf_ipo_mapping_compute @ %def sf_ipo_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ipo_mapping_inverse <>= subroutine sf_ipo_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ipo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b real(default) :: f1, f2, y, yb integer :: j do j = 1, 2 r2 (j) = r (mapping%i(j)) r2b(j) = rb(mapping%i(j)) end do call map_unit_square_inverse_prec (r2, r2b, f1, px, pxb) y = px(2) yb = pxb(2) call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps) p2(1) = 0 p2b(1)= 1 p2(2) = 1 - p2b(2) f = f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = p2b(j) end do end subroutine sf_ipo_mapping_inverse @ %def sf_ipo_mapping_inverse @ \subsection{Implementation: Endpoint + ISR power mapping} This is a combination of endpoint (i.e., beamstrahlung) and ISR power mapping. The first two parameters apply to the beamstrahlung spectrum, the last two to the ISR function for the first and second beam, respectively. <>= public :: sf_ei_mapping_t <>= type, extends (sf_mapping_t) :: sf_ei_mapping_t type(sf_ep_mapping_t) :: ep type(sf_ip_mapping_t) :: ip contains <> end type sf_ei_mapping_t @ %def sf_ei_mapping_t @ Output. <>= procedure :: write => sf_ei_mapping_write <>= subroutine sf_ei_mapping_write (object, unit) class(sf_ei_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,3(',',I0),')')", advance="no") object%i end if write (u, "(A,ES12.5,A,ES12.5,A)") ": ep/isr (a =", object%ep%a, & ", eps =", object%ip%eps, ")" end subroutine sf_ei_mapping_write @ %def sf_ei_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ei_mapping_init <>= subroutine sf_ei_mapping_init (mapping, a, eps) class(sf_ei_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a, eps call mapping%base_init (4) call mapping%ep%init (a) call mapping%ip%init (eps) end subroutine sf_ei_mapping_init @ %def sf_ei_mapping_init @ Set an index value. We should communicate the appropriate indices to the enclosed sub-mappings, therefore override the method. <>= procedure :: set_index => sf_ei_mapping_set_index <>= subroutine sf_ei_mapping_set_index (mapping, j, i) class(sf_ei_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i select case (j) case (1:2); call mapping%ep%set_index (j, i) case (3:4); call mapping%ip%set_index (j-2, i) end select end subroutine sf_ei_mapping_set_index @ %def sf_mapping_set_index @ Apply mapping. Now, the beamstrahlung and ISR mappings are independent of each other. The parameter subsets that are actually used should not overlap. The Jacobians are multiplied. <>= procedure :: compute => sf_ei_mapping_compute <>= subroutine sf_ei_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ei_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: q, qb real(default) :: f1, f2 call mapping%ep%compute (q, qb, f1, p, pb, x_free) call mapping%ip%compute (r, rb, f2, q, qb, x_free) f = f1 * f2 end subroutine sf_ei_mapping_compute @ %def sf_ei_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ei_mapping_inverse <>= subroutine sf_ei_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ei_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: q, qb real(default) :: f1, f2 call mapping%ip%inverse (r, rb, f2, q, qb, x_free) call mapping%ep%inverse (q, qb, f1, p, pb, x_free) f = f1 * f2 end subroutine sf_ei_mapping_inverse @ %def sf_ei_mapping_inverse @ \subsection{Implementation: Endpoint + ISR + resonance} This is a combination of endpoint (i.e., beamstrahlung) and ISR power mapping, adapted for an s-channel resonance. The first two internal parameters apply to the beamstrahlung spectrum, the last two to the ISR function for the first and second beam, respectively. The first and third parameters are the result of an overall resonance mapping, so on the outside, the first parameter is the total momentum fraction, the third one describes the distribution between beamstrahlung and ISR. <>= public :: sf_eir_mapping_t <>= type, extends (sf_mapping_t) :: sf_eir_mapping_t type(sf_res_mapping_t) :: res type(sf_epr_mapping_t) :: ep type(sf_ipr_mapping_t) :: ip contains <> end type sf_eir_mapping_t @ %def sf_eir_mapping_t @ Output. <>= procedure :: write => sf_eir_mapping_write <>= subroutine sf_eir_mapping_write (object, unit) class(sf_eir_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,3(',',I0),')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A,F7.5,', ',F7.5,A)") & ": ep/isr/res (a =", object%ep%a, & ", eps =", object%ip%eps, " | ", object%res%m, object%res%w, ")" end subroutine sf_eir_mapping_write @ %def sf_eir_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_eir_mapping_init <>= subroutine sf_eir_mapping_init (mapping, a, eps, m, w) class(sf_eir_mapping_t), intent(out) :: mapping real(default), intent(in) :: a, eps, m, w call mapping%base_init (4) call mapping%res%init (m, w) call mapping%ep%init (a) call mapping%ip%init (eps) end subroutine sf_eir_mapping_init @ %def sf_eir_mapping_init @ Set an index value. We should communicate the appropriate indices to the enclosed sub-mappings, therefore override the method. <>= procedure :: set_index => sf_eir_mapping_set_index <>= subroutine sf_eir_mapping_set_index (mapping, j, i) class(sf_eir_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i select case (j) case (1); call mapping%res%set_index (1, i) case (3); call mapping%res%set_index (2, i) end select select case (j) case (1:2); call mapping%ep%set_index (j, i) case (3:4); call mapping%ip%set_index (j-2, i) end select end subroutine sf_eir_mapping_set_index @ %def sf_mapping_set_index @ Apply mapping. Now, the beamstrahlung and ISR mappings are independent of each other. The parameter subsets that are actually used should not overlap. The Jacobians are multiplied. <>= procedure :: compute => sf_eir_mapping_compute <>= subroutine sf_eir_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_eir_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%res%compute (px, pxb, f0, p, pb, x_free) call mapping%ep%compute (q, qb, f1, px, pxb, x_free) call mapping%ip%compute (r, rb, f2, q, qb, x_free) f = f0 * f1 * f2 end subroutine sf_eir_mapping_compute @ %def sf_eir_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_eir_mapping_inverse <>= subroutine sf_eir_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_eir_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%ip%inverse (r, rb, f2, q, qb, x_free) call mapping%ep%inverse (q, qb, f1, px, pxb, x_free) call mapping%res%inverse (px, pxb, f0, p, pb, x_free) f = f0 * f1 * f2 end subroutine sf_eir_mapping_inverse @ %def sf_eir_mapping_inverse @ \subsection{Implementation: Endpoint + ISR power mapping, on-shell} This is a combination of endpoint (i.e., beamstrahlung) and ISR power mapping. The first two parameters apply to the beamstrahlung spectrum, the last two to the ISR function for the first and second beam, respectively. On top of that, we map the first and third parameter such that the product is constant. From the outside, the first parameter is irrelevant while the third parameter describes the distribution of energy (loss) among beamstrahlung and ISR. <>= public :: sf_eio_mapping_t <>= type, extends (sf_mapping_t) :: sf_eio_mapping_t type(sf_os_mapping_t) :: os type(sf_epr_mapping_t) :: ep type(sf_ipr_mapping_t) :: ip contains <> end type sf_eio_mapping_t @ %def sf_eio_mapping_t @ Output. <>= procedure :: write => sf_eio_mapping_write <>= subroutine sf_eio_mapping_write (object, unit) class(sf_eio_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,3(',',I0),')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A,F7.5,A)") ": ep/isr/os (a =", object%ep%a, & ", eps =", object%ip%eps, " | ", object%os%m, ")" end subroutine sf_eio_mapping_write @ %def sf_eio_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_eio_mapping_init <>= subroutine sf_eio_mapping_init (mapping, a, eps, m) class(sf_eio_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a, eps, m call mapping%base_init (4) call mapping%os%init (m) call mapping%ep%init (a) call mapping%ip%init (eps) end subroutine sf_eio_mapping_init @ %def sf_eio_mapping_init @ Set an index value. We should communicate the appropriate indices to the enclosed sub-mappings, therefore override the method. <>= procedure :: set_index => sf_eio_mapping_set_index <>= subroutine sf_eio_mapping_set_index (mapping, j, i) class(sf_eio_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i select case (j) case (1); call mapping%os%set_index (1, i) case (3); call mapping%os%set_index (2, i) end select select case (j) case (1:2); call mapping%ep%set_index (j, i) case (3:4); call mapping%ip%set_index (j-2, i) end select end subroutine sf_eio_mapping_set_index @ %def sf_mapping_set_index @ Apply mapping. Now, the beamstrahlung and ISR mappings are independent of each other. The parameter subsets that are actually used should not overlap. The Jacobians are multiplied. <>= procedure :: compute => sf_eio_mapping_compute <>= subroutine sf_eio_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_eio_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%os%compute (px, pxb, f0, p, pb, x_free) call mapping%ep%compute (q, qb, f1, px, pxb, x_free) call mapping%ip%compute (r, rb, f2, q, qb, x_free) f = f0 * f1 * f2 end subroutine sf_eio_mapping_compute @ %def sf_eio_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_eio_mapping_inverse <>= subroutine sf_eio_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_eio_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%ip%inverse (r, rb, f2, q, qb, x_free) call mapping%ep%inverse (q, qb, f1, px, pxb, x_free) call mapping%os%inverse (px, pxb, f0, p, pb, x_free) f = f0 * f1 * f2 end subroutine sf_eio_mapping_inverse @ %def sf_eio_mapping_inverse @ \subsection{Basic formulas} \subsubsection{Standard mapping of the unit square} This mapping of the unit square is appropriate in particular for structure functions which are concentrated at the lower end. Instead of a rectangular grid, one set of grid lines corresponds to constant parton c.m. energy. The other set is chosen such that the jacobian is only mildly singular ($\ln x$ which is zero at $x=1$), corresponding to an initial concentration of sampling points at the maximum energy. If [[power]] is greater than one (the default), points are also concentrated at the lower end. The formula is ([[power]]=$\alpha$): \begin{align} r_1 &= (p_1 ^ {p_2})^\alpha \\ r_2 &= (p_1 ^ {1 - p_2})^\alpha\\ f &= \alpha^2 p_1 ^ {\alpha - 1} |\log p_1| \end{align} and for the default case $\alpha=1$: \begin{align} r_1 &= p_1 ^ {p_2} \\ r_2 &= p_1 ^ {1 - p_2} \\ f &= |\log p_1| \end{align} <>= subroutine map_unit_square (r, factor, p, power) real(default), dimension(2), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), intent(in), optional :: power real(default) :: xx, yy factor = 1 xx = p(1) yy = p(2) if (present(power)) then if (p(1) > 0 .and. power > 1) then xx = p(1)**power factor = factor * power * xx / p(1) end if end if if (.not. vanishes (xx)) then r(1) = xx ** yy r(2) = xx / r(1) factor = factor * abs (log (xx)) else r = 0 end if end subroutine map_unit_square @ %def map_unit_square @ This is the inverse mapping. <>= subroutine map_unit_square_inverse (r, factor, p, power) real(kind=default), dimension(2), intent(in) :: r real(kind=default), intent(out) :: factor real(kind=default), dimension(2), intent(out) :: p real(kind=default), intent(in), optional :: power real(kind=default) :: lg, xx, yy factor = 1 xx = r(1) * r(2) if (.not. vanishes (xx)) then lg = log (xx) if (.not. vanishes (lg)) then yy = log (r(1)) / lg else yy = 0 end if p(2) = yy factor = factor * abs (lg) if (present(power)) then p(1) = xx**(1._default/power) factor = factor * power * xx / p(1) else p(1) = xx end if else p = 0 end if end subroutine map_unit_square_inverse @ %def map_unit_square_inverse @ \subsubsection{Precise mapping of the unit square} A more precise version (with unit power parameter). This version should be numerically stable near $x=1$ and $y=0,1$. The formulas are again \begin{equation} r_1 = p_1^{p_2}, \qquad r_2 = p_1^{\bar p_2}, \qquad f = - \log p_1 \end{equation} but we compute both $r_i$ and $\bar r_i$ simultaneously and make direct use of both $p_i$ and $\bar p_i$ as appropriate. <>= subroutine map_unit_square_prec (r, rb, factor, p, pb) real(default), dimension(2), intent(out) :: r real(default), dimension(2), intent(out) :: rb real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), dimension(2), intent(in) :: pb if (p(1) > 0.5_default) then call compute_prec_xy_1 (r(1), rb(1), p(1), pb(1), p (2)) call compute_prec_xy_1 (r(2), rb(2), p(1), pb(1), pb(2)) factor = - log_prec (p(1), pb(1)) else if (.not. vanishes (p(1))) then call compute_prec_xy_0 (r(1), rb(1), p(1), pb(1), p (2)) call compute_prec_xy_0 (r(2), rb(2), p(1), pb(1), pb(2)) factor = - log_prec (p(1), pb(1)) else r = 0 rb = 1 factor = 0 end if end subroutine map_unit_square_prec @ %def map_unit_square_prec @ This is the inverse mapping. <>= subroutine map_unit_square_inverse_prec (r, rb, factor, p, pb) real(default), dimension(2), intent(in) :: r real(default), dimension(2), intent(in) :: rb real(default), intent(out) :: factor real(default), dimension(2), intent(out) :: p real(default), dimension(2), intent(out) :: pb call inverse_prec_x (r, rb, p(1), pb(1)) if (all (r > 0)) then if (rb(1) < rb(2)) then call inverse_prec_y (r, rb, p(2), pb(2)) else call inverse_prec_y ([r(2),r(1)], [rb(2),rb(1)], pb(2), p(2)) end if factor = - log_prec (p(1), pb(1)) else p(1) = 0 pb(1) = 1 p(2) = 0.5_default pb(2) = 0.5_default factor = 0 end if end subroutine map_unit_square_inverse_prec @ %def map_unit_square_prec_inverse @ This is an auxiliary function: evaluate the expression $\bar z = 1 - x^y$ in a numerically stable way. Instabilities occur for $y=0$ and $x=1$. The idea is to replace the bracket by the first terms of its Taylor expansion around $x=1$ (read $\bar x\equiv 1 -x$) \begin{equation} 1 - x^y = y\bar x\left(1 + \frac12(1-y)\bar x + \frac16(2-y)(1-y)\bar x^2\right) \end{equation} whenever this is the better approximation. Actually, the relative numerical error of the exact formula is about $\eta/(y\bar x)$ where $\eta$ is given by [[epsilon(KIND)]] in Fortran. The relative error of the approximation is better than the last included term divided by $(y\bar x)$. The first subroutine computes $z$ and $\bar z$ near $x=1$ where $\log x$ should be expanded, the second one near $x=0$ where $\log x$ can be kept. <>= subroutine compute_prec_xy_1 (z, zb, x, xb, y) real(default), intent(out) :: z, zb real(default), intent(in) :: x, xb, y real(default) :: a1, a2, a3 a1 = y * xb a2 = a1 * (1 - y) * xb / 2 a3 = a2 * (2 - y) * xb / 3 if (abs (a3) < epsilon (a3)) then zb = a1 + a2 + a3 z = 1 - zb else z = x ** y zb = 1 - z end if end subroutine compute_prec_xy_1 subroutine compute_prec_xy_0 (z, zb, x, xb, y) real(default), intent(out) :: z, zb real(default), intent(in) :: x, xb, y real(default) :: a1, a2, a3, lx lx = -log (x) a1 = y * lx a2 = a1 * y * lx / 2 a3 = a2 * y * lx / 3 if (abs (a3) < epsilon (a3)) then zb = a1 + a2 + a3 z = 1 - zb else z = x ** y zb = 1 - z end if end subroutine compute_prec_xy_0 @ %def compute_prec_xy_1 @ %def compute_prec_xy_0 @ For the inverse calculation, we evaluate $x=r_1r_2$ in a stable way. Since it is just a polynomial, the expansion near $x=1$ is analytically exact, and we don't need to choose based on precision. <>= subroutine inverse_prec_x (r, rb, x, xb) real(default), dimension(2), intent(in) :: r, rb real(default), intent(out) :: x, xb real(default) :: a0, a1 a0 = rb(1) + rb(2) a1 = rb(1) * rb(2) if (a0 > 0.5_default) then xb = a0 - a1 x = 1 - xb else x = r(1) * r(2) xb = 1 - x end if end subroutine inverse_prec_x @ %def inverse_prec_x @ The inverse calculation for the relative momentum fraction \begin{equation} y = \frac{1}{1 + \frac{\log{r_2}}{\log{r_1}}} \end{equation} is slightly more complicated. We should take the precise form of the logarithm, so we are safe near $r_i=1$. A series expansion is required if $r_1\ll r_2$, since then $y$ becomes small. (We assume $r_1>= subroutine inverse_prec_y (r, rb, y, yb) real(default), dimension(2), intent(in) :: r, rb real(default), intent(out) :: y, yb real(default) :: log1, log2, a1, a2, a3 log1 = log_prec (r(1), rb(1)) log2 = log_prec (r(2), rb(2)) if (abs (log2**3) < epsilon (one)) then if (abs(log1) < epsilon (one)) then y = zero else y = one / (one + log2 / log1) end if if (abs(log2) < epsilon (one)) then yb = zero else yb = one / (one + log1 / log2) end if return end if a1 = - rb(1) / log2 a2 = - rb(1) ** 2 * (one / log2**2 + one / (2 * log2)) a3 = - rb(1) ** 3 * (one / log2**3 + one / log2**2 + one/(3 * log2)) if (abs (a3) < epsilon (a3)) then y = a1 + a2 + a3 yb = one - y else y = one / (one + log2 / log1) yb = one / (one + log1 / log2) end if end subroutine inverse_prec_y @ %def inverse_prec_y @ \subsubsection{Mapping for on-shell s-channel} The limiting case, if the product $r_1r_2$ is fixed for on-shell production. The parameter $p_1$ is ignored. In the inverse mapping, it is returned zero. The parameter [[x_free]], if present, rescales the total energy. If it is less than one, the rescaled mass parameter $m^2$ should be increased accordingly. Public for access in unit test. <>= public :: map_on_shell public :: map_on_shell_inverse <>= subroutine map_on_shell (r, factor, p, lm2, x_free) real(default), dimension(2), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) r(1) = exp (- p(2) * lx) r(2) = exp (- (1 - p(2)) * lx) factor = lx end subroutine map_on_shell subroutine map_on_shell_inverse (r, factor, p, lm2, x_free) real(default), dimension(2), intent(in) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(out) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) p(1) = 0 p(2) = abs (log (r(1))) / lx factor = lx end subroutine map_on_shell_inverse @ %def map_on_shell @ %def map_on_shell_inverse @ \subsubsection{Mapping for on-shell s-channel, single parameter} This is a pseudo-mapping which applies if there is actually just one parameter [[p]]. The output parameter [[r]] is fixed for on-shell production. The lone parameter $p_1$ is ignored. In the inverse mapping, it is returned zero. The parameter [[x_free]], if present, rescales the total energy. If it is less than one, the rescaled mass parameter $m^2$ should be increased accordingly. Public for access in unit test. <>= public :: map_on_shell_single public :: map_on_shell_single_inverse <>= subroutine map_on_shell_single (r, factor, p, lm2, x_free) real(default), dimension(1), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(1), intent(in) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) r(1) = exp (- lx) factor = 1 end subroutine map_on_shell_single subroutine map_on_shell_single_inverse (r, factor, p, lm2, x_free) real(default), dimension(1), intent(in) :: r real(default), intent(out) :: factor real(default), dimension(1), intent(out) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) p(1) = 0 factor = 1 end subroutine map_on_shell_single_inverse @ %def map_on_shell_single @ %def map_on_shell_single_inverse @ \subsubsection{Mapping for a Breit-Wigner resonance} This is the standard Breit-Wigner mapping. We apply it to a single variable, independently of or in addition to a unit-square mapping. We assume here that the limits for the variable are 0 and 1, and that the mass $m$ and width $w$ are rescaled appropriately, so they are dimensionless and usually between 0 and 1. If [[x_free]] is set, it rescales the total energy and thus mass and width, since these are defined with respect to the total energy. <>= subroutine map_breit_wigner (r, factor, p, m, w, x_free) real(default), intent(out) :: r real(default), intent(out) :: factor real(default), intent(in) :: p real(default), intent(in) :: m real(default), intent(in) :: w real(default), intent(in), optional :: x_free real(default) :: m2, mw, a1, a2, a3, z, tmp m2 = m ** 2 mw = m * w if (present (x_free)) then m2 = m2 / x_free mw = mw / x_free end if a1 = atan (- m2 / mw) a2 = atan ((1 - m2) / mw) a3 = (a2 - a1) * mw z = (1-p) * a1 + p * a2 if (-pi/2 < z .and. z < pi/2) then tmp = tan (z) r = max (m2 + mw * tmp, 0._default) factor = a3 * (1 + tmp ** 2) else r = 0 factor = 0 end if end subroutine map_breit_wigner subroutine map_breit_wigner_inverse (r, factor, p, m, w, x_free) real(default), intent(in) :: r real(default), intent(out) :: factor real(default), intent(out) :: p real(default), intent(in) :: m real(default), intent(in) :: w real(default) :: m2, mw, a1, a2, a3, tmp real(default), intent(in), optional :: x_free m2 = m ** 2 mw = m * w if (present (x_free)) then m2 = m2 / x_free mw = mw / x_free end if a1 = atan (- m2 / mw) a2 = atan ((1 - m2) / mw) a3 = (a2 - a1) * mw tmp = (r - m2) / mw p = (atan (tmp) - a1) / (a2 - a1) factor = a3 * (1 + tmp ** 2) end subroutine map_breit_wigner_inverse @ %def map_breit_wigner @ %def map_breit_wigner_inverse @ \subsubsection{Mapping with endpoint enhancement} This is a mapping which is close to the unit mapping, except that at the endpoint(s), the output values are exponentially enhanced. \begin{equation} y = \tanh (a \tan (\frac{\pi}{2}x)) \end{equation} We have two variants: one covers endpoints at $0$ and $1$ symmetrically, while the other one (which essentially maps one-half of the range), covers only the endpoint at $1$. <>= subroutine map_endpoint_1 (x3, factor, x1, a) real(default), intent(out) :: x3, factor real(default), intent(in) :: x1 real(default), intent(in) :: a real(default) :: x2 if (abs (x1) < 1) then x2 = tan (x1 * pi / 2) x3 = tanh (a * x2) factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2) else x3 = x1 factor = 0 end if end subroutine map_endpoint_1 subroutine map_endpoint_inverse_1 (x3, factor, x1, a) real(default), intent(in) :: x3 real(default), intent(out) :: x1, factor real(default), intent(in) :: a real(default) :: x2 if (abs (x3) < 1) then x2 = atanh (x3) / a x1 = 2 / pi * atan (x2) factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2) else x1 = x3 factor = 0 end if end subroutine map_endpoint_inverse_1 subroutine map_endpoint_01 (x4, factor, x0, a) real(default), intent(out) :: x4, factor real(default), intent(in) :: x0 real(default), intent(in) :: a real(default) :: x1, x3 x1 = 2 * x0 - 1 call map_endpoint_1 (x3, factor, x1, a) x4 = (x3 + 1) / 2 end subroutine map_endpoint_01 subroutine map_endpoint_inverse_01 (x4, factor, x0, a) real(default), intent(in) :: x4 real(default), intent(out) :: x0, factor real(default), intent(in) :: a real(default) :: x1, x3 x3 = 2 * x4 - 1 call map_endpoint_inverse_1 (x3, factor, x1, a) x0 = (x1 + 1) / 2 end subroutine map_endpoint_inverse_01 @ %def map_endpoint_1 @ %def map_endpoint_inverse_1 @ %def map_endpoint_01 @ %def map_endpoint_inverse_01 @ \subsubsection{Mapping with endpoint enhancement (ISR)} This is another endpoint mapping. It is designed to flatten the ISR singularity which is of power type at $x=1$, i.e., if \begin{equation} \sigma = \int_0^1 dx\,f(x)\,G(x) = \int_0^1 dx\,\epsilon(1-x)^{-1+\epsilon} G(x), \end{equation} we replace this by \begin{equation} r = x^\epsilon \quad\Longrightarrow\quad \sigma = \int_0^1 dr\,G(1- (1-r)^{1/\epsilon}). \end{equation} We expect that $\epsilon$ is small. The actual mapping is $r\to x$ (so $x$ emerges closer to $1$). The Jacobian that we return is thus $1/f(x)$. We compute the mapping in terms of $\bar x\equiv 1 - x$, so we can achieve the required precision. Because some compilers show quite wild numeric fluctuations, we internally convert numeric types to explicit [[double]] precision. <>= public :: map_power_1 public :: map_power_inverse_1 <>= subroutine map_power_1 (xb, factor, rb, eps) real(default), intent(out) :: xb, factor real(default), intent(in) :: rb real(double) :: rb_db, factor_db, eps_db, xb_db real(default), intent(in) :: eps rb_db = real (rb, kind=double) eps_db = real (eps, kind=double) xb_db = rb_db ** (1 / eps_db) if (rb_db > 0) then factor_db = xb_db / rb_db / eps_db factor = real (factor_db, kind=default) else factor = 0 end if xb = real (xb_db, kind=default) end subroutine map_power_1 subroutine map_power_inverse_1 (xb, factor, rb, eps) real(default), intent(in) :: xb real(default), intent(out) :: rb, factor real(double) :: xb_db, factor_db, eps_db, rb_db real(default), intent(in) :: eps xb_db = real (xb, kind=double) eps_db = real (eps, kind=double) rb_db = xb_db ** eps_db if (xb_db > 0) then factor_db = xb_db / rb_db / eps_db factor = real (factor_db, kind=default) else factor = 0 end if rb = real (rb_db, kind=default) end subroutine map_power_inverse_1 @ %def map_power_1 @ %def map_power_inverse_1 @ Here we apply a power mapping to both endpoints. We divide the interval in two equal halves and apply the power mapping for the nearest endpoint, either $0$ or $1$. <>= subroutine map_power_01 (y, yb, factor, r, eps) real(default), intent(out) :: y, yb, factor real(default), intent(in) :: r real(default), intent(in) :: eps real(default) :: u, ub, zp, zm u = 2 * r - 1 if (u > 0) then ub = 2 * (1 - r) call map_power_1 (zm, factor, ub, eps) zp = 2 - zm else if (u < 0) then ub = 2 * r call map_power_1 (zp, factor, ub, eps) zm = 2 - zp else factor = 1 / eps zp = 1 zm = 1 end if y = zp / 2 yb = zm / 2 end subroutine map_power_01 subroutine map_power_inverse_01 (y, yb, factor, r, eps) real(default), intent(in) :: y, yb real(default), intent(out) :: r, factor real(default), intent(in) :: eps real(default) :: ub, zp, zm zp = 2 * y zm = 2 * yb if (zm < zp) then call map_power_inverse_1 (zm, factor, ub, eps) r = 1 - ub / 2 else if (zp < zm) then call map_power_inverse_1 (zp, factor, ub, eps) r = ub / 2 else factor = 1 / eps ub = 1 r = ub / 2 end if end subroutine map_power_inverse_01 @ %def map_power_01 @ %def map_power_inverse_01 @ \subsubsection{Structure-function channels} A structure-function chain parameterization (channel) may contain a mapping that applies to multiple structure functions. This is described by an extension of the [[sf_mapping_t]] type. In addition, it may contain mappings that apply to (other) individual structure functions. The details of these mappings are implementation-specific. The [[sf_channel_t]] type combines this information. It contains an array of map codes, one for each structure-function entry. The code values are: \begin{description} \item[none] MC input parameters $r$ directly become energy fractions $x$ \item[single] default mapping for a single structure-function entry \item[multi/s] map $r\to x$ such that one MC input parameter is $\hat s/s$ \item[multi/resonance] as before, adapted to s-channel resonance \item[multi/on-shell] as before, adapted to an on-shell particle in the s channel \item[multi/endpoint] like multi/s, but enhance the region near $r_i=1$ \item[multi/endpoint/res] endpoint mapping with resonance \item[multi/endpoint/os] endpoint mapping for on-shell \item[multi/power/os] like multi/endpoint, regulating a power singularity \end{description} <>= integer, parameter :: SFMAP_NONE = 0 integer, parameter :: SFMAP_SINGLE = 1 integer, parameter :: SFMAP_MULTI_S = 2 integer, parameter :: SFMAP_MULTI_RES = 3 integer, parameter :: SFMAP_MULTI_ONS = 4 integer, parameter :: SFMAP_MULTI_EP = 5 integer, parameter :: SFMAP_MULTI_EPR = 6 integer, parameter :: SFMAP_MULTI_EPO = 7 integer, parameter :: SFMAP_MULTI_IP = 8 integer, parameter :: SFMAP_MULTI_IPR = 9 integer, parameter :: SFMAP_MULTI_IPO = 10 integer, parameter :: SFMAP_MULTI_EI = 11 integer, parameter :: SFMAP_MULTI_SRS = 13 integer, parameter :: SFMAP_MULTI_SON = 14 @ %def SFMAP_NONE SFMAP_SINGLE @ %def SFMAP_MULTI_S SFMAP_MULTI_RES SFMAP_MULTI_ONS @ %def SFMAP_MULTI_EP SFMAP_MULTI_EPR SFMAP_MULTI_EPO @ %def SFMAP_MULTI_IP SFMAP_MULTI_IPR SFMAP_MULTI_IPO @ %def SFMAP_MULTI_EI @ %def SFMAP_MULTI_SRS SFMAP_MULTI_SON @ Then, it contains an allocatable entry for the multi mapping. This entry holds the MC-parameter indices on which the mapping applies (there may be more than one MC parameter per structure-function entry) and any parameters associated with the mapping. There can be only one multi-mapping per channel. <>= public :: sf_channel_t <>= type :: sf_channel_t integer, dimension(:), allocatable :: map_code class(sf_mapping_t), allocatable :: multi_mapping contains <> end type sf_channel_t @ %def sf_channel_t @ The output format prints a single character for each structure-function entry and, if applicable, an account of the mapping parameters. <>= procedure :: write => sf_channel_write <>= subroutine sf_channel_write (object, unit) class(sf_channel_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) if (allocated (object%map_code)) then do i = 1, size (object%map_code) select case (object%map_code (i)) case (SFMAP_NONE) write (u, "(1x,A)", advance="no") "-" case (SFMAP_SINGLE) write (u, "(1x,A)", advance="no") "+" case (SFMAP_MULTI_S) write (u, "(1x,A)", advance="no") "s" case (SFMAP_MULTI_RES, SFMAP_MULTI_SRS) write (u, "(1x,A)", advance="no") "r" case (SFMAP_MULTI_ONS, SFMAP_MULTI_SON) write (u, "(1x,A)", advance="no") "o" case (SFMAP_MULTI_EP) write (u, "(1x,A)", advance="no") "e" case (SFMAP_MULTI_EPR) write (u, "(1x,A)", advance="no") "p" case (SFMAP_MULTI_EPO) write (u, "(1x,A)", advance="no") "q" case (SFMAP_MULTI_IP) write (u, "(1x,A)", advance="no") "i" case (SFMAP_MULTI_IPR) write (u, "(1x,A)", advance="no") "i" case (SFMAP_MULTI_IPO) write (u, "(1x,A)", advance="no") "i" case (SFMAP_MULTI_EI) write (u, "(1x,A)", advance="no") "i" case default write (u, "(1x,A)", advance="no") "?" end select end do else write (u, "(1x,A)", advance="no") "-" end if if (allocated (object%multi_mapping)) then write (u, "(1x,'/')", advance="no") call object%multi_mapping%write (u) else write (u, *) end if end subroutine sf_channel_write @ %def sf_channel_write @ Initializer for a single [[sf_channel]] object. <>= procedure :: init => sf_channel_init <>= subroutine sf_channel_init (channel, n_strfun) class(sf_channel_t), intent(out) :: channel integer, intent(in) :: n_strfun allocate (channel%map_code (n_strfun)) channel%map_code = SFMAP_NONE end subroutine sf_channel_init @ %def sf_channel_init @ Assignment. This merely copies intrinsic assignment. <>= generic :: assignment (=) => sf_channel_assign procedure :: sf_channel_assign <>= subroutine sf_channel_assign (copy, original) class(sf_channel_t), intent(out) :: copy type(sf_channel_t), intent(in) :: original allocate (copy%map_code (size (original%map_code))) copy%map_code = original%map_code if (allocated (original%multi_mapping)) then allocate (copy%multi_mapping, source = original%multi_mapping) end if end subroutine sf_channel_assign @ %def sf_channel_assign @ This initializer allocates an array of channels with common number of structure-function entries, therefore it is not a type-bound procedure. <>= public :: allocate_sf_channels <>= subroutine allocate_sf_channels (channel, n_channel, n_strfun) type(sf_channel_t), dimension(:), intent(out), allocatable :: channel integer, intent(in) :: n_channel integer, intent(in) :: n_strfun integer :: c allocate (channel (n_channel)) do c = 1, n_channel call channel(c)%init (n_strfun) end do end subroutine allocate_sf_channels @ %def allocate_sf_channels @ This marks a given subset of indices as single-mapping. <>= procedure :: activate_mapping => sf_channel_activate_mapping <>= subroutine sf_channel_activate_mapping (channel, i_sf) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf channel%map_code(i_sf) = SFMAP_SINGLE end subroutine sf_channel_activate_mapping @ %def sf_channel_activate_mapping @ This sets an s-channel multichannel mapping. The parameter indices are not yet set. <>= procedure :: set_s_mapping => sf_channel_set_s_mapping <>= subroutine sf_channel_set_s_mapping (channel, i_sf, power) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: power channel%map_code(i_sf) = SFMAP_MULTI_S allocate (sf_s_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_s_mapping_t) call mapping%init (power) end select end subroutine sf_channel_set_s_mapping @ %def sf_channel_set_s_mapping @ This sets an s-channel resonance multichannel mapping. <>= procedure :: set_res_mapping => sf_channel_set_res_mapping <>= subroutine sf_channel_set_res_mapping (channel, i_sf, m, w, single) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: m, w logical, intent(in) :: single if (single) then channel%map_code(i_sf) = SFMAP_MULTI_SRS allocate (sf_res_mapping_single_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_res_mapping_single_t) call mapping%init (m, w) end select else channel%map_code(i_sf) = SFMAP_MULTI_RES allocate (sf_res_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_res_mapping_t) call mapping%init (m, w) end select end if end subroutine sf_channel_set_res_mapping @ %def sf_channel_set_res_mapping @ This sets an s-channel on-shell multichannel mapping. The length of the [[i_sf]] array must be 2. (The first parameter actually becomes an irrelevant dummy.) <>= procedure :: set_os_mapping => sf_channel_set_os_mapping <>= subroutine sf_channel_set_os_mapping (channel, i_sf, m, single) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: m logical, intent(in) :: single if (single) then channel%map_code(i_sf) = SFMAP_MULTI_SON allocate (sf_os_mapping_single_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_os_mapping_single_t) call mapping%init (m) end select else channel%map_code(i_sf) = SFMAP_MULTI_ONS allocate (sf_os_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_os_mapping_t) call mapping%init (m) end select end if end subroutine sf_channel_set_os_mapping @ %def sf_channel_set_os_mapping @ This sets an s-channel endpoint mapping. The parameter $a$ is the slope parameter (default 1); increasing it moves the endpoint region (at $x=1$ to lower values in the input parameter. region even more. <>= procedure :: set_ep_mapping => sf_channel_set_ep_mapping <>= subroutine sf_channel_set_ep_mapping (channel, i_sf, a) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a channel%map_code(i_sf) = SFMAP_MULTI_EP allocate (sf_ep_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ep_mapping_t) call mapping%init (a = a) end select end subroutine sf_channel_set_ep_mapping @ %def sf_channel_set_ep_mapping @ This sets a resonant endpoint mapping. <>= procedure :: set_epr_mapping => sf_channel_set_epr_mapping <>= subroutine sf_channel_set_epr_mapping (channel, i_sf, a, m, w) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: a, m, w channel%map_code(i_sf) = SFMAP_MULTI_EPR allocate (sf_epr_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_epr_mapping_t) call mapping%init (a, m, w) end select end subroutine sf_channel_set_epr_mapping @ %def sf_channel_set_epr_mapping @ This sets an on-shell endpoint mapping. <>= procedure :: set_epo_mapping => sf_channel_set_epo_mapping <>= subroutine sf_channel_set_epo_mapping (channel, i_sf, a, m) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: a, m channel%map_code(i_sf) = SFMAP_MULTI_EPO allocate (sf_epo_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_epo_mapping_t) call mapping%init (a, m) end select end subroutine sf_channel_set_epo_mapping @ %def sf_channel_set_epo_mapping @ This sets an s-channel power mapping, regulating a singularity of type $(1-x)^{-1+\epsilon}$. The parameter $\epsilon$ depends on the structure function. <>= procedure :: set_ip_mapping => sf_channel_set_ip_mapping <>= subroutine sf_channel_set_ip_mapping (channel, i_sf, eps) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: eps channel%map_code(i_sf) = SFMAP_MULTI_IP allocate (sf_ip_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ip_mapping_t) call mapping%init (eps) end select end subroutine sf_channel_set_ip_mapping @ %def sf_channel_set_ip_mapping @ This sets an s-channel resonant power mapping, regulating a singularity of type $(1-x)^{-1+\epsilon}$ in the presence of an s-channel resonance. The parameter $\epsilon$ depends on the structure function. <>= procedure :: set_ipr_mapping => sf_channel_set_ipr_mapping <>= subroutine sf_channel_set_ipr_mapping (channel, i_sf, eps, m, w) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: eps, m, w channel%map_code(i_sf) = SFMAP_MULTI_IPR allocate (sf_ipr_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ipr_mapping_t) call mapping%init (eps, m, w) end select end subroutine sf_channel_set_ipr_mapping @ %def sf_channel_set_ipr_mapping @ This sets an on-shell power mapping, regulating a singularity of type $(1-x)^{-1+\epsilon}$ for the production of a single on-shell particle.. The parameter $\epsilon$ depends on the structure function. <>= procedure :: set_ipo_mapping => sf_channel_set_ipo_mapping <>= subroutine sf_channel_set_ipo_mapping (channel, i_sf, eps, m) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: eps, m channel%map_code(i_sf) = SFMAP_MULTI_IPO allocate (sf_ipo_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ipo_mapping_t) call mapping%init (eps, m) end select end subroutine sf_channel_set_ipo_mapping @ %def sf_channel_set_ipo_mapping @ This sets a combined endpoint/ISR mapping. <>= procedure :: set_ei_mapping => sf_channel_set_ei_mapping <>= subroutine sf_channel_set_ei_mapping (channel, i_sf, a, eps) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a, eps channel%map_code(i_sf) = SFMAP_MULTI_EI allocate (sf_ei_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ei_mapping_t) call mapping%init (a, eps) end select end subroutine sf_channel_set_ei_mapping @ %def sf_channel_set_ei_mapping @ This sets a combined endpoint/ISR mapping with resonance. <>= procedure :: set_eir_mapping => sf_channel_set_eir_mapping <>= subroutine sf_channel_set_eir_mapping (channel, i_sf, a, eps, m, w) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a, eps, m, w channel%map_code(i_sf) = SFMAP_MULTI_EI allocate (sf_eir_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_eir_mapping_t) call mapping%init (a, eps, m, w) end select end subroutine sf_channel_set_eir_mapping @ %def sf_channel_set_eir_mapping @ This sets a combined endpoint/ISR mapping, on-shell. <>= procedure :: set_eio_mapping => sf_channel_set_eio_mapping <>= subroutine sf_channel_set_eio_mapping (channel, i_sf, a, eps, m) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a, eps, m channel%map_code(i_sf) = SFMAP_MULTI_EI allocate (sf_eio_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_eio_mapping_t) call mapping%init (a, eps, m) end select end subroutine sf_channel_set_eio_mapping @ %def sf_channel_set_eio_mapping @ Return true if the mapping code at position [[i_sf]] is [[SFMAP_SINGLE]]. <>= procedure :: is_single_mapping => sf_channel_is_single_mapping <>= function sf_channel_is_single_mapping (channel, i_sf) result (flag) class(sf_channel_t), intent(in) :: channel integer, intent(in) :: i_sf logical :: flag flag = channel%map_code(i_sf) == SFMAP_SINGLE end function sf_channel_is_single_mapping @ %def sf_channel_is_single_mapping @ Return true if the mapping code at position [[i_sf]] is any of the [[SFMAP_MULTI]] mappings. <>= procedure :: is_multi_mapping => sf_channel_is_multi_mapping <>= function sf_channel_is_multi_mapping (channel, i_sf) result (flag) class(sf_channel_t), intent(in) :: channel integer, intent(in) :: i_sf logical :: flag select case (channel%map_code(i_sf)) case (SFMAP_NONE, SFMAP_SINGLE) flag = .false. case default flag = .true. end select end function sf_channel_is_multi_mapping @ %def sf_channel_is_multi_mapping @ Return the number of parameters that the multi-mapping requires. The mapping object must be allocated. <>= procedure :: get_multi_mapping_n_par => sf_channel_get_multi_mapping_n_par <>= function sf_channel_get_multi_mapping_n_par (channel) result (n_par) class(sf_channel_t), intent(in) :: channel integer :: n_par if (allocated (channel%multi_mapping)) then n_par = channel%multi_mapping%get_n_dim () else n_par = 0 end if end function sf_channel_get_multi_mapping_n_par @ %def sf_channel_is_multi_mapping @ Return true if there is any nontrivial mapping in any of the channels. <>= public :: any_sf_channel_has_mapping <>= function any_sf_channel_has_mapping (channel) result (flag) type(sf_channel_t), dimension(:), intent(in) :: channel logical :: flag integer :: c flag = .false. do c = 1, size (channel) flag = flag .or. any (channel(c)%map_code /= SFMAP_NONE) end do end function any_sf_channel_has_mapping @ %def any_sf_channel_has_mapping @ Set a parameter index for an active multi mapping. We assume that the index array is allocated properly. <>= procedure :: set_par_index => sf_channel_set_par_index <>= subroutine sf_channel_set_par_index (channel, j, i_par) class(sf_channel_t), intent(inout) :: channel integer, intent(in) :: j integer, intent(in) :: i_par associate (mapping => channel%multi_mapping) if (j >= 1 .and. j <= mapping%get_n_dim ()) then if (mapping%get_index (j) == 0) then call channel%multi_mapping%set_index (j, i_par) else call msg_bug ("Structure-function setup: mapping index set twice") end if else call msg_bug ("Structure-function setup: mapping index out of range") end if end associate end subroutine sf_channel_set_par_index @ %def sf_channel_set_par_index @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_mappings_ut.f90]]>>= <> module sf_mappings_ut use unit_tests use sf_mappings_uti <> <> contains <> end module sf_mappings_ut @ %def sf_mappings_ut @ <<[[sf_mappings_uti.f90]]>>= <> module sf_mappings_uti <> use format_defs, only: FMT_11, FMT_12, FMT_13, FMT_14, FMT_15, FMT_16 use sf_mappings <> <> contains <> end module sf_mappings_uti @ %def sf_mappings_ut @ API: driver for the unit tests below. <>= public :: sf_mappings_test <>= subroutine sf_mappings_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_mappings_test @ %def sf_mappings_test @ \subsubsection{Check standard mapping} Probe the standard mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_1, "sf_mappings_1", & "standard pair mapping", & u, results) <>= public :: sf_mappings_1 <>= subroutine sf_mappings_1 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_1" write (u, "(A)") "* Purpose: probe standard mapping" write (u, "(A)") allocate (sf_s_mapping_t :: mapping) select type (mapping) type is (sf_s_mapping_t) call mapping%init () call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.1):" p = [0.1_default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) allocate (sf_s_mapping_t :: mapping) select type (mapping) type is (sf_s_mapping_t) call mapping%init (power=2._default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select write (u, *) call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.1):" p = [0.1_default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_1" end subroutine sf_mappings_1 @ %def sf_mappings_1 @ \subsubsection{Channel entries} Construct channel entries and print them. <>= call test (sf_mappings_2, "sf_mappings_2", & "structure-function mapping channels", & u, results) <>= public :: sf_mappings_2 <>= subroutine sf_mappings_2 (u) integer, intent(in) :: u type(sf_channel_t), dimension(:), allocatable :: channel integer :: c write (u, "(A)") "* Test output: sf_mappings_2" write (u, "(A)") "* Purpose: construct and display & &mapping-channel objects" write (u, "(A)") call allocate_sf_channels (channel, n_channel = 8, n_strfun = 2) call channel(2)%activate_mapping ([1]) call channel(3)%set_s_mapping ([1,2]) call channel(4)%set_s_mapping ([1,2], power=2._default) call channel(5)%set_res_mapping ([1,2], m = 0.5_default, w = 0.1_default, single = .false.) call channel(6)%set_os_mapping ([1,2], m = 0.5_default, single = .false.) call channel(7)%set_res_mapping ([1], m = 0.5_default, w = 0.1_default, single = .true.) call channel(8)%set_os_mapping ([1], m = 0.5_default, single = .true.) call channel(3)%set_par_index (1, 1) call channel(3)%set_par_index (2, 4) call channel(4)%set_par_index (1, 1) call channel(4)%set_par_index (2, 4) call channel(5)%set_par_index (1, 1) call channel(5)%set_par_index (2, 3) call channel(6)%set_par_index (1, 1) call channel(6)%set_par_index (2, 2) call channel(7)%set_par_index (1, 1) call channel(8)%set_par_index (1, 1) do c = 1, size (channel) write (u, "(I0,':')", advance="no") c call channel(c)%write (u) end do write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_2" end subroutine sf_mappings_2 @ %def sf_mappings_2 @ \subsubsection{Check resonance mapping} Probe the resonance mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. The resonance mass is at $1/2$ the energy, the width is $1/10$. <>= call test (sf_mappings_3, "sf_mappings_3", & "resonant pair mapping", & u, results) <>= public :: sf_mappings_3 <>= subroutine sf_mappings_3 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_3" write (u, "(A)") "* Purpose: probe resonance pair mapping" write (u, "(A)") allocate (sf_res_mapping_t :: mapping) select type (mapping) type is (sf_res_mapping_t) call mapping%init (0.5_default, 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.1):" p = [0.1_default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_3" end subroutine sf_mappings_3 @ %def sf_mappings_3 @ \subsubsection{Check on-shell mapping} Probe the on-shell mapping of the unit square for different parameter values. Also calculates integrals. In this case, the Jacobian is constant and given by $|\log m^2|$, so this is also the value of the integral. The factor results from the variable change in the $\delta$ function $\delta (m^2 - x_1x_2)$ which multiplies the cross section for the case at hand. For the test, the (rescaled) resonance mass is set at $1/2$ the energy. <>= call test (sf_mappings_4, "sf_mappings_4", & "on-shell pair mapping", & u, results) <>= public :: sf_mappings_4 <>= subroutine sf_mappings_4 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_4" write (u, "(A)") "* Purpose: probe on-shell pair mapping" write (u, "(A)") allocate (sf_os_mapping_t :: mapping) select type (mapping) type is (sf_os_mapping_t) call mapping%init (0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0,0.1):" p = [0._default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0,1.0):" p = [0._default, 1.0_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_4" end subroutine sf_mappings_4 @ %def sf_mappings_4 @ \subsubsection{Check endpoint mapping} Probe the endpoint mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_5, "sf_mappings_5", & "endpoint pair mapping", & u, results) <>= public :: sf_mappings_5 <>= subroutine sf_mappings_5 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_5" write (u, "(A)") "* Purpose: probe endpoint pair mapping" write (u, "(A)") allocate (sf_ep_mapping_t :: mapping) select type (mapping) type is (sf_ep_mapping_t) call mapping%init () call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_5" end subroutine sf_mappings_5 @ %def sf_mappings_5 @ \subsubsection{Check endpoint resonant mapping} Probe the endpoint mapping with resonance. Also calculates integrals. <>= call test (sf_mappings_6, "sf_mappings_6", & "endpoint resonant mapping", & u, results) <>= public :: sf_mappings_6 <>= subroutine sf_mappings_6 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_6" write (u, "(A)") "* Purpose: probe endpoint resonant mapping" write (u, "(A)") allocate (sf_epr_mapping_t :: mapping) select type (mapping) type is (sf_epr_mapping_t) call mapping%init (a = 1._default, m = 0.5_default, w = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Same mapping without resonance:" write (u, "(A)") allocate (sf_epr_mapping_t :: mapping) select type (mapping) type is (sf_epr_mapping_t) call mapping%init (a = 1._default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_6" end subroutine sf_mappings_6 @ %def sf_mappings_6 @ \subsubsection{Check endpoint on-shell mapping} Probe the endpoint mapping with an on-shell particle. Also calculates integrals. <>= call test (sf_mappings_7, "sf_mappings_7", & "endpoint on-shell mapping", & u, results) <>= public :: sf_mappings_7 <>= subroutine sf_mappings_7 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_7" write (u, "(A)") "* Purpose: probe endpoint on-shell mapping" write (u, "(A)") allocate (sf_epo_mapping_t :: mapping) select type (mapping) type is (sf_epo_mapping_t) call mapping%init (a = 1._default, m = 0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_7" end subroutine sf_mappings_7 @ %def sf_mappings_7 @ \subsubsection{Check power mapping} Probe the power mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_8, "sf_mappings_8", & "power pair mapping", & u, results) <>= public :: sf_mappings_8 <>= subroutine sf_mappings_8 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p, pb write (u, "(A)") "* Test output: sf_mappings_8" write (u, "(A)") "* Purpose: probe power pair mapping" write (u, "(A)") allocate (sf_ip_mapping_t :: mapping) select type (mapping) type is (sf_ip_mapping_t) call mapping%init (eps = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] pb= [0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9,0.5):" p = [0.9_default, 0.5_default] pb= [0.1_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] pb= [0.3_default, 0.8_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.8):" p = [0.7_default, 0.8_default] pb= [0.3_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.99,0.02):" p = [0.99_default, 0.02_default] pb= [0.01_default, 0.98_default] call mapping%check (u, p, pb, FMT_14, FMT_12) write (u, *) write (u, "(A)") "Probe at (0.99,0.98):" p = [0.99_default, 0.98_default] pb= [0.01_default, 0.02_default] call mapping%check (u, p, pb, FMT_14, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_8" end subroutine sf_mappings_8 @ %def sf_mappings_8 @ \subsubsection{Check resonant power mapping} Probe the power mapping of the unit square, adapted for an s-channel resonance, for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_9, "sf_mappings_9", & "power resonance mapping", & u, results) <>= public :: sf_mappings_9 <>= subroutine sf_mappings_9 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p, pb write (u, "(A)") "* Test output: sf_mappings_9" write (u, "(A)") "* Purpose: probe power resonant pair mapping" write (u, "(A)") allocate (sf_ipr_mapping_t :: mapping) select type (mapping) type is (sf_ipr_mapping_t) call mapping%init (eps = 0.1_default, m = 0.5_default, w = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] pb= [0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9,0.5):" p = [0.9_default, 0.5_default] pb= [0.1_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] pb= [0.3_default, 0.8_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.8):" p = [0.7_default, 0.8_default] pb= [0.3_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9999,0.02):" p = [0.9999_default, 0.02_default] pb= [0.0001_default, 0.98_default] call mapping%check (u, p, pb, FMT_11, FMT_12) write (u, *) write (u, "(A)") "Probe at (0.9999,0.98):" p = [0.9999_default, 0.98_default] pb= [0.0001_default, 0.02_default] call mapping%check (u, p, pb, FMT_11, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Same mapping without resonance:" write (u, "(A)") allocate (sf_ipr_mapping_t :: mapping) select type (mapping) type is (sf_ipr_mapping_t) call mapping%init (eps = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] pb= [0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9,0.5):" p = [0.9_default, 0.5_default] pb= [0.1_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] pb= [0.3_default, 0.8_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.8):" p = [0.7_default, 0.8_default] pb= [0.3_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_9" end subroutine sf_mappings_9 @ %def sf_mappings_9 @ \subsubsection{Check on-shell power mapping} Probe the power mapping of the unit square, adapted for single-particle production, for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_10, "sf_mappings_10", & "power on-shell mapping", & u, results) <>= public :: sf_mappings_10 <>= subroutine sf_mappings_10 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p, pb write (u, "(A)") "* Test output: sf_mappings_10" write (u, "(A)") "* Purpose: probe power on-shell mapping" write (u, "(A)") allocate (sf_ipo_mapping_t :: mapping) select type (mapping) type is (sf_ipo_mapping_t) call mapping%init (eps = 0.1_default, m = 0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0,0.02):" p = [0._default, 0.02_default] pb= [1._default, 0.98_default] call mapping%check (u, p, pb, FMT_15, FMT_12) write (u, *) write (u, "(A)") "Probe at (0,0.98):" p = [0._default, 0.98_default] pb= [1._default, 0.02_default] call mapping%check (u, p, pb, FMT_15, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_10" end subroutine sf_mappings_10 @ %def sf_mappings_10 @ \subsubsection{Check combined endpoint-power mapping} Probe the mapping for the beamstrahlung/ISR combination. <>= call test (sf_mappings_11, "sf_mappings_11", & "endpoint/power combined mapping", & u, results) <>= public :: sf_mappings_11 <>= subroutine sf_mappings_11 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(4) :: p, pb write (u, "(A)") "* Test output: sf_mappings_11" write (u, "(A)") "* Purpose: probe power pair mapping" write (u, "(A)") allocate (sf_ei_mapping_t :: mapping) select type (mapping) type is (sf_ei_mapping_t) call mapping%init (eps = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) call mapping%set_index (3, 3) call mapping%set_index (4, 4) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):" p = [0.5_default, 0.5_default, 0.5_default, 0.5_default] pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):" p = [0.7_default, 0.2_default, 0.4_default, 0.8_default] pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):" p = [0.9_default, 0.06_default, 0.95_default, 0.1_default] pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default] call mapping%check (u, p, pb, FMT_13, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_11" end subroutine sf_mappings_11 @ %def sf_mappings_11 @ \subsubsection{Check resonant endpoint-power mapping} Probe the mapping for the beamstrahlung/ISR combination. <>= call test (sf_mappings_12, "sf_mappings_12", & "endpoint/power resonant combined mapping", & u, results) <>= public :: sf_mappings_12 <>= subroutine sf_mappings_12 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(4) :: p, pb write (u, "(A)") "* Test output: sf_mappings_12" write (u, "(A)") "* Purpose: probe resonant combined mapping" write (u, "(A)") allocate (sf_eir_mapping_t :: mapping) select type (mapping) type is (sf_eir_mapping_t) call mapping%init (a = 1._default, & eps = 0.1_default, m = 0.5_default, w = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) call mapping%set_index (3, 3) call mapping%set_index (4, 4) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):" p = [0.5_default, 0.5_default, 0.5_default, 0.5_default] pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):" p = [0.7_default, 0.2_default, 0.4_default, 0.8_default] pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):" p = [0.9_default, 0.06_default, 0.95_default, 0.1_default] pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default] call mapping%check (u, p, pb, FMT_15, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_12" end subroutine sf_mappings_12 @ %def sf_mappings_12 @ \subsubsection{Check on-shell endpoint-power mapping} Probe the mapping for the beamstrahlung/ISR combination. <>= call test (sf_mappings_13, "sf_mappings_13", & "endpoint/power on-shell combined mapping", & u, results) <>= public :: sf_mappings_13 <>= subroutine sf_mappings_13 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(4) :: p, pb write (u, "(A)") "* Test output: sf_mappings_13" write (u, "(A)") "* Purpose: probe on-shell combined mapping" write (u, "(A)") allocate (sf_eio_mapping_t :: mapping) select type (mapping) type is (sf_eio_mapping_t) call mapping%init (a = 1._default, eps = 0.1_default, m = 0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) call mapping%set_index (3, 3) call mapping%set_index (4, 4) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):" p = [0.5_default, 0.5_default, 0.5_default, 0.5_default] pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):" p = [0.7_default, 0.2_default, 0.4_default, 0.8_default] pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):" p = [0.9_default, 0.06_default, 0.95_default, 0.1_default] pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default] call mapping%check (u, p, pb, FMT_14, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_13" end subroutine sf_mappings_13 @ %def sf_mappings_13 @ \subsubsection{Check rescaling} Check the rescaling factor in on-shell basic mapping. <>= call test (sf_mappings_14, "sf_mappings_14", & "rescaled on-shell mapping", & u, results) <>= public :: sf_mappings_14 <>= subroutine sf_mappings_14 (u) integer, intent(in) :: u real(default), dimension(2) :: p2, r2 real(default), dimension(1) :: p1, r1 real(default) :: f, x_free, m2 write (u, "(A)") "* Test output: sf_mappings_14" write (u, "(A)") "* Purpose: probe rescaling in os mapping" write (u, "(A)") x_free = 0.9_default m2 = 0.5_default write (u, "(A)") "* Two parameters" write (u, "(A)") p2 = [0.1_default, 0.2_default] call map_on_shell (r2, f, p2, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p2 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r2 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r2) write (u, *) call map_on_shell_inverse (r2, f, p2, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p2 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r2 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r2) write (u, "(A)") write (u, "(A)") "* One parameter" write (u, "(A)") p1 = [0.1_default] call map_on_shell_single (r1, f, p1, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p1 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r1 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r1) write (u, *) call map_on_shell_single_inverse (r1, f, p1, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p1 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r1 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r1) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_14" end subroutine sf_mappings_14 @ %def sf_mappings_14 @ \subsubsection{Check single parameter resonance mapping} Probe the resonance mapping of the unit interval for different parameter values. Also calculates integrals. The resonance mass is at $1/2$ the energy, the width is $1/10$. <>= call test (sf_mappings_15, "sf_mappings_15", & "resonant single mapping", & u, results) <>= public :: sf_mappings_15 <>= subroutine sf_mappings_15 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(1) :: p write (u, "(A)") "* Test output: sf_mappings_15" write (u, "(A)") "* Purpose: probe resonance single mapping" write (u, "(A)") allocate (sf_res_mapping_single_t :: mapping) select type (mapping) type is (sf_res_mapping_single_t) call mapping%init (0.5_default, 0.1_default) call mapping%set_index (1, 1) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0):" p = [0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5):" p = [0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1):" p = [0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_15" end subroutine sf_mappings_15 @ %def sf_mappings_15 @ \subsubsection{Check single parameter on-shell mapping} Probe the on-shell (pseudo) mapping of the unit interval for different parameter values. Also calculates integrals. The resonance mass is at $1/2$ the energy. <>= call test (sf_mappings_16, "sf_mappings_16", & "on-shell single mapping", & u, results) <>= public :: sf_mappings_16 <>= subroutine sf_mappings_16 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(1) :: p write (u, "(A)") "* Test output: sf_mappings_16" write (u, "(A)") "* Purpose: probe on-shell single mapping" write (u, "(A)") allocate (sf_os_mapping_single_t :: mapping) select type (mapping) type is (sf_os_mapping_single_t) call mapping%init (0.5_default) call mapping%set_index (1, 1) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0):" p = [0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5):" p = [0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_16" end subroutine sf_mappings_16 @ %def sf_mappings_16 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Structure function base} <<[[sf_base.f90]]>>= <> module sf_base <> <> use io_units use format_utils, only: write_separator use format_defs, only: FMT_17, FMT_19 use numeric_utils, only: pacify use diagnostics use lorentz use quantum_numbers use interactions use evaluators use pdg_arrays use beams use sf_aux use sf_mappings use constants, only: one, two use physics_defs, only: n_beams_rescaled <> <> <> <> <> contains <> end module sf_base @ %def sf_base @ \subsection{Abstract rescale data-type} NLO calculations require the treatment of initial state parton radiation. The radiation of a parton rescales the energy fraction which enters the hard process. We allow for different rescale settings by extending the abstract. [[sf_rescale_t]] data type. <>= public :: sf_rescale_t <>= type, abstract :: sf_rescale_t integer :: i_beam = 0 contains <> end type sf_rescale_t @ %def sf_rescale_t @ <>= procedure (sf_rescale_apply), deferred :: apply <>= abstract interface subroutine sf_rescale_apply (func, x) import class(sf_rescale_t), intent(in) :: func real(default), intent(inout) :: x end subroutine sf_rescale_apply end interface @ %def rescale_apply @ <>= procedure :: set_i_beam => sf_rescale_set_i_beam <>= subroutine sf_rescale_set_i_beam (func, i_beam) class(sf_rescale_t), intent(inout) :: func integer, intent(in) :: i_beam func%i_beam = i_beam end subroutine sf_rescale_set_i_beam @ %def rescale_set_i_beam @ <>= 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 @ For the subtraction terms we need to rescale the Born $x$ of both beams in the collinear limit. This leaves one beam unaffected and rescales the other according to \begin{equation} x = \frac{\overline{x}}{1-\xi} \end{equation} which is the collinear limit of [[sf_rescale_real_apply]]. <>= 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, unscaled x: ', 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 *, 'rescaled 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 @ In case of IS Splittings, the beam $x$ changes from Born to real and thus needs to be rescaled according to \begin{equation} x_\oplus = \frac{\overline{x}_\oplus}{\sqrt{1-\xi}} \sqrt{\frac{2-\xi(1-y)}{2-\xi(1+y)}} , \qquad x_\ominus = \frac{\overline{x}_\ominus}{\sqrt{1-\xi}} \sqrt{\frac{2-\xi(1+y)}{2-\xi(1-y)}} \end{equation} Refs: \begin{itemize} \item[\textbullet] [0709.2092] Eq. (5.7). \item[\textbullet] [0907.4076] Eq. (2.21). \item Christian Weiss' PhD Thesis (DESY-THESIS-2017-025), Eq. (A.2.3). \end{itemize} <>= 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, unscaled: ', 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 *, 'rescaled 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 @ \subsection{Abstract structure-function data type} This type should hold all configuration data for a specific type of structure function. The base object is empty; the implementations will fill it. <>= public :: sf_data_t <>= type, abstract :: sf_data_t contains <> end type sf_data_t @ %def sf_data_t @ Output. <>= procedure (sf_data_write), deferred :: write <>= abstract interface subroutine sf_data_write (data, unit, verbose) import class(sf_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine sf_data_write end interface @ %def sf_data_write @ Return true if this structure function is in generator mode. In that case, all parameters are free, otherwise bound. (We do not support mixed cases.) Default is: no generator. <>= procedure :: is_generator => sf_data_is_generator <>= function sf_data_is_generator (data) result (flag) class(sf_data_t), intent(in) :: data logical :: flag flag = .false. end function sf_data_is_generator @ %def sf_data_is_generator @ Return the number of input parameters that determine the structure function. <>= procedure (sf_data_get_int), deferred :: get_n_par <>= abstract interface function sf_data_get_int (data) result (n) import class(sf_data_t), intent(in) :: data integer :: n end function sf_data_get_int end interface @ %def sf_data_get_int @ Return the outgoing particle PDG codes for the current setup. The codes can be an array of particles, for each beam. <>= procedure (sf_data_get_pdg_out), deferred :: get_pdg_out <>= abstract interface subroutine sf_data_get_pdg_out (data, pdg_out) import class(sf_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out end subroutine sf_data_get_pdg_out end interface @ %def sf_data_get_pdg_out @ Allocate a matching structure function interaction object and properly initialize it. <>= procedure (sf_data_allocate_sf_int), deferred :: allocate_sf_int <>= abstract interface subroutine sf_data_allocate_sf_int (data, sf_int) import class(sf_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int end subroutine sf_data_allocate_sf_int end interface @ %def sf_data_allocate_sf_int @ Return the PDF set index, if applicable. We implement a default method which returns zero. The PDF (builtin and LHA) implementations will override this. <>= procedure :: get_pdf_set => sf_data_get_pdf_set <>= elemental function sf_data_get_pdf_set (data) result (pdf_set) class(sf_data_t), intent(in) :: data integer :: pdf_set pdf_set = 0 end function sf_data_get_pdf_set @ %def sf_data_get_pdf_set @ Return the spectrum file, if applicable. We implement a default method which returns zero. CIRCE1, CIRCE2 and the beam spectrum will override this. <>= procedure :: get_beam_file => sf_data_get_beam_file <>= function sf_data_get_beam_file (data) result (file) class(sf_data_t), intent(in) :: data type(string_t) :: file file = "" end function sf_data_get_beam_file @ %def sf_data_get_beam_file @ \subsection{Structure-function chain configuration} This is the data type that the [[process]] module uses for setting up its structure-function chain. For each structure function described by the beam data, there is an entry. The [[i]] array indicates the beam(s) to which this structure function applies, and the [[data]] object contains the actual configuration data. <>= public :: sf_config_t <>= type :: sf_config_t integer, dimension(:), allocatable :: i class(sf_data_t), allocatable :: data contains <> end type sf_config_t @ %def sf_config_t @ Output: <>= procedure :: write => sf_config_write <>= subroutine sf_config_write (object, unit, verbose) class(sf_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) if (allocated (object%i)) then write (u, "(1x,A,2(1x,I0))") "Structure-function configuration: & &beam(s)", object%i if (allocated (object%data)) & call object%data%write (u, verbose = verbose) else write (u, "(1x,A)") "Structure-function configuration: [undefined]" end if end subroutine sf_config_write @ %def sf_config_write @ Initialize. <>= procedure :: init => sf_config_init <>= subroutine sf_config_init (sf_config, i_beam, sf_data) class(sf_config_t), intent(out) :: sf_config integer, dimension(:), intent(in) :: i_beam class(sf_data_t), intent(in) :: sf_data allocate (sf_config%i (size (i_beam)), source = i_beam) allocate (sf_config%data, source = sf_data) end subroutine sf_config_init @ %def sf_config_init @ Return the PDF set, if any. <>= procedure :: get_pdf_set => sf_config_get_pdf_set <>= elemental function sf_config_get_pdf_set (sf_config) result (pdf_set) class(sf_config_t), intent(in) :: sf_config integer :: pdf_set pdf_set = sf_config%data%get_pdf_set () end function sf_config_get_pdf_set @ %def sf_config_get_pdf_set @ Return the beam spectrum file, if any. <>= procedure :: get_beam_file => sf_config_get_beam_file <>= function sf_config_get_beam_file (sf_config) result (file) class(sf_config_t), intent(in) :: sf_config type(string_t) :: file file = sf_config%data%get_beam_file () end function sf_config_get_beam_file @ %def sf_config_get_beam_file @ \subsection{Structure-function instance} The [[sf_int_t]] data type contains an [[interaction_t]] object (it is an extension of this type) and a pointer to the [[sf_data_t]] configuration data. This interaction, or copies of it, is used to implement structure-function kinematics and dynamics in the context of process evaluation. The status code [[status]] tells whether the interaction is undefined, has defined kinematics (but matrix elements invalid), or is completely defined. There is also a status code for failure. The implementation is responsible for updating the status. The entries [[mi2]], [[mr2]], and [[mo2]] hold the squared invariant masses of the incoming, radiated, and outgoing particle, respectively. They are supposed to be set upon initialization, but could also be varied event by event. If the radiated or outgoing mass is nonzero, we may need to apply an on-shell projection. The projection mode is stored as [[on_shell_mode]]. The array [[beam_index]] is the list of beams on which this structure function applies ($1$, $2$, or both). The arrays [[incoming]], [[radiated]], and [[outgoing]] contain the indices of the respective particle sets within the interaction, for convenient lookup. The array [[par_index]] indicates the MC input parameters that this entry will use up in the structure-function chain. The first parameter (or the first two, for a spectrum) in this array determines the momentum fraction and is thus subject to global mappings. In the abstract base type, we do not implement the data pointer. This allows us to restrict its type in the implementations. <>= public :: sf_int_t <>= type, abstract, extends (interaction_t) :: sf_int_t integer :: status = SF_UNDEFINED real(default), dimension(:), allocatable :: mi2 real(default), dimension(:), allocatable :: mr2 real(default), dimension(:), allocatable :: mo2 integer :: on_shell_mode = KEEP_ENERGY logical :: qmin_defined = .false. logical :: qmax_defined = .false. real(default), dimension(:), allocatable :: qmin real(default), dimension(:), allocatable :: qmax integer, dimension(:), allocatable :: beam_index integer, dimension(:), allocatable :: incoming integer, dimension(:), allocatable :: radiated integer, dimension(:), allocatable :: outgoing integer, dimension(:), allocatable :: par_index integer, dimension(:), allocatable :: par_primary contains <> end type sf_int_t @ %def sf_int_t @ Status codes. The codes that refer to links, masks, and connections, apply to structure-function chains only. The status codes are public. <>= integer, parameter, public :: SF_UNDEFINED = 0 integer, parameter, public :: SF_INITIAL = 1 integer, parameter, public :: SF_DONE_LINKS = 2 integer, parameter, public :: SF_FAILED_MASK = 3 integer, parameter, public :: SF_DONE_MASK = 4 integer, parameter, public :: SF_FAILED_CONNECTIONS = 5 integer, parameter, public :: SF_DONE_CONNECTIONS = 6 integer, parameter, public :: SF_SEED_KINEMATICS = 10 integer, parameter, public :: SF_FAILED_KINEMATICS = 11 integer, parameter, public :: SF_DONE_KINEMATICS = 12 integer, parameter, public :: SF_FAILED_EVALUATION = 13 integer, parameter, public :: SF_EVALUATED = 20 @ %def SF_UNDEFINED SF_INITIAL @ %def SF_DONE_LINKS SF_DONE_MASK SF_DONE_CONNECTIONS @ %def SF_DONE_KINEMATICS SF_EVALUATED @ %def SF_FAILED_MASK SF_FAILED_CONNECTIONS @ %def SF_FAILED_KINEMATICS SF_FAILED_EVALUATION @ Write a string version of the status code: <>= subroutine write_sf_status (status, u) integer, intent(in) :: status integer, intent(in) :: u select case (status) case (SF_UNDEFINED) write (u, "(1x,'[',A,']')") "undefined" case (SF_INITIAL) write (u, "(1x,'[',A,']')") "initialized" case (SF_DONE_LINKS) write (u, "(1x,'[',A,']')") "links set" case (SF_FAILED_MASK) write (u, "(1x,'[',A,']')") "mask mismatch" case (SF_DONE_MASK) write (u, "(1x,'[',A,']')") "mask set" case (SF_FAILED_CONNECTIONS) write (u, "(1x,'[',A,']')") "connections failed" case (SF_DONE_CONNECTIONS) write (u, "(1x,'[',A,']')") "connections set" case (SF_SEED_KINEMATICS) write (u, "(1x,'[',A,']')") "incoming momenta set" case (SF_FAILED_KINEMATICS) write (u, "(1x,'[',A,']')") "kinematics failed" case (SF_DONE_KINEMATICS) write (u, "(1x,'[',A,']')") "kinematics set" case (SF_FAILED_EVALUATION) write (u, "(1x,'[',A,']')") "evaluation failed" case (SF_EVALUATED) write (u, "(1x,'[',A,']')") "evaluated" end select end subroutine write_sf_status @ %def write_sf_status @ This is the basic output routine. Display status and interaction. <>= procedure :: base_write => sf_int_base_write <>= subroutine sf_int_base_write (object, unit, testflag) class(sf_int_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "SF instance:" call write_sf_status (object%status, u) if (allocated (object%beam_index)) & write (u, "(3x,A,2(1x,I0))") "beam =", object%beam_index if (allocated (object%incoming)) & write (u, "(3x,A,2(1x,I0))") "incoming =", object%incoming if (allocated (object%radiated)) & write (u, "(3x,A,2(1x,I0))") "radiated =", object%radiated if (allocated (object%outgoing)) & write (u, "(3x,A,2(1x,I0))") "outgoing =", object%outgoing if (allocated (object%par_index)) & write (u, "(3x,A,2(1x,I0))") "parameter =", object%par_index if (object%qmin_defined) & write (u, "(3x,A,1x," // FMT_19 // ")") "q_min =", object%qmin if (object%qmax_defined) & write (u, "(3x,A,1x," // FMT_19 // ")") "q_max =", object%qmax call object%interaction_t%basic_write (u, testflag = testflag) end subroutine sf_int_base_write @ %def sf_int_base_write @ The type string identifies the structure function class, and possibly more details about the structure function. <>= procedure (sf_int_type_string), deferred :: type_string <>= abstract interface function sf_int_type_string (object) result (string) import class(sf_int_t), intent(in) :: object type(string_t) :: string end function sf_int_type_string end interface @ %def sf_int_type_string @ Output of the concrete object. We should not forget to call the output routine for the base type. <>= procedure (sf_int_write), deferred :: write <>= abstract interface subroutine sf_int_write (object, unit, testflag) import class(sf_int_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine sf_int_write end interface @ %def sf_int_write @ Basic initialization: set the invariant masses for the particles and initialize the interaction. The caller should then add states to the interaction and freeze it. The dimension of the mask should be equal to the sum of the dimensions of the mass-squared arrays, which determine incoming, radiated, and outgoing particles, respectively. Optionally, we can define minimum and maximum values for the momentum transfer to the outgoing particle(s). If all masses are zero, this is actually required for non-collinear splitting. <>= procedure :: base_init => sf_int_base_init <>= subroutine sf_int_base_init & (sf_int, mask, mi2, mr2, mo2, qmin, qmax, hel_lock) class(sf_int_t), intent(out) :: sf_int type (quantum_numbers_mask_t), dimension(:), intent(in) :: mask real(default), dimension(:), intent(in) :: mi2, mr2, mo2 real(default), dimension(:), intent(in), optional :: qmin, qmax integer, dimension(:), intent(in), optional :: hel_lock allocate (sf_int%mi2 (size (mi2))) sf_int%mi2 = mi2 allocate (sf_int%mr2 (size (mr2))) sf_int%mr2 = mr2 allocate (sf_int%mo2 (size (mo2))) sf_int%mo2 = mo2 if (present (qmin)) then sf_int%qmin_defined = .true. allocate (sf_int%qmin (size (qmin))) sf_int%qmin = qmin end if if (present (qmax)) then sf_int%qmax_defined = .true. allocate (sf_int%qmax (size (qmax))) sf_int%qmax = qmax end if call sf_int%interaction_t%basic_init & (size (mi2), 0, size (mr2) + size (mo2), & mask = mask, hel_lock = hel_lock, set_relations = .true.) end subroutine sf_int_base_init @ %def sf_int_base_init @ Set the indices of the incoming, radiated, and outgoing particles, respectively. <>= procedure :: set_incoming => sf_int_set_incoming procedure :: set_radiated => sf_int_set_radiated procedure :: set_outgoing => sf_int_set_outgoing <>= subroutine sf_int_set_incoming (sf_int, incoming) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: incoming allocate (sf_int%incoming (size (incoming))) sf_int%incoming = incoming end subroutine sf_int_set_incoming subroutine sf_int_set_radiated (sf_int, radiated) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: radiated allocate (sf_int%radiated (size (radiated))) sf_int%radiated = radiated end subroutine sf_int_set_radiated subroutine sf_int_set_outgoing (sf_int, outgoing) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: outgoing allocate (sf_int%outgoing (size (outgoing))) sf_int%outgoing = outgoing end subroutine sf_int_set_outgoing @ %def sf_int_set_incoming @ %def sf_int_set_radiated @ %def sf_int_set_outgoing @ Initialization. This proceeds via an abstract data object, which for the actual implementation should have the matching concrete type. Since all implementations have the same signature, we can prepare a deferred procedure. The data object will become the target of a corresponding pointer within the [[sf_int_t]] implementation. This should call the previous procedure. <>= procedure (sf_int_init), deferred :: init <>= abstract interface subroutine sf_int_init (sf_int, data) import class(sf_int_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data end subroutine sf_int_init end interface @ %def sf_int_init @ Complete initialization. This routine contains initializations that can only be performed after the interaction object got its final shape, i.e., redundant helicities have been eliminated by matching with beams and process. The default implementation does nothing. The [[target]] attribute is formally required since some overriding implementations use a temporary pointer (iterator) to the state-matrix component. It doesn't appear to make a real difference, though. <>= procedure :: setup_constants => sf_int_setup_constants <>= subroutine sf_int_setup_constants (sf_int) class(sf_int_t), intent(inout), target :: sf_int end subroutine sf_int_setup_constants @ %def sf_int_setup_constants @ Set beam indices, i.e., the beam(s) on which this structure function applies. <>= procedure :: set_beam_index => sf_int_set_beam_index <>= subroutine sf_int_set_beam_index (sf_int, beam_index) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: beam_index allocate (sf_int%beam_index (size (beam_index))) sf_int%beam_index = beam_index end subroutine sf_int_set_beam_index @ %def sf_int_set_beam_index @ Set parameter indices, indicating which MC input parameters are to be used for evaluating this structure function. <>= procedure :: set_par_index => sf_int_set_par_index <>= subroutine sf_int_set_par_index (sf_int, par_index) class(sf_int_t), intent(inout) :: sf_int integer, dimension(:), intent(in) :: par_index allocate (sf_int%par_index (size (par_index))) sf_int%par_index = par_index end subroutine sf_int_set_par_index @ %def sf_int_set_par_index @ Initialize the structure-function kinematics, setting incoming momenta. We assume that array shapes match. Three versions. The first version relies on the momenta being linked to another interaction. The second version sets the momenta explicitly. In the third version, we first compute momenta for the specified energies and store those. <>= generic :: seed_kinematics => sf_int_receive_momenta generic :: seed_kinematics => sf_int_seed_momenta generic :: seed_kinematics => sf_int_seed_energies procedure :: sf_int_receive_momenta procedure :: sf_int_seed_momenta procedure :: sf_int_seed_energies <>= subroutine sf_int_receive_momenta (sf_int) class(sf_int_t), intent(inout) :: sf_int if (sf_int%status >= SF_INITIAL) then call sf_int%receive_momenta () sf_int%status = SF_SEED_KINEMATICS end if end subroutine sf_int_receive_momenta subroutine sf_int_seed_momenta (sf_int, k) class(sf_int_t), intent(inout) :: sf_int type(vector4_t), dimension(:), intent(in) :: k if (sf_int%status >= SF_INITIAL) then call sf_int%set_momenta (k, outgoing=.false.) sf_int%status = SF_SEED_KINEMATICS end if end subroutine sf_int_seed_momenta subroutine sf_int_seed_energies (sf_int, E) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: E type(vector4_t), dimension(:), allocatable :: k integer :: j if (sf_int%status >= SF_INITIAL) then allocate (k (size (E))) if (all (E**2 >= sf_int%mi2)) then do j = 1, size (E) k(j) = vector4_moving (E(j), & (3-2*j) * sqrt (E(j)**2 - sf_int%mi2(j)), 3) end do call sf_int%seed_kinematics (k) end if end if end subroutine sf_int_seed_energies @ %def sf_int_seed_momenta @ %def sf_int_seed_energies @ Tell if in generator mode. By default, this is false. To be overridden where appropriate; we may refer to the [[is_generator]] method of the [[data]] component in the concrete type. <>= procedure :: is_generator => sf_int_is_generator <>= function sf_int_is_generator (sf_int) result (flag) class(sf_int_t), intent(in) :: sf_int logical :: flag flag = .false. end function sf_int_is_generator @ %def sf_int_is_generator @ Generate free parameters [[r]]. Parameters are free if they do not correspond to integration parameters (i.e., are bound), but are generated by the structure function object itself. By default, all parameters are bound, and the output values of this procedure will be discarded. With free parameters, we have to override this procedure. The value [[x_free]] is the renormalization factor of the total energy that corresponds to the free parameters. If there are no free parameters, the procedure will not change its value, which starts as unity. Otherwise, the fraction is typically decreased, but may also be increased in some cases. <>= procedure :: generate_free => sf_int_generate_free <>= subroutine sf_int_generate_free (sf_int, r, rb, x_free) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free r = 0 rb= 1 end subroutine sf_int_generate_free @ %def sf_int_generate_free @ Complete the structure-function kinematics, derived from an input parameter (array) $r$ between 0 and 1. The interaction momenta are calculated, and we return $x$ (the momentum fraction), and $f$ (the Jacobian factor for the map $r\to x$), if [[map]] is set. If the [[map]] flag is unset, $r$ and $x$ values will coincide, and $f$ will become unity. If it is set, the structure-function implementation chooses a convenient mapping from $r$ to $x$ with Jacobian $f$. In the [[inverse_kinematics]] variant, we exchange the intent of [[x]] and [[r]]. The momenta are calculated only if the optional flag [[set_momenta]] is present and set. Internal parameters of [[sf_int]] are calculated only if the optional flag [[set_x]] is present and set. Update 2018-08-22: Throughout this algorithm, we now carry [[xb]]=$1-x$ together with [[x]] values, as we did for [[r]] before. This allows us to handle unstable endpoint numerics wherever necessary. The only place where the changes actually did matter was for inverse kinematics in the ISR setup, with a very soft photon, but it might be most sensible to apply the extension with [[xb]] everywhere. <>= procedure (sf_int_complete_kinematics), deferred :: complete_kinematics procedure (sf_int_inverse_kinematics), deferred :: inverse_kinematics <>= abstract interface subroutine sf_int_complete_kinematics (sf_int, x, xb, f, r, rb, map) import class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map end subroutine sf_int_complete_kinematics end interface abstract interface subroutine sf_int_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) import class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta end subroutine sf_int_inverse_kinematics end interface @ %def sf_int_complete_kinematics @ %def sf_int_inverse_kinematics @ Single splitting: compute momenta, given $x$ input parameters. We assume that the incoming momentum is set. The status code is set to [[SF_FAILED_KINEMATICS]] if the $x$ array does not correspond to a valid momentum configuration. Otherwise, it is updated to [[SF_DONE_KINEMATICS]]. We force the outgoing particle on-shell. The on-shell projection is determined by the [[on_shell_mode]]. The radiated particle should already be on shell. <>= procedure :: split_momentum => sf_int_split_momentum <>= subroutine sf_int_split_momentum (sf_int, x, xb) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb type(vector4_t) :: k type(vector4_t), dimension(2) :: q type(splitting_data_t) :: sd real(default) :: E1, E2 logical :: fail if (sf_int%status >= SF_SEED_KINEMATICS) then k = sf_int%get_momentum (1) call sd%init (k, & sf_int%mi2(1), sf_int%mr2(1), sf_int%mo2(1), & collinear = size (x) == 1) call sd%set_t_bounds (x(1), xb(1)) select case (size (x)) case (1) case (3) if (sf_int%qmax_defined) then if (sf_int%qmin_defined) then call sd%sample_t (x(2), & t0 = - sf_int%qmax(1) ** 2, t1 = - sf_int%qmin(1) ** 2) else call sd%sample_t (x(2), & t0 = - sf_int%qmax(1) ** 2) end if else if (sf_int%qmin_defined) then call sd%sample_t (x(2), t1 = - sf_int%qmin(1) ** 2) else call sd%sample_t (x(2)) end if end if call sd%sample_phi (x(3)) case default call msg_bug ("Structure function: impossible number of parameters") end select q = sd%split_momentum (k) call on_shell (q, [sf_int%mr2, sf_int%mo2], & sf_int%on_shell_mode) call sf_int%set_momenta (q, outgoing=.true.) E1 = energy (q(1)) E2 = energy (q(2)) fail = E1 < 0 .or. E2 < 0 & .or. E1 ** 2 < sf_int%mr2(1) & .or. E2 ** 2 < sf_int%mo2(1) if (fail) then sf_int%status = SF_FAILED_KINEMATICS else sf_int%status = SF_DONE_KINEMATICS end if end if end subroutine sf_int_split_momentum @ %def sf_test_split_momentum @ Pair splitting: two incoming momenta, two radiated, two outgoing. This is simple because we insist on all momenta being collinear. <>= procedure :: split_momenta => sf_int_split_momenta <>= subroutine sf_int_split_momenta (sf_int, x, xb) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb type(vector4_t), dimension(2) :: k type(vector4_t), dimension(4) :: q real(default), dimension(4) :: E logical :: fail if (sf_int%status >= SF_SEED_KINEMATICS) then select case (size (x)) case (2) case default call msg_bug ("Pair structure function: recoil requested & &but not implemented yet") end select k(1) = sf_int%get_momentum (1) k(2) = sf_int%get_momentum (2) q(1:2) = xb * k q(3:4) = x * k select case (size (sf_int%mr2)) case (2) call on_shell (q, & [sf_int%mr2(1), sf_int%mr2(2), & sf_int%mo2(1), sf_int%mo2(2)], & sf_int%on_shell_mode) call sf_int%set_momenta (q, outgoing=.true.) E = energy (q) fail = any (E < 0) & .or. any (E(1:2) ** 2 < sf_int%mr2) & .or. any (E(3:4) ** 2 < sf_int%mo2) case default; call msg_bug ("split momenta: incorrect use") end select if (fail) then sf_int%status = SF_FAILED_KINEMATICS else sf_int%status = SF_DONE_KINEMATICS end if end if end subroutine sf_int_split_momenta @ %def sf_int_split_momenta @ Pair spectrum: the reduced version of the previous splitting, without radiated momenta. <>= procedure :: reduce_momenta => sf_int_reduce_momenta <>= subroutine sf_int_reduce_momenta (sf_int, x) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q real(default), dimension(2) :: E logical :: fail if (sf_int%status >= SF_SEED_KINEMATICS) then select case (size (x)) case (2) case default call msg_bug ("Pair spectrum: recoil requested & &but not implemented yet") end select k(1) = sf_int%get_momentum (1) k(2) = sf_int%get_momentum (2) q = x * k call on_shell (q, & [sf_int%mo2(1), sf_int%mo2(2)], & sf_int%on_shell_mode) call sf_int%set_momenta (q, outgoing=.true.) E = energy (q) fail = any (E < 0) & .or. any (E ** 2 < sf_int%mo2) if (fail) then sf_int%status = SF_FAILED_KINEMATICS else sf_int%status = SF_DONE_KINEMATICS end if end if end subroutine sf_int_reduce_momenta @ %def sf_int_reduce_momenta @ The inverse procedure: we compute the [[x]] array from the momentum configuration. In an overriding TBP, we may also set internal data that depend on this, for convenience. NOTE: Here and above, the single-particle case is treated in detail, allowing for non-collinearity and non-vanishing masses and nontrivial momentum-transfer bounds. For the pair case, we currently implement only collinear splitting and assume massless particles. This should be improved. Update 2017-08-22: recover also [[xb]], using the updated [[recover]] method of the splitting-data object. Th <>= procedure :: recover_x => sf_int_recover_x procedure :: base_recover_x => sf_int_recover_x <>= subroutine sf_int_recover_x (sf_int, x, xb, x_free) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free type(vector4_t), dimension(:), allocatable :: k type(vector4_t), dimension(:), allocatable :: q type(splitting_data_t) :: sd if (sf_int%status >= SF_SEED_KINEMATICS) then allocate (k (sf_int%interaction_t%get_n_in ())) allocate (q (sf_int%interaction_t%get_n_out ())) k = sf_int%get_momenta (outgoing=.false.) q = sf_int%get_momenta (outgoing=.true.) select case (size (k)) case (1) call sd%init (k(1), & sf_int%mi2(1), sf_int%mr2(1), sf_int%mo2(1), & collinear = size (x) == 1) call sd%recover (k(1), q, sf_int%on_shell_mode) x(1) = sd%get_x () xb(1) = sd%get_xb () select case (size (x)) case (1) case (3) if (sf_int%qmax_defined) then if (sf_int%qmin_defined) then call sd%inverse_t (x(2), & t0 = - sf_int%qmax(1) ** 2, t1 = - sf_int%qmin(1) ** 2) else call sd%inverse_t (x(2), & t0 = - sf_int%qmax(1) ** 2) end if else if (sf_int%qmin_defined) then call sd%inverse_t (x(2), t1 = - sf_int%qmin(1) ** 2) else call sd%inverse_t (x(2)) end if end if call sd%inverse_phi (x(3)) xb(2:3) = 1 - x(2:3) case default call msg_bug ("Structure function: impossible number & &of parameters") end select case (2) select case (size (x)) case (2) case default call msg_bug ("Pair structure function: recoil requested & &but not implemented yet") end select select case (sf_int%on_shell_mode) case (KEEP_ENERGY) select case (size (q)) case (4) x = energy (q(3:4)) / energy (k) xb= energy (q(1:2)) / energy (k) case (2) x = energy (q) / energy (k) xb= 1 - x end select case (KEEP_MOMENTUM) select case (size (q)) case (4) x = longitudinal_part (q(3:4)) / longitudinal_part (k) xb= longitudinal_part (q(1:2)) / longitudinal_part (k) case (2) x = longitudinal_part (q) / longitudinal_part (k) xb= 1 - x end select end select end select end if end subroutine sf_int_recover_x @ %def sf_int_recover_x @ Apply the structure function, i.e., evaluate the interaction. For the calculation, we may use the stored momenta, any further information stored inside the [[sf_int]] implementation during kinematics setup, and the given energy scale. It may happen that for the given kinematics the value is not defined. This should be indicated by the status code. <>= procedure (sf_int_apply), deferred :: apply <>= abstract interface subroutine sf_int_apply (sf_int, scale, negative_sf, rescale, i_sub) import class(sf_int_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub end subroutine sf_int_apply end interface @ %def sf_int_apply @ \subsection{Accessing the structure function} Return metadata. Once [[interaction_t]] is rewritten in OO, some of this will be inherited. The number of outgoing particles is equal to the number of incoming particles. The radiated particles are the difference. <>= procedure :: get_n_in => sf_int_get_n_in procedure :: get_n_rad => sf_int_get_n_rad procedure :: get_n_out => sf_int_get_n_out <>= pure function sf_int_get_n_in (object) result (n_in) class(sf_int_t), intent(in) :: object integer :: n_in n_in = object%interaction_t%get_n_in () end function sf_int_get_n_in pure function sf_int_get_n_rad (object) result (n_rad) class(sf_int_t), intent(in) :: object integer :: n_rad n_rad = object%interaction_t%get_n_out () & - object%interaction_t%get_n_in () end function sf_int_get_n_rad pure function sf_int_get_n_out (object) result (n_out) class(sf_int_t), intent(in) :: object integer :: n_out n_out = object%interaction_t%get_n_in () end function sf_int_get_n_out @ %def sf_int_get_n_in @ %def sf_int_get_n_rad @ %def sf_int_get_n_out @ Number of matrix element entries in the interaction: <>= procedure :: get_n_states => sf_int_get_n_states <>= function sf_int_get_n_states (sf_int) result (n_states) class(sf_int_t), intent(in) :: sf_int integer :: n_states n_states = sf_int%get_n_matrix_elements () end function sf_int_get_n_states @ %def sf_int_get_n_states @ Return a specific state as a quantum-number array. <>= procedure :: get_state => sf_int_get_state <>= function sf_int_get_state (sf_int, i) result (qn) class(sf_int_t), intent(in) :: sf_int type(quantum_numbers_t), dimension(:), allocatable :: qn integer, intent(in) :: i allocate (qn (sf_int%get_n_tot ())) qn = sf_int%get_quantum_numbers (i) end function sf_int_get_state @ %def sf_int_get_state @ Return the matrix-element values for all states. We can assume that the matrix elements are real, so we take the real part. <>= procedure :: get_values => sf_int_get_values <>= subroutine sf_int_get_values (sf_int, value) class(sf_int_t), intent(in) :: sf_int real(default), dimension(:), intent(out) :: value integer :: i if (sf_int%status >= SF_EVALUATED) then do i = 1, size (value) value(i) = real (sf_int%get_matrix_element (i)) end do else value = 0 end if end subroutine sf_int_get_values @ %def sf_int_get_values @ \subsection{Direct calculations} Compute a structure function value (array) directly, given an array of $x$ values and a scale. If the energy is also given, we initialize the kinematics for that energy, otherwise take it from a previous run. We assume that the [[E]] array has dimension [[n_in]], and the [[x]] array has [[n_par]]. Note: the output x values ([[xx]] and [[xxb]]) are unused in this use case. <>= procedure :: compute_values => sf_int_compute_values <>= subroutine sf_int_compute_values (sf_int, value, x, xb, scale, E) class(sf_int_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: value real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(in) :: scale real(default), dimension(:), intent(in), optional :: E real(default), dimension(size (x)) :: xx, xxb real(default) :: f if (present (E)) call sf_int%seed_kinematics (E) if (sf_int%status >= SF_SEED_KINEMATICS) then call sf_int%complete_kinematics (xx, xxb, f, x, xb, map=.false.) call sf_int%apply (scale) call sf_int%get_values (value) value = value * f else value = 0 end if end subroutine sf_int_compute_values @ %def sf_int_compute_values @ Compute just a single value for one of the states, i.e., throw the others away. <>= procedure :: compute_value => sf_int_compute_value <>= subroutine sf_int_compute_value & (sf_int, i_state, value, x, xb, scale, E) class(sf_int_t), intent(inout) :: sf_int integer, intent(in) :: i_state real(default), intent(out) :: value real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(in) :: scale real(default), dimension(:), intent(in), optional :: E real(default), dimension(:), allocatable :: value_array if (sf_int%status >= SF_INITIAL) then allocate (value_array (sf_int%get_n_states ())) call sf_int%compute_values (value_array, x, xb, scale, E) value = value_array(i_state) else value = 0 end if end subroutine sf_int_compute_value @ %def sf_int_compute_value @ \subsection{Structure-function instance} This is a wrapper for [[sf_int_t]] objects, such that we can build an array with different structure-function types. The structure-function contains an array (a sequence) of [[sf_int_t]] objects. The object, it holds the evaluator that connects the preceding part of the structure-function chain to the current interaction. It also stores the input and output parameter values for the contained structure function. The [[r]] array has a second dimension, corresponding to the mapping channels in a multi-channel configuration. There is a Jacobian entry [[f]] for each channel. The corresponding logical array [[mapping]] tells whether we apply the mapping appropriate for the current structure function in this channel. The [[x]] parameter values (energy fractions) are common to all channels. <>= type :: sf_instance_t class(sf_int_t), allocatable :: int type(evaluator_t) :: eval real(default), dimension(:,:), allocatable :: r real(default), dimension(:,:), allocatable :: rb real(default), dimension(:), allocatable :: f logical, dimension(:), allocatable :: m real(default), dimension(:), allocatable :: x real(default), dimension(:), allocatable :: xb end type sf_instance_t @ %def sf_instance_t @ \subsection{Structure-function chain} A chain is an array of structure functions [[sf]], initiated by a beam setup. We do not use this directly for evaluation, but create instances with copies of the contained interactions. [[n_par]] is the total number of parameters that is necessary for completely determining the structure-function chain. [[n_bound]] is the number of MC input parameters that are requested from the integrator. The difference of [[n_par]] and [[n_bound]] is the number of free parameters, which are generated by a structure-function object in generator mode. <>= public :: sf_chain_t <>= type, extends (beam_t) :: sf_chain_t type(beam_data_t), pointer :: beam_data => null () integer :: n_in = 0 integer :: n_strfun = 0 integer :: n_par = 0 integer :: n_bound = 0 type(sf_instance_t), dimension(:), allocatable :: sf logical :: trace_enable = .false. integer :: trace_unit = 0 contains <> end type sf_chain_t @ %def sf_chain_t @ Finalizer. <>= procedure :: final => sf_chain_final <>= subroutine sf_chain_final (object) class(sf_chain_t), intent(inout) :: object integer :: i call object%final_tracing () if (allocated (object%sf)) then do i = 1, size (object%sf, 1) associate (sf => object%sf(i)) if (allocated (sf%int)) then call sf%int%final () end if end associate end do end if call beam_final (object%beam_t) end subroutine sf_chain_final @ %def sf_chain_final @ Output. <>= procedure :: write => sf_chain_write <>= subroutine sf_chain_write (object, unit) class(sf_chain_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "Incoming particles / structure-function chain:" if (associated (object%beam_data)) then write (u, "(3x,A,I0)") "n_in = ", object%n_in write (u, "(3x,A,I0)") "n_strfun = ", object%n_strfun write (u, "(3x,A,I0)") "n_par = ", object%n_par if (object%n_par /= object%n_bound) then write (u, "(3x,A,I0)") "n_bound = ", object%n_bound end if call object%beam_data%write (u) call write_separator (u) call beam_write (object%beam_t, u) if (allocated (object%sf)) then do i = 1, object%n_strfun associate (sf => object%sf(i)) call write_separator (u) if (allocated (sf%int)) then call sf%int%write (u) else write (u, "(1x,A)") "SF instance: [undefined]" end if end associate end do end if else write (u, "(3x,A)") "[undefined]" end if end subroutine sf_chain_write @ %def sf_chain_write @ Initialize: setup beams. The [[beam_data]] target must remain valid for the lifetime of the chain, since we just establish a pointer. The structure-function configuration array is used to initialize the individual structure-function entries. The target attribute is needed because the [[sf_int]] entries establish pointers to the configuration data. <>= procedure :: init => sf_chain_init <>= subroutine sf_chain_init (sf_chain, beam_data, sf_config) class(sf_chain_t), intent(out) :: sf_chain type(beam_data_t), intent(in), target :: beam_data type(sf_config_t), dimension(:), intent(in), optional, target :: sf_config integer :: i sf_chain%beam_data => beam_data sf_chain%n_in = beam_data%get_n_in () call beam_init (sf_chain%beam_t, beam_data) if (present (sf_config)) then sf_chain%n_strfun = size (sf_config) allocate (sf_chain%sf (sf_chain%n_strfun)) do i = 1, sf_chain%n_strfun call sf_chain%set_strfun (i, sf_config(i)%i, sf_config(i)%data) end do end if end subroutine sf_chain_init @ %def sf_chain_init @ Receive the beam momenta from a source to which the beam interaction is linked. <>= procedure :: receive_beam_momenta => sf_chain_receive_beam_momenta <>= subroutine sf_chain_receive_beam_momenta (sf_chain) class(sf_chain_t), intent(inout), target :: sf_chain type(interaction_t), pointer :: beam_int beam_int => sf_chain%get_beam_int_ptr () call beam_int%receive_momenta () end subroutine sf_chain_receive_beam_momenta @ %def sf_chain_receive_beam_momenta @ Explicitly set the beam momenta. <>= procedure :: set_beam_momenta => sf_chain_set_beam_momenta <>= subroutine sf_chain_set_beam_momenta (sf_chain, p) class(sf_chain_t), intent(inout) :: sf_chain type(vector4_t), dimension(:), intent(in) :: p call beam_set_momenta (sf_chain%beam_t, p) end subroutine sf_chain_set_beam_momenta @ %def sf_chain_set_beam_momenta @ Set a structure-function entry. We use the [[data]] input to allocate the [[int]] structure-function instance with appropriate type, then initialize the entry. The entry establishes a pointer to [[data]]. The index [[i]] is the structure-function index in the chain. <>= procedure :: set_strfun => sf_chain_set_strfun <>= subroutine sf_chain_set_strfun (sf_chain, i, beam_index, data) class(sf_chain_t), intent(inout) :: sf_chain integer, intent(in) :: i integer, dimension(:), intent(in) :: beam_index class(sf_data_t), intent(in), target :: data integer :: n_par, j n_par = data%get_n_par () call data%allocate_sf_int (sf_chain%sf(i)%int) associate (sf_int => sf_chain%sf(i)%int) call sf_int%init (data) call sf_int%set_beam_index (beam_index) call sf_int%set_par_index & ([(j, j = sf_chain%n_par + 1, sf_chain%n_par + n_par)]) sf_chain%n_par = sf_chain%n_par + n_par if (.not. data%is_generator ()) then sf_chain%n_bound = sf_chain%n_bound + n_par end if end associate end subroutine sf_chain_set_strfun @ %def sf_chain_set_strfun @ Return the number of structure-function parameters. <>= procedure :: get_n_par => sf_chain_get_n_par procedure :: get_n_bound => sf_chain_get_n_bound <>= function sf_chain_get_n_par (sf_chain) result (n) class(sf_chain_t), intent(in) :: sf_chain integer :: n n = sf_chain%n_par end function sf_chain_get_n_par function sf_chain_get_n_bound (sf_chain) result (n) class(sf_chain_t), intent(in) :: sf_chain integer :: n n = sf_chain%n_bound end function sf_chain_get_n_bound @ %def sf_chain_get_n_par @ %def sf_chain_get_n_bound @ Return a pointer to the beam interaction. <>= procedure :: get_beam_int_ptr => sf_chain_get_beam_int_ptr <>= function sf_chain_get_beam_int_ptr (sf_chain) result (int) type(interaction_t), pointer :: int class(sf_chain_t), intent(in), target :: sf_chain int => beam_get_int_ptr (sf_chain%beam_t) end function sf_chain_get_beam_int_ptr @ %def sf_chain_get_beam_int_ptr @ Enable the trace feature: record structure function data (input parameters, $x$ values, evaluation result) to an external file. <>= procedure :: setup_tracing => sf_chain_setup_tracing procedure :: final_tracing => sf_chain_final_tracing <>= subroutine sf_chain_setup_tracing (sf_chain, file) class(sf_chain_t), intent(inout) :: sf_chain type(string_t), intent(in) :: file if (sf_chain%n_strfun > 0) then sf_chain%trace_enable = .true. sf_chain%trace_unit = free_unit () open (sf_chain%trace_unit, file = char (file), action = "write", & status = "replace") call sf_chain%write_trace_header () else call msg_error ("Beam structure: no structure functions, tracing & &disabled") end if end subroutine sf_chain_setup_tracing subroutine sf_chain_final_tracing (sf_chain) class(sf_chain_t), intent(inout) :: sf_chain if (sf_chain%trace_enable) then close (sf_chain%trace_unit) sf_chain%trace_enable = .false. end if end subroutine sf_chain_final_tracing @ %def sf_chain_setup_tracing @ %def sf_chain_final_tracing @ Write the header for the tracing file. <>= procedure :: write_trace_header => sf_chain_write_trace_header <>= subroutine sf_chain_write_trace_header (sf_chain) class(sf_chain_t), intent(in) :: sf_chain integer :: u if (sf_chain%trace_enable) then u = sf_chain%trace_unit write (u, "('# ',A)") "WHIZARD output: & &structure-function sampling data" write (u, "('# ',A,1x,I0)") "Number of sf records:", sf_chain%n_strfun write (u, "('# ',A,1x,I0)") "Number of parameters:", sf_chain%n_par write (u, "('# ',A)") "Columns: channel, p(n_par), x(n_par), f, Jac * f" end if end subroutine sf_chain_write_trace_header @ %def sf_chain_write_trace_header @ Write a record which collects the structure function data for the current data point. For the selected channel, we print first the input integration parameters, then the $x$ values, then the structure-function value summed over all quantum numbers, then the structure function value times the mapping Jacobian. <>= procedure :: trace => sf_chain_trace <>= subroutine sf_chain_trace (sf_chain, c_sel, p, x, f, sf_sum) class(sf_chain_t), intent(in) :: sf_chain integer, intent(in) :: c_sel real(default), dimension(:,:), intent(in) :: p real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: f real(default), intent(in) :: sf_sum real(default) :: sf_sum_pac, f_sf_sum_pac integer :: u, i if (sf_chain%trace_enable) then u = sf_chain%trace_unit write (u, "(1x,I0)", advance="no") c_sel write (u, "(2x)", advance="no") do i = 1, sf_chain%n_par write (u, "(1x," // FMT_17 // ")", advance="no") p(i,c_sel) end do write (u, "(2x)", advance="no") do i = 1, sf_chain%n_par write (u, "(1x," // FMT_17 // ")", advance="no") x(i) end do write (u, "(2x)", advance="no") sf_sum_pac = sf_sum f_sf_sum_pac = f(c_sel) * sf_sum call pacify (sf_sum_pac, 1.E-28_default) call pacify (f_sf_sum_pac, 1.E-28_default) write (u, "(2(1x," // FMT_17 // "))") sf_sum_pac, f_sf_sum_pac end if end subroutine sf_chain_trace @ %def sf_chain_trace @ \subsection{Chain instances} A structure-function chain instance contains copies of the interactions in the configuration chain, suitably linked to each other and connected by evaluators. After initialization, [[out_sf]] should point, for each beam, to the last structure function that affects this beam. [[out_sf_i]] should indicate the index of the corresponding outgoing particle within that structure-function interaction. Analogously, [[out_eval]] is the last evaluator in the structure-function chain, which contains the complete set of outgoing particles. [[out_eval_i]] should indicate the index of the outgoing particles, within that evaluator, which will initiate the collision. When calculating actual kinematics, we fill the [[p]], [[r]], and [[x]] arrays and the [[f]] factor. The [[p]] array denotes the MC input parameters as they come from the random-number generator. The [[r]] array results from applying global mappings. The [[x]] array results from applying structure-function local mappings. The $x$ values can be interpreted directly as momentum fractions (or angle fractions, where recoil is involved). The [[f]] factor is the Jacobian that results from applying all mappings. Update 2017-08-22: carry and output all complements ([[pb]], [[rb]], [[xb]]). Previously, [[xb]] was not included in the record, and the output did not contain either. It does become more verbose, however. The [[mapping]] entry may store a global mapping that is applied to a combination of $x$ values and structure functions, as opposed to mappings that affect only a single structure function. It is applied before the latter mappings, in the transformation from the [[p]] array to the [[r]] array. For parameters affected by this mapping, we should ensure that they are not involved in a local mapping. <>= public :: sf_chain_instance_t <>= type, extends (beam_t) :: sf_chain_instance_t type(sf_chain_t), pointer :: config => null () integer :: status = SF_UNDEFINED type(sf_instance_t), dimension(:), allocatable :: sf integer, dimension(:), allocatable :: out_sf integer, dimension(:), allocatable :: out_sf_i integer :: out_eval = 0 integer, dimension(:), allocatable :: out_eval_i integer :: selected_channel = 0 real(default), dimension(:,:), allocatable :: p, pb real(default), dimension(:,:), allocatable :: r, rb real(default), dimension(:), allocatable :: f real(default), dimension(:), allocatable :: x, xb logical, dimension(:), allocatable :: bound real(default) :: x_free = 1 type(sf_channel_t), dimension(:), allocatable :: channel contains <> end type sf_chain_instance_t @ %def sf_chain_instance_t @ Finalizer. <>= procedure :: final => sf_chain_instance_final <>= subroutine sf_chain_instance_final (object) class(sf_chain_instance_t), intent(inout) :: object integer :: i if (allocated (object%sf)) then do i = 1, size (object%sf, 1) associate (sf => object%sf(i)) if (allocated (sf%int)) then call sf%eval%final () call sf%int%final () end if end associate end do end if call beam_final (object%beam_t) end subroutine sf_chain_instance_final @ %def sf_chain_instance_final @ Output. <>= procedure :: write => sf_chain_instance_write <>= subroutine sf_chain_instance_write (object, unit, col_verbose) class(sf_chain_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: col_verbose integer :: u, i, c u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "Structure-function chain instance:" call write_sf_status (object%status, u) if (allocated (object%out_sf)) then write (u, "(3x,A)", advance="no") "outgoing (interactions) =" do i = 1, size (object%out_sf) write (u, "(1x,I0,':',I0)", advance="no") & object%out_sf(i), object%out_sf_i(i) end do write (u, *) end if if (object%out_eval /= 0) then write (u, "(3x,A)", advance="no") "outgoing (evaluators) =" do i = 1, size (object%out_sf) write (u, "(1x,I0,':',I0)", advance="no") & object%out_eval, object%out_eval_i(i) end do write (u, *) end if if (allocated (object%sf)) then if (size (object%sf) /= 0) then write (u, "(1x,A)") "Structure-function parameters:" do c = 1, size (object%f) write (u, "(1x,A,I0,A)", advance="no") "Channel #", c, ":" if (c == object%selected_channel) then write (u, "(1x,A)") "[selected]" else write (u, *) end if write (u, "(3x,A,9(1x,F9.7))") "p =", object%p(:,c) write (u, "(3x,A,9(1x,F9.7))") "pb=", object%pb(:,c) write (u, "(3x,A,9(1x,F9.7))") "r =", object%r(:,c) write (u, "(3x,A,9(1x,F9.7))") "rb=", object%rb(:,c) write (u, "(3x,A,9(1x,ES13.7))") "f =", object%f(c) write (u, "(3x,A)", advance="no") "m =" call object%channel(c)%write (u) end do write (u, "(3x,A,9(1x,F9.7))") "x =", object%x write (u, "(3x,A,9(1x,F9.7))") "xb=", object%xb if (.not. all (object%bound)) then write (u, "(3x,A,9(1x,L1))") "bound =", object%bound end if end if end if call write_separator (u) call beam_write (object%beam_t, u, col_verbose = col_verbose) if (allocated (object%sf)) then do i = 1, size (object%sf) associate (sf => object%sf(i)) call write_separator (u) if (allocated (sf%int)) then if (allocated (sf%r)) then write (u, "(1x,A)") "Structure-function parameters:" do c = 1, size (sf%f) write (u, "(1x,A,I0,A)", advance="no") "Channel #", c, ":" if (c == object%selected_channel) then write (u, "(1x,A)") "[selected]" else write (u, *) end if write (u, "(3x,A,9(1x,F9.7))") "r =", sf%r(:,c) write (u, "(3x,A,9(1x,F9.7))") "rb=", sf%rb(:,c) write (u, "(3x,A,9(1x,ES13.7))") "f =", sf%f(c) write (u, "(3x,A,9(1x,L1,7x))") "m =", sf%m(c) end do write (u, "(3x,A,9(1x,F9.7))") "x =", sf%x write (u, "(3x,A,9(1x,F9.7))") "xb=", sf%xb end if call sf%int%write(u) if (.not. sf%eval%is_empty ()) then call sf%eval%write (u, col_verbose = col_verbose) end if end if end associate end do end if end subroutine sf_chain_instance_write @ %def sf_chain_instance_write @ Initialize. This creates a copy of the interactions in the configuration chain, assumed to be properly initialized. In the copy, we allocate the [[p]] etc.\ arrays. The brute-force assignment of the [[sf]] component would be straightforward, but we provide a more fine-grained copy. In any case, the copy is deep as far as allocatables are concerned, but for the contained [[interaction_t]] objects the copy is shallow, as long as we do not bind defined assignment to the type. Therefore, we have to re-assign the [[interaction_t]] components explicitly, this time calling the proper defined assignment. Furthermore, we allocate the parameter arrays for each structure function. <>= procedure :: init => sf_chain_instance_init <>= subroutine sf_chain_instance_init (chain, config, n_channel) class(sf_chain_instance_t), intent(out), target :: chain type(sf_chain_t), intent(in), target :: config integer, intent(in) :: n_channel integer :: i, j integer :: n_par_tot, n_par, n_strfun chain%config => config n_strfun = config%n_strfun chain%beam_t = config%beam_t allocate (chain%out_sf (config%n_in), chain%out_sf_i (config%n_in)) allocate (chain%out_eval_i (config%n_in)) chain%out_sf = 0 chain%out_sf_i = [(i, i = 1, config%n_in)] chain%out_eval_i = chain%out_sf_i n_par_tot = 0 if (n_strfun /= 0) then allocate (chain%sf (n_strfun)) do i = 1, n_strfun associate (sf => chain%sf(i)) allocate (sf%int, source=config%sf(i)%int) sf%int%interaction_t = config%sf(i)%int%interaction_t n_par = size (sf%int%par_index) allocate (sf%r (n_par, n_channel)); sf%r = 0 allocate (sf%rb(n_par, n_channel)); sf%rb= 0 allocate (sf%f (n_channel)); sf%f = 0 allocate (sf%m (n_channel)); sf%m = .false. allocate (sf%x (n_par)); sf%x = 0 allocate (sf%xb(n_par)); sf%xb= 0 n_par_tot = n_par_tot + n_par end associate end do allocate (chain%p (n_par_tot, n_channel)); chain%p = 0 allocate (chain%pb(n_par_tot, n_channel)); chain%pb= 0 allocate (chain%r (n_par_tot, n_channel)); chain%r = 0 allocate (chain%rb(n_par_tot, n_channel)); chain%rb= 0 allocate (chain%f (n_channel)); chain%f = 0 allocate (chain%x (n_par_tot)); chain%x = 0 allocate (chain%xb(n_par_tot)); chain%xb= 0 call allocate_sf_channels & (chain%channel, n_channel=n_channel, n_strfun=n_strfun) end if allocate (chain%bound (n_par_tot), source = .true.) do i = 1, n_strfun associate (sf => chain%sf(i)) if (sf%int%is_generator ()) then do j = 1, size (sf%int%par_index) chain%bound(sf%int%par_index(j)) = .false. end do end if end associate end do chain%status = SF_INITIAL end subroutine sf_chain_instance_init @ %def sf_chain_instance_init @ Manually select a channel. <>= procedure :: select_channel => sf_chain_instance_select_channel <>= subroutine sf_chain_instance_select_channel (chain, channel) class(sf_chain_instance_t), intent(inout) :: chain integer, intent(in), optional :: channel if (present (channel)) then chain%selected_channel = channel else chain%selected_channel = 0 end if end subroutine sf_chain_instance_select_channel @ %def sf_chain_instance_select_channel @ Copy a channel-mapping object to the structure-function chain instance. We assume that assignment is sufficient, i.e., any non-static components of the [[channel]] object are allocatable und thus recursively copied. After the copy, we extract the single-entry mappings and activate them for the individual structure functions. If there is a multi-entry mapping, we obtain the corresponding MC parameter indices and set them in the copy of the channel object. <>= procedure :: set_channel => sf_chain_instance_set_channel <>= subroutine sf_chain_instance_set_channel (chain, c, channel) class(sf_chain_instance_t), intent(inout) :: chain integer, intent(in) :: c type(sf_channel_t), intent(in) :: channel integer :: i, j, k if (chain%status >= SF_INITIAL) then chain%channel(c) = channel j = 0 do i = 1, chain%config%n_strfun associate (sf => chain%sf(i)) sf%m(c) = channel%is_single_mapping (i) if (channel%is_multi_mapping (i)) then do k = 1, size (sf%int%beam_index) j = j + 1 call chain%channel(c)%set_par_index & (j, sf%int%par_index(k)) end do end if end associate end do if (j /= chain%channel(c)%get_multi_mapping_n_par ()) then print *, "index last filled = ", j print *, "number of parameters = ", & chain%channel(c)%get_multi_mapping_n_par () call msg_bug ("Structure-function setup: mapping index mismatch") end if chain%status = SF_INITIAL end if end subroutine sf_chain_instance_set_channel @ %def sf_chain_instance_set_channel @ Link the interactions in the chain. First, link the beam instance to its template in the configuration chain, which should have the appropriate momenta fixed. Then, we follow the chain via the arrays [[out_sf]] and [[out_sf_i]]. The arrays are (up to) two-dimensional, the entries correspond to the beam particle(s). For each beam, the entry [[out_sf]] points to the last interaction that affected this beam, and [[out_sf_i]] is the out-particle index within that interaction. For the initial beam, [[out_sf]] is zero by definition. For each entry in the chain, we scan the affected beams (one or two). We look for [[out_sf]] and link the out-particle there to the corresponding in-particle in the current interaction. Then, we update the entry in [[out_sf]] and [[out_sf_i]] to point to the current interaction. <>= procedure :: link_interactions => sf_chain_instance_link_interactions <>= subroutine sf_chain_instance_link_interactions (chain) class(sf_chain_instance_t), intent(inout), target :: chain type(interaction_t), pointer :: int integer :: i, j, b if (chain%status >= SF_INITIAL) then do b = 1, chain%config%n_in int => beam_get_int_ptr (chain%beam_t) call interaction_set_source_link (int, b, & chain%config%beam_t, b) end do if (allocated (chain%sf)) then do i = 1, size (chain%sf) associate (sf_int => chain%sf(i)%int) do j = 1, size (sf_int%beam_index) b = sf_int%beam_index(j) call link (sf_int%interaction_t, b, sf_int%incoming(j)) chain%out_sf(b) = i chain%out_sf_i(b) = sf_int%outgoing(j) end do end associate end do end if chain%status = SF_DONE_LINKS end if contains subroutine link (int, b, in_index) type(interaction_t), intent(inout) :: int integer, intent(in) :: b, in_index integer :: i i = chain%out_sf(b) select case (i) case (0) call interaction_set_source_link (int, in_index, & chain%beam_t, chain%out_sf_i(b)) case default call int%set_source_link (in_index, & chain%sf(i)%int, chain%out_sf_i(b)) end select end subroutine link end subroutine sf_chain_instance_link_interactions @ %def sf_chain_instance_link_interactions @ Exchange the quantum-number masks between the interactions in the chain, so we can combine redundant entries and detect any obvious mismatch. We proceed first in the forward direction and then backwards again. After this is finished, we finalize initialization by calling the [[setup_constants]] method, which prepares constant data that depend on the matrix element structure. <>= procedure :: exchange_mask => sf_chain_exchange_mask <>= subroutine sf_chain_exchange_mask (chain) class(sf_chain_instance_t), intent(inout), target :: chain type(interaction_t), pointer :: int type(quantum_numbers_mask_t), dimension(:), allocatable :: mask integer :: i if (chain%status >= SF_DONE_LINKS) then if (allocated (chain%sf)) then int => beam_get_int_ptr (chain%beam_t) allocate (mask (int%get_n_out ())) mask = int%get_mask () if (size (chain%sf) /= 0) then do i = 1, size (chain%sf) - 1 - call interaction_exchange_mask (chain%sf(i)%int%interaction_t) + call chain%sf(i)%int%exchange_mask () end do do i = size (chain%sf), 1, -1 - call interaction_exchange_mask (chain%sf(i)%int%interaction_t) + call chain%sf(i)%int%exchange_mask () end do if (any (mask .neqv. int%get_mask ())) then chain%status = SF_FAILED_MASK return end if do i = 1, size (chain%sf) call chain%sf(i)%int%setup_constants () end do end if end if chain%status = SF_DONE_MASK end if end subroutine sf_chain_exchange_mask @ %def sf_chain_exchange_mask @ Initialize the evaluators that connect the interactions in the chain. <>= procedure :: init_evaluators => sf_chain_instance_init_evaluators <>= subroutine sf_chain_instance_init_evaluators (chain, extended_sf) class(sf_chain_instance_t), intent(inout), target :: chain logical, intent(in), optional :: extended_sf type(interaction_t), pointer :: int type(quantum_numbers_mask_t) :: mask integer :: i logical :: yorn yorn = .false.; if (present (extended_sf)) yorn = extended_sf if (chain%status >= SF_DONE_MASK) then if (allocated (chain%sf)) then if (size (chain%sf) /= 0) then mask = quantum_numbers_mask (.false., .false., .true.) int => beam_get_int_ptr (chain%beam_t) do i = 1, size (chain%sf) associate (sf => chain%sf(i)) if (yorn) then if (int%get_n_sub () == 0) then call int%declare_subtraction (n_beams_rescaled) end if if (sf%int%interaction_t%get_n_sub () == 0) then call sf%int%interaction_t%declare_subtraction (n_beams_rescaled) end if end if call sf%eval%init_product (int, sf%int%interaction_t, mask,& & ignore_sub_for_qn = .true.) if (sf%eval%is_empty ()) then chain%status = SF_FAILED_CONNECTIONS return end if int => sf%eval%interaction_t end associate end do call find_outgoing_particles () end if else if (chain%out_eval == 0) then int => beam_get_int_ptr (chain%beam_t) call int%tag_hard_process () end if chain%status = SF_DONE_CONNECTIONS end if contains <> end subroutine sf_chain_instance_init_evaluators @ %def sf_chain_instance_init_evaluators @ For debug purposes <>= procedure :: write_interaction => sf_chain_instance_write_interaction <>= subroutine sf_chain_instance_write_interaction (chain, i_sf, i_int, unit) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: i_sf, i_int integer, intent(in) :: unit class(interaction_t), pointer :: int_in1 => null () class(interaction_t), pointer :: int_in2 => null () integer :: u u = given_output_unit (unit); if (u < 0) return if (chain%status >= SF_DONE_MASK) then if (allocated (chain%sf)) then int_in1 => evaluator_get_int_in_ptr (chain%sf(i_sf)%eval, 1) int_in2 => evaluator_get_int_in_ptr (chain%sf(i_sf)%eval, 2) if (int_in1%get_tag () == i_int) then call int_in1%basic_write (u) else if (int_in2%get_tag () == i_int) then call int_in2%basic_write (u) else write (u, "(A,1x,I0,1x,A,1x,I0)") 'No tag of sf', i_sf, 'matches' , i_int end if else write (u, "(A)") 'No sf_chain allocated!' end if else write (u, "(A)") 'sf_chain not ready!' end if end subroutine sf_chain_instance_write_interaction @ %def sf_chain_instance_write_interaction @ This is an internal subroutine of the previous one: After evaluators are set, trace the outgoing particles to the last evaluator. We only need the first channel, all channels are equivalent for this purpose. For each beam, the outgoing particle is located by [[out_sf]] (the structure-function object where it originates) and [[out_sf_i]] (the index within that object). This particle is referenced by the corresponding evaluator, which in turn is referenced by the next evaluator, until we are at the end of the chain. We can trace back references by [[interaction_find_link]]. Knowing that [[out_eval]] is the index of the last evaluator, we thus determine [[out_eval_i]], the index of the outgoing particle within that evaluator. <>= subroutine find_outgoing_particles () type(interaction_t), pointer :: int, int_next integer :: i, j, out_sf, out_i chain%out_eval = size (chain%sf) do j = 1, size (chain%out_eval_i) out_sf = chain%out_sf(j) out_i = chain%out_sf_i(j) if (out_sf == 0) then int => beam_get_int_ptr (chain%beam_t) out_sf = 1 else int => chain%sf(out_sf)%int%interaction_t end if do i = out_sf, chain%out_eval int_next => chain%sf(i)%eval%interaction_t out_i = interaction_find_link (int_next, int, out_i) int => int_next end do chain%out_eval_i(j) = out_i end do call int%tag_hard_process (chain%out_eval_i) end subroutine find_outgoing_particles @ %def find_outgoing_particles @ Compute the kinematics in the chain instance. We can assume that the seed momenta are set in the configuration beams. Scanning the chain, we first transfer the incoming momenta. Then, the use up the MC input parameter array [[p]] to compute the radiated and outgoing momenta. In the multi-channel case, [[c_sel]] is the channel which we use for computing the kinematics and the [[x]] values. In the other channels, we invert the kinematics in order to recover the corresponding rows in the [[r]] array, and the Jacobian [[f]]. We first apply any global mapping to transform the input [[p]] into the array [[r]]. This is then given to the structure functions which compute the final array [[x]] and Jacobian factors [[f]], which we multiply to obtain the overall Jacobian. <>= procedure :: compute_kinematics => sf_chain_instance_compute_kinematics <>= subroutine sf_chain_instance_compute_kinematics (chain, c_sel, p_in) class(sf_chain_instance_t), intent(inout), target :: chain integer, intent(in) :: c_sel real(default), dimension(:), intent(in) :: p_in type(interaction_t), pointer :: int real(default) :: f_mapping integer :: i, j, c if (chain%status >= SF_DONE_CONNECTIONS) then call chain%select_channel (c_sel) int => beam_get_int_ptr (chain%beam_t) call int%receive_momenta () if (allocated (chain%sf)) then if (size (chain%sf) /= 0) then forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL chain%p (:,c_sel) = unpack (p_in, chain%bound, 0._default) chain%pb(:,c_sel) = 1 - chain%p(:,c_sel) chain%f = 1 chain%x_free = 1 do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%generate_free (sf%r(:,c_sel), sf%rb(:,c_sel), & chain%x_free) do j = 1, size (sf%x) if (.not. chain%bound(sf%int%par_index(j))) then chain%p (sf%int%par_index(j),c_sel) = sf%r (j,c_sel) chain%pb(sf%int%par_index(j),c_sel) = sf%rb(j,c_sel) end if end do end associate end do if (allocated (chain%channel(c_sel)%multi_mapping)) then call chain%channel(c_sel)%multi_mapping%compute & (chain%r(:,c_sel), chain%rb(:,c_sel), & f_mapping, & chain%p(:,c_sel), chain%pb(:,c_sel), & chain%x_free) chain%f(c_sel) = f_mapping else chain%r (:,c_sel) = chain%p (:,c_sel) chain%rb(:,c_sel) = chain%pb(:,c_sel) chain%f(c_sel) = 1 end if do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%seed_kinematics () do j = 1, size (sf%x) sf%r (j,c_sel) = chain%r (sf%int%par_index(j),c_sel) sf%rb(j,c_sel) = chain%rb(sf%int%par_index(j),c_sel) end do call sf%int%complete_kinematics & (sf%x, sf%xb, sf%f(c_sel), sf%r(:,c_sel), sf%rb(:,c_sel), & sf%m(c_sel)) do j = 1, size (sf%x) chain%x(sf%int%par_index(j)) = sf%x(j) chain%xb(sf%int%par_index(j)) = sf%xb(j) end do if (sf%int%status <= SF_FAILED_KINEMATICS) then chain%status = SF_FAILED_KINEMATICS return end if do c = 1, size (sf%f) if (c /= c_sel) then call sf%int%inverse_kinematics & (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c)) do j = 1, size (sf%x) chain%r (sf%int%par_index(j),c) = sf%r (j,c) chain%rb(sf%int%par_index(j),c) = sf%rb(j,c) end do end if chain%f(c) = chain%f(c) * sf%f(c) end do if (.not. sf%eval%is_empty ()) then call sf%eval%receive_momenta () end if end associate end do do c = 1, size (chain%f) if (c /= c_sel) then if (allocated (chain%channel(c)%multi_mapping)) then call chain%channel(c)%multi_mapping%inverse & (chain%r(:,c), chain%rb(:,c), & f_mapping, & chain%p(:,c), chain%pb(:,c), & chain%x_free) chain%f(c) = chain%f(c) * f_mapping else chain%p (:,c) = chain%r (:,c) chain%pb(:,c) = chain%rb(:,c) end if end if end do end if end if chain%status = SF_DONE_KINEMATICS end if end subroutine sf_chain_instance_compute_kinematics @ %def sf_chain_instance_compute_kinematics @ This is a variant of the previous procedure. We know the $x$ parameters and reconstruct the momenta and the MC input parameters [[p]]. We do not need to select a channel. Note: this is probably redundant, since the method we actually want starts from the momenta, recovers all $x$ parameters, and then inverts mappings. See below [[recover_kinematics]]. <>= procedure :: inverse_kinematics => sf_chain_instance_inverse_kinematics <>= subroutine sf_chain_instance_inverse_kinematics (chain, x, xb) class(sf_chain_instance_t), intent(inout), target :: chain real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb type(interaction_t), pointer :: int real(default) :: f_mapping integer :: i, j, c if (chain%status >= SF_DONE_CONNECTIONS) then call chain%select_channel () int => beam_get_int_ptr (chain%beam_t) call int%receive_momenta () if (allocated (chain%sf)) then chain%f = 1 if (size (chain%sf) /= 0) then forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL chain%x = x chain%xb= xb do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%seed_kinematics () do j = 1, size (sf%x) sf%x(j) = chain%x(sf%int%par_index(j)) sf%xb(j) = chain%xb(sf%int%par_index(j)) end do do c = 1, size (sf%f) call sf%int%inverse_kinematics & (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), & set_momenta = c==1) chain%f(c) = chain%f(c) * sf%f(c) do j = 1, size (sf%x) chain%r (sf%int%par_index(j),c) = sf%r (j,c) chain%rb(sf%int%par_index(j),c) = sf%rb(j,c) end do end do if (.not. sf%eval%is_empty ()) then call sf%eval%receive_momenta () end if end associate end do do c = 1, size (chain%f) if (allocated (chain%channel(c)%multi_mapping)) then call chain%channel(c)%multi_mapping%inverse & (chain%r(:,c), chain%rb(:,c), & f_mapping, & chain%p(:,c), chain%pb(:,c), & chain%x_free) chain%f(c) = chain%f(c) * f_mapping else chain%p (:,c) = chain%r (:,c) chain%pb(:,c) = chain%rb(:,c) end if end do end if end if chain%status = SF_DONE_KINEMATICS end if end subroutine sf_chain_instance_inverse_kinematics @ %def sf_chain_instance_inverse_kinematics @ Recover the kinematics: assuming that the last evaluator has been filled with a valid set of momenta, we travel the momentum links backwards and fill the preceding evaluators and, as a side effect, interactions. We stop at the beam interaction. After all momenta are set, apply the [[inverse_kinematics]] procedure above, suitably modified, to recover the $x$ and $p$ parameters and the Jacobian factors. The [[c_sel]] (channel) argument is just used to mark a selected channel for the records, otherwise the recovery procedure is independent of this. <>= procedure :: recover_kinematics => sf_chain_instance_recover_kinematics <>= subroutine sf_chain_instance_recover_kinematics (chain, c_sel) class(sf_chain_instance_t), intent(inout), target :: chain integer, intent(in) :: c_sel real(default) :: f_mapping integer :: i, j, c if (chain%status >= SF_DONE_CONNECTIONS) then call chain%select_channel (c_sel) if (allocated (chain%sf)) then do i = size (chain%sf), 1, -1 associate (sf => chain%sf(i)) if (.not. sf%eval%is_empty ()) then - call interaction_send_momenta (sf%eval%interaction_t) + call sf%eval%send_momenta () end if end associate end do chain%f = 1 if (size (chain%sf) /= 0) then forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL chain%x_free = 1 do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%seed_kinematics () call sf%int%recover_x (sf%x, sf%xb, chain%x_free) do j = 1, size (sf%x) chain%x(sf%int%par_index(j)) = sf%x(j) chain%xb(sf%int%par_index(j)) = sf%xb(j) end do do c = 1, size (sf%f) call sf%int%inverse_kinematics & (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), & set_momenta = .false.) chain%f(c) = chain%f(c) * sf%f(c) do j = 1, size (sf%x) chain%r (sf%int%par_index(j),c) = sf%r (j,c) chain%rb(sf%int%par_index(j),c) = sf%rb(j,c) end do end do end associate end do do c = 1, size (chain%f) if (allocated (chain%channel(c)%multi_mapping)) then call chain%channel(c)%multi_mapping%inverse & (chain%r(:,c), chain%rb(:,c), & f_mapping, & chain%p(:,c), chain%pb(:,c), & chain%x_free) chain%f(c) = chain%f(c) * f_mapping else chain%p (:,c) = chain%r (:,c) chain%pb(:,c) = chain%rb(:,c) end if end do end if end if chain%status = SF_DONE_KINEMATICS end if end subroutine sf_chain_instance_recover_kinematics @ %def sf_chain_instance_recover_kinematics @ Return the initial beam momenta to their source, thus completing kinematics recovery. Obviously, this works as a side effect. <>= procedure :: return_beam_momenta => sf_chain_instance_return_beam_momenta <>= subroutine sf_chain_instance_return_beam_momenta (chain) class(sf_chain_instance_t), intent(in), target :: chain type(interaction_t), pointer :: int if (chain%status >= SF_DONE_KINEMATICS) then int => beam_get_int_ptr (chain%beam_t) - call interaction_send_momenta (int) + call int%send_momenta () end if end subroutine sf_chain_instance_return_beam_momenta @ %def sf_chain_instance_return_beam_momenta @ Evaluate all interactions in the chain and the product evaluators. We provide a [[scale]] argument that is given to all structure functions in the chain. Hadronic NLO calculations involve rescaled fractions of the original beam momentum. In particular, we have to handle the following cases: \begin{itemize} \item normal evaluation (where [[i_sub = 0]]) for all terms except the real non-subtracted, \item rescaled momentum fraction for both beams in the case of the real non-subtracted term ([[i_sub = 0]]), \item and rescaled momentum fraction for one of both beams in the case of the subtraction and DGLAP component ([[i_sub = 1,2]]). \end{itemize} For the collinear final or intial state counter terms, we apply a rescaling to one beam, and keep the other beam as is. We redo it then vice versa having now two subtractions. <>= procedure :: evaluate => sf_chain_instance_evaluate <>= subroutine sf_chain_instance_evaluate (chain, scale, negative_sf, sf_rescale) class(sf_chain_instance_t), intent(inout), target :: chain real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(inout), optional :: sf_rescale type(interaction_t), pointer :: out_int real(default) :: sf_sum integer :: i_beam, i_sub, n_sub logical :: rescale n_sub = 0 rescale = .false.; if (present (sf_rescale)) rescale = .true. if (rescale) then n_sub = chain%get_n_sub () end if if (chain%status >= SF_DONE_KINEMATICS) then if (allocated (chain%sf)) then if (size (chain%sf) /= 0) then do i_beam = 1, size (chain%sf) associate (sf => chain%sf(i_beam)) if (rescale) then call sf_rescale%set_i_beam (i_beam) do i_sub = 0, n_sub select case (i_sub) case (0) if (n_sub == 0) then call sf%int%apply (scale, negative_sf, sf_rescale, i_sub = i_sub) else call sf%int%apply (scale, negative_sf, i_sub = i_sub) end if case default if (i_beam == i_sub) then call sf%int%apply (scale, negative_sf, sf_rescale, i_sub = i_sub) else call sf%int%apply (scale, negative_sf, i_sub = i_sub) end if end select end do else call sf%int%apply (scale, negative_sf, i_sub = n_sub) end if if (sf%int%status <= SF_FAILED_EVALUATION) then chain%status = SF_FAILED_EVALUATION return end if if (.not. sf%eval%is_empty ()) call sf%eval%evaluate () end associate end do out_int => chain%get_out_int_ptr () sf_sum = real (out_int%sum ()) call chain%config%trace & (chain%selected_channel, chain%p, chain%x, chain%f, sf_sum) end if end if chain%status = SF_EVALUATED end if end subroutine sf_chain_instance_evaluate @ %def sf_chain_instance_evaluate @ \subsection{Access to the chain instance} Transfer the outgoing momenta to the array [[p]]. We assume that array sizes match. <>= procedure :: get_out_momenta => sf_chain_instance_get_out_momenta <>= subroutine sf_chain_instance_get_out_momenta (chain, p) class(sf_chain_instance_t), intent(in), target :: chain type(vector4_t), dimension(:), intent(out) :: p type(interaction_t), pointer :: int integer :: i, j if (chain%status >= SF_DONE_KINEMATICS) then do j = 1, size (chain%out_sf) i = chain%out_sf(j) select case (i) case (0) int => beam_get_int_ptr (chain%beam_t) case default int => chain%sf(i)%int%interaction_t end select p(j) = int%get_momentum (chain%out_sf_i(j)) end do end if end subroutine sf_chain_instance_get_out_momenta @ %def sf_chain_instance_get_out_momenta @ Return a pointer to the last evaluator in the chain (to the interaction). <>= procedure :: get_out_int_ptr => sf_chain_instance_get_out_int_ptr <>= function sf_chain_instance_get_out_int_ptr (chain) result (int) class(sf_chain_instance_t), intent(in), target :: chain type(interaction_t), pointer :: int if (chain%out_eval == 0) then int => beam_get_int_ptr (chain%beam_t) else int => chain%sf(chain%out_eval)%eval%interaction_t end if end function sf_chain_instance_get_out_int_ptr @ %def sf_chain_instance_get_out_int_ptr @ Return the index of the [[j]]-th outgoing particle, within the last evaluator. <>= procedure :: get_out_i => sf_chain_instance_get_out_i <>= function sf_chain_instance_get_out_i (chain, j) result (i) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: j integer :: i i = chain%out_eval_i(j) end function sf_chain_instance_get_out_i @ %def sf_chain_instance_get_out_i @ Return the mask for the outgoing particle(s), within the last evaluator. <>= procedure :: get_out_mask => sf_chain_instance_get_out_mask <>= function sf_chain_instance_get_out_mask (chain) result (mask) class(sf_chain_instance_t), intent(in), target :: chain type(quantum_numbers_mask_t), dimension(:), allocatable :: mask type(interaction_t), pointer :: int allocate (mask (chain%config%n_in)) int => chain%get_out_int_ptr () mask = int%get_mask (chain%out_eval_i) end function sf_chain_instance_get_out_mask @ %def sf_chain_instance_get_out_mask @ Return the array of MC input parameters that corresponds to channel [[c]]. This is the [[p]] array, the parameters before all mappings. The [[p]] array may be deallocated. This should correspond to a zero-size [[r]] argument, so nothing to do then. <>= procedure :: get_mcpar => sf_chain_instance_get_mcpar <>= subroutine sf_chain_instance_get_mcpar (chain, c, r) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: c real(default), dimension(:), intent(out) :: r if (allocated (chain%p)) r = pack (chain%p(:,c), chain%bound) end subroutine sf_chain_instance_get_mcpar @ %def sf_chain_instance_get_mcpar @ Return the Jacobian factor that corresponds to channel [[c]]. <>= procedure :: get_f => sf_chain_instance_get_f <>= function sf_chain_instance_get_f (chain, c) result (f) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: c real(default) :: f if (allocated (chain%f)) then f = chain%f(c) else f = 1 end if end function sf_chain_instance_get_f @ %def sf_chain_instance_get_f @ Return the evaluation status. <>= procedure :: get_status => sf_chain_instance_get_status <>= function sf_chain_instance_get_status (chain) result (status) class(sf_chain_instance_t), intent(in) :: chain integer :: status status = chain%status end function sf_chain_instance_get_status @ %def sf_chain_instance_get_status @ <>= procedure :: get_matrix_elements => sf_chain_instance_get_matrix_elements <>= subroutine sf_chain_instance_get_matrix_elements (chain, i, ff) class(sf_chain_instance_t), intent(in) :: chain integer, intent(in) :: i real(default), intent(out), dimension(:), allocatable :: ff associate (sf => chain%sf(i)) ff = real (sf%int%get_matrix_element ()) end associate end subroutine sf_chain_instance_get_matrix_elements @ %def sf_chain_instance_get_matrix_elements @ <>= procedure :: get_beam_int_ptr => sf_chain_instance_get_beam_int_ptr <>= function sf_chain_instance_get_beam_int_ptr (chain) result (int) type(interaction_t), pointer :: int class(sf_chain_instance_t), intent(in), target :: chain int => beam_get_int_ptr (chain%beam_t) end function sf_chain_instance_get_beam_int_ptr @ %def sf_chain_instance_get_beam_ptr @ <>= procedure :: get_n_sub => sf_chain_instance_get_n_sub <>= integer function sf_chain_instance_get_n_sub (chain) result (n_sub) type(interaction_t), pointer :: int class(sf_chain_instance_t), intent(in), target :: chain int => beam_get_int_ptr (chain%beam_t) n_sub = int%get_n_sub () end function sf_chain_instance_get_n_sub @ %def sf_chain_instance_get_n_sub @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_base_ut.f90]]>>= <> module sf_base_ut use unit_tests use sf_base_uti <> <> <> contains <> end module sf_base_ut @ %def sf_base_ut @ <<[[sf_base_uti.f90]]>>= <> module sf_base_uti <> <> use io_units use format_defs, only: FMT_19 use format_utils, only: write_separator use diagnostics use lorentz use pdg_arrays use flavors use colors use helicities use quantum_numbers use state_matrices, only: FM_IGNORE_HELICITY use interactions use particles use model_data use beams use sf_aux use sf_mappings use sf_base <> <> <> <> contains <> <> end module sf_base_uti @ %def sf_base_ut @ API: driver for the unit tests below. <>= public :: sf_base_test <>= subroutine sf_base_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_base_test @ %def sf_base_test @ \subsection{Test implementation: structure function} This is a template for the actual structure-function implementation which will be defined in separate modules. \subsubsection{Configuration data} The test structure function uses the [[Test]] model. It describes a scalar within an arbitrary initial particle, which is given in the initialization. The radiated particle is also a scalar, the same one, but we set its mass artificially to zero. <>= public :: sf_test_data_t <>= type, extends (sf_data_t) :: sf_test_data_t class(model_data_t), pointer :: model => null () integer :: mode = 0 type(flavor_t) :: flv_in type(flavor_t) :: flv_out type(flavor_t) :: flv_rad real(default) :: m = 0 logical :: collinear = .true. real(default), dimension(:), allocatable :: qbounds contains <> end type sf_test_data_t @ %def sf_test_data_t @ Output. <>= procedure :: write => sf_test_data_write <>= subroutine sf_test_data_write (data, unit, verbose) class(sf_test_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "SF test data:" write (u, "(3x,A,A)") "model = ", char (data%model%get_name ()) write (u, "(3x,A)", advance="no") "incoming = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A)", advance="no") "outgoing = " call data%flv_out%write (u); write (u, *) write (u, "(3x,A)", advance="no") "radiated = " call data%flv_rad%write (u); write (u, *) write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m write (u, "(3x,A,L1)") "collinear = ", data%collinear if (.not. data%collinear .and. allocated (data%qbounds)) then write (u, "(3x,A," // FMT_19 // ")") "qmin = ", data%qbounds(1) write (u, "(3x,A," // FMT_19 // ")") "qmax = ", data%qbounds(2) end if end subroutine sf_test_data_write @ %def sf_test_data_write @ Initialization. <>= procedure :: init => sf_test_data_init <>= subroutine sf_test_data_init (data, model, pdg_in, collinear, qbounds, mode) class(sf_test_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in logical, intent(in), optional :: collinear real(default), dimension(2), intent(in), optional :: qbounds integer, intent(in), optional :: mode data%model => model if (present (mode)) data%mode = mode if (pdg_in%get (1) /= 25) then call msg_fatal ("Test spectrum function: input flavor must be 's'") end if call data%flv_in%init (25, model) data%m = data%flv_in%get_mass () if (present (collinear)) data%collinear = collinear call data%flv_out%init (25, model) call data%flv_rad%init (25, model) if (present (qbounds)) then allocate (data%qbounds (2)) data%qbounds = qbounds end if end subroutine sf_test_data_init @ %def sf_test_data_init @ Return the number of parameters: 1 if only consider collinear splitting, 3 otherwise. <>= procedure :: get_n_par => sf_test_data_get_n_par <>= function sf_test_data_get_n_par (data) result (n) class(sf_test_data_t), intent(in) :: data integer :: n if (data%collinear) then n = 1 else n = 3 end if end function sf_test_data_get_n_par @ %def sf_test_data_get_n_par @ Return the outgoing particle PDG code: 25 <>= procedure :: get_pdg_out => sf_test_data_get_pdg_out <>= subroutine sf_test_data_get_pdg_out (data, pdg_out) class(sf_test_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = 25 end subroutine sf_test_data_get_pdg_out @ %def sf_test_data_get_pdg_out @ Allocate the matching interaction. <>= procedure :: allocate_sf_int => sf_test_data_allocate_sf_int <>= subroutine sf_test_data_allocate_sf_int (data, sf_int) class(sf_test_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int if (allocated (sf_int)) deallocate (sf_int) allocate (sf_test_t :: sf_int) end subroutine sf_test_data_allocate_sf_int @ %def sf_test_data_allocate_sf_int @ \subsubsection{Interaction} <>= type, extends (sf_int_t) :: sf_test_t type(sf_test_data_t), pointer :: data => null () real(default) :: x = 0 contains <> end type sf_test_t @ %def sf_test_t @ Type string: constant <>= procedure :: type_string => sf_test_type_string <>= function sf_test_type_string (object) result (string) class(sf_test_t), intent(in) :: object type(string_t) :: string string = "Test" end function sf_test_type_string @ %def sf_test_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => sf_test_write <>= subroutine sf_test_write (object, unit, testflag) class(sf_test_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "SF test data: [undefined]" end if end subroutine sf_test_write @ %def sf_test_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. Optionally, we can provide minimum and maximum values for the momentum transfer. <>= procedure :: init => sf_test_init <>= subroutine sf_test_init (sf_int, data) class(sf_test_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask type(helicity_t) :: hel0 type(color_t) :: col0 type(quantum_numbers_t), dimension(3) :: qn mask = quantum_numbers_mask (.false., .false., .false.) select type (data) type is (sf_test_data_t) if (allocated (data%qbounds)) then call sf_int%base_init (mask, & [data%m**2], [0._default], [data%m**2], & [data%qbounds(1)], [data%qbounds(2)]) else call sf_int%base_init (mask, & [data%m**2], [0._default], [data%m**2]) end if sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_rad, col0, hel0) call qn(3)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn) call sf_int%freeze () call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) end select sf_int%status = SF_INITIAL end subroutine sf_test_init @ %def sf_test_init @ Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ and consequently $f(r)=2r$. <>= procedure :: complete_kinematics => sf_test_complete_kinematics <>= subroutine sf_test_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(sf_test_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then x(1) = r(1)**2 f = 2 * r(1) else x(1) = r(1) f = 1 end if xb(1) = 1 - x(1) if (size (x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) sf_int%x = x(1) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end subroutine sf_test_complete_kinematics @ %def sf_test_complete_kinematics @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => sf_test_inverse_kinematics <>= subroutine sf_test_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(sf_test_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then r(1) = sqrt (x(1)) f = 2 * r(1) else r(1) = x(1) f = 1 end if if (size (x) == 3) r(2:3) = x(2:3) rb = 1 - r sf_int%x = x(1) if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine sf_test_inverse_kinematics @ %def sf_test_inverse_kinematics @ Apply the structure function. The matrix element becomes unity and the application always succeeds. If the [[mode]] indicator is one, the matrix element is equal to the parameter~$x$. <>= procedure :: apply => sf_test_apply <>= subroutine sf_test_apply (sf_int, scale, negative_sf, rescale, i_sub) class(sf_test_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub select case (sf_int%data%mode) case (0) call sf_int%set_matrix_element & (cmplx (1._default, kind=default)) case (1) call sf_int%set_matrix_element & (cmplx (sf_int%x, kind=default)) end select sf_int%status = SF_EVALUATED end subroutine sf_test_apply @ %def sf_test_apply @ \subsection{Test implementation: pair spectrum} Another template, this time for a incoming particle pair, splitting into two radiated and two outgoing particles. \subsubsection{Configuration data} For simplicity, the spectrum contains two mirror images of the previous structure-function configuration: the incoming and all outgoing particles are test scalars. We have two versions, one with radiated particles, one without. <>= type, extends (sf_data_t) :: sf_test_spectrum_data_t class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in type(flavor_t) :: flv_out type(flavor_t) :: flv_rad logical :: with_radiation = .true. real(default) :: m = 0 contains <> end type sf_test_spectrum_data_t @ %def sf_test_spectrum_data_t @ Output. <>= procedure :: write => sf_test_spectrum_data_write <>= subroutine sf_test_spectrum_data_write (data, unit, verbose) class(sf_test_spectrum_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "SF test spectrum data:" write (u, "(3x,A,A)") "model = ", char (data%model%get_name ()) write (u, "(3x,A)", advance="no") "incoming = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A)", advance="no") "outgoing = " call data%flv_out%write (u); write (u, *) write (u, "(3x,A)", advance="no") "radiated = " call data%flv_rad%write (u); write (u, *) write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m end subroutine sf_test_spectrum_data_write @ %def sf_test_spectrum_data_write @ Initialization. <>= procedure :: init => sf_test_spectrum_data_init <>= subroutine sf_test_spectrum_data_init (data, model, pdg_in, with_radiation) class(sf_test_spectrum_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in logical, intent(in) :: with_radiation data%model => model data%with_radiation = with_radiation if (pdg_in%get (1) /= 25) then call msg_fatal ("Test structure function: input flavor must be 's'") end if call data%flv_in%init (25, model) data%m = data%flv_in%get_mass () call data%flv_out%init (25, model) if (with_radiation) then call data%flv_rad%init (25, model) end if end subroutine sf_test_spectrum_data_init @ %def sf_test_spectrum_data_init @ Return the number of parameters: 2, since we have only collinear splitting here. <>= procedure :: get_n_par => sf_test_spectrum_data_get_n_par <>= function sf_test_spectrum_data_get_n_par (data) result (n) class(sf_test_spectrum_data_t), intent(in) :: data integer :: n n = 2 end function sf_test_spectrum_data_get_n_par @ %def sf_test_spectrum_data_get_n_par @ Return the outgoing particle PDG codes: 25 <>= procedure :: get_pdg_out => sf_test_spectrum_data_get_pdg_out <>= subroutine sf_test_spectrum_data_get_pdg_out (data, pdg_out) class(sf_test_spectrum_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = 25 pdg_out(2) = 25 end subroutine sf_test_spectrum_data_get_pdg_out @ %def sf_test_spectrum_data_get_pdg_out @ Allocate the matching interaction. <>= procedure :: allocate_sf_int => & sf_test_spectrum_data_allocate_sf_int <>= subroutine sf_test_spectrum_data_allocate_sf_int (data, sf_int) class(sf_test_spectrum_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (sf_test_spectrum_t :: sf_int) end subroutine sf_test_spectrum_data_allocate_sf_int @ %def sf_test_spectrum_data_allocate_sf_int @ \subsubsection{Interaction} <>= type, extends (sf_int_t) :: sf_test_spectrum_t type(sf_test_spectrum_data_t), pointer :: data => null () contains <> end type sf_test_spectrum_t @ %def sf_test_spectrum_t <>= procedure :: type_string => sf_test_spectrum_type_string <>= function sf_test_spectrum_type_string (object) result (string) class(sf_test_spectrum_t), intent(in) :: object type(string_t) :: string string = "Test Spectrum" end function sf_test_spectrum_type_string @ %def sf_test_spectrum_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => sf_test_spectrum_write <>= subroutine sf_test_spectrum_write (object, unit, testflag) class(sf_test_spectrum_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "SF test spectrum data: [undefined]" end if end subroutine sf_test_spectrum_write @ %def sf_test_spectrum_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_spectrum_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. Optionally, we can provide minimum and maximum values for the momentum transfer. <>= procedure :: init => sf_test_spectrum_init <>= subroutine sf_test_spectrum_init (sf_int, data) class(sf_test_spectrum_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(6) :: mask type(helicity_t) :: hel0 type(color_t) :: col0 type(quantum_numbers_t), dimension(6) :: qn mask = quantum_numbers_mask (.false., .false., .false.) select type (data) type is (sf_test_spectrum_data_t) if (data%with_radiation) then call sf_int%base_init (mask(1:6), & [data%m**2, data%m**2], & [0._default, 0._default], & [data%m**2, data%m**2]) sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_in, col0, hel0) call qn(3)%init (data%flv_rad, col0, hel0) call qn(4)%init (data%flv_rad, col0, hel0) call qn(5)%init (data%flv_out, col0, hel0) call qn(6)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn(1:6)) call sf_int%set_incoming ([1,2]) call sf_int%set_radiated ([3,4]) call sf_int%set_outgoing ([5,6]) else call sf_int%base_init (mask(1:4), & [data%m**2, data%m**2], & [real(default) :: ], & [data%m**2, data%m**2]) sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_in, col0, hel0) call qn(3)%init (data%flv_out, col0, hel0) call qn(4)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn(1:4)) call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) end if call sf_int%freeze () end select sf_int%status = SF_INITIAL end subroutine sf_test_spectrum_init @ %def sf_test_spectrum_init @ Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ (as above) for both $x$ parameters and consequently $f(r)=4r_1r_2$. <>= procedure :: complete_kinematics => sf_test_spectrum_complete_kinematics <>= subroutine sf_test_spectrum_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(sf_test_spectrum_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default), dimension(2) :: xb1 if (map) then x = r**2 f = 4 * r(1) * r(2) else x = r f = 1 end if xb = 1 - x if (sf_int%data%with_radiation) then call sf_int%split_momenta (x, xb) else call sf_int%reduce_momenta (x) end if select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end subroutine sf_test_spectrum_complete_kinematics @ %def sf_test_spectrum_complete_kinematics @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => sf_test_spectrum_inverse_kinematics <>= subroutine sf_test_spectrum_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(sf_test_spectrum_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default), dimension(2) :: xb1 logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then r = sqrt (x) f = 4 * r(1) * r(2) else r = x f = 1 end if rb = 1 - r if (set_mom) then if (sf_int%data%with_radiation) then call sf_int%split_momenta (x, xb) else call sf_int%reduce_momenta (x) end if select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine sf_test_spectrum_inverse_kinematics @ %def sf_test_spectrum_inverse_kinematics @ Apply the structure function. The matrix element becomes unity and the application always succeeds. <>= procedure :: apply => sf_test_spectrum_apply <>= subroutine sf_test_spectrum_apply (sf_int, scale, negative_sf, rescale, i_sub) class(sf_test_spectrum_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub call sf_int%set_matrix_element & (cmplx (1._default, kind=default)) sf_int%status = SF_EVALUATED end subroutine sf_test_spectrum_apply @ %def sf_test_spectrum_apply @ \subsection{Test implementation: generator spectrum} A generator for two beams, no radiation (for simplicity). \subsubsection{Configuration data} For simplicity, the spectrum contains two mirror images of the previous structure-function configuration: the incoming and all outgoing particles are test scalars. We have two versions, one with radiated particles, one without. <>= type, extends (sf_data_t) :: sf_test_generator_data_t class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in type(flavor_t) :: flv_out type(flavor_t) :: flv_rad real(default) :: m = 0 contains <> end type sf_test_generator_data_t @ %def sf_test_generator_data_t @ Output. <>= procedure :: write => sf_test_generator_data_write <>= subroutine sf_test_generator_data_write (data, unit, verbose) class(sf_test_generator_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "SF test generator data:" write (u, "(3x,A,A)") "model = ", char (data%model%get_name ()) write (u, "(3x,A)", advance="no") "incoming = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A)", advance="no") "outgoing = " call data%flv_out%write (u); write (u, *) write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m end subroutine sf_test_generator_data_write @ %def sf_test_generator_data_write @ Initialization. <>= procedure :: init => sf_test_generator_data_init <>= subroutine sf_test_generator_data_init (data, model, pdg_in) class(sf_test_generator_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in data%model => model if (pdg_in%get (1) /= 25) then call msg_fatal ("Test generator: input flavor must be 's'") end if call data%flv_in%init (25, model) data%m = data%flv_in%get_mass () call data%flv_out%init (25, model) end subroutine sf_test_generator_data_init @ %def sf_test_generator_data_init @ This structure function is a generator. <>= procedure :: is_generator => sf_test_generator_data_is_generator <>= function sf_test_generator_data_is_generator (data) result (flag) class(sf_test_generator_data_t), intent(in) :: data logical :: flag flag = .true. end function sf_test_generator_data_is_generator @ %def sf_test_generator_data_is_generator @ Return the number of parameters: 2, since we have only collinear splitting here. <>= procedure :: get_n_par => sf_test_generator_data_get_n_par <>= function sf_test_generator_data_get_n_par (data) result (n) class(sf_test_generator_data_t), intent(in) :: data integer :: n n = 2 end function sf_test_generator_data_get_n_par @ %def sf_test_generator_data_get_n_par @ Return the outgoing particle PDG codes: 25 <>= procedure :: get_pdg_out => sf_test_generator_data_get_pdg_out <>= subroutine sf_test_generator_data_get_pdg_out (data, pdg_out) class(sf_test_generator_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = 25 pdg_out(2) = 25 end subroutine sf_test_generator_data_get_pdg_out @ %def sf_test_generator_data_get_pdg_out @ Allocate the matching interaction. <>= procedure :: allocate_sf_int => & sf_test_generator_data_allocate_sf_int <>= subroutine sf_test_generator_data_allocate_sf_int (data, sf_int) class(sf_test_generator_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (sf_test_generator_t :: sf_int) end subroutine sf_test_generator_data_allocate_sf_int @ %def sf_test_generator_data_allocate_sf_int @ \subsubsection{Interaction} <>= type, extends (sf_int_t) :: sf_test_generator_t type(sf_test_generator_data_t), pointer :: data => null () contains <> end type sf_test_generator_t @ %def sf_test_generator_t <>= procedure :: type_string => sf_test_generator_type_string <>= function sf_test_generator_type_string (object) result (string) class(sf_test_generator_t), intent(in) :: object type(string_t) :: string string = "Test Generator" end function sf_test_generator_type_string @ %def sf_test_generator_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => sf_test_generator_write <>= subroutine sf_test_generator_write (object, unit, testflag) class(sf_test_generator_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "SF test generator data: [undefined]" end if end subroutine sf_test_generator_write @ %def sf_test_generator_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_generator_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass. No radiation. <>= procedure :: init => sf_test_generator_init <>= subroutine sf_test_generator_init (sf_int, data) class(sf_test_generator_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(4) :: mask type(helicity_t) :: hel0 type(color_t) :: col0 type(quantum_numbers_t), dimension(4) :: qn mask = quantum_numbers_mask (.false., .false., .false.) select type (data) type is (sf_test_generator_data_t) call sf_int%base_init (mask(1:4), & [data%m**2, data%m**2], & [real(default) :: ], & [data%m**2, data%m**2]) sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_in, col0, hel0) call qn(3)%init (data%flv_out, col0, hel0) call qn(4)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn(1:4)) call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%freeze () end select sf_int%status = SF_INITIAL end subroutine sf_test_generator_init @ %def sf_test_generator_init @ This structure function is a generator. <>= procedure :: is_generator => sf_test_generator_is_generator <>= function sf_test_generator_is_generator (sf_int) result (flag) class(sf_test_generator_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function sf_test_generator_is_generator @ %def sf_test_generator_is_generator @ Generate free parameters. This mock generator always produces the nubmers 0.8 and 0.5. <>= procedure :: generate_free => sf_test_generator_generate_free <>= subroutine sf_test_generator_generate_free (sf_int, r, rb, x_free) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free r = [0.8, 0.5] rb= 1 - r x_free = x_free * product (r) end subroutine sf_test_generator_generate_free @ %def sf_test_generator_generate_free @ Recover momentum fractions. Since the x values are free, we also set the [[x_free]] parameter. <>= procedure :: recover_x => sf_test_generator_recover_x <>= subroutine sf_test_generator_recover_x (sf_int, x, xb, x_free) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb) if (present (x_free)) x_free = x_free * product (x) end subroutine sf_test_generator_recover_x @ %def sf_test_generator_recover_x @ Set kinematics. Since this is a generator, just transfer input to output. <>= procedure :: complete_kinematics => sf_test_generator_complete_kinematics <>= subroutine sf_test_generator_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map x = r xb= rb f = 1 call sf_int%reduce_momenta (x) end subroutine sf_test_generator_complete_kinematics @ %def sf_test_generator_complete_kinematics @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => sf_test_generator_inverse_kinematics <>= subroutine sf_test_generator_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta r = x rb= xb f = 1 if (set_mom) call sf_int%reduce_momenta (x) end subroutine sf_test_generator_inverse_kinematics @ %def sf_test_generator_inverse_kinematics @ Apply the structure function. The matrix element becomes unity and the application always succeeds. <>= procedure :: apply => sf_test_generator_apply <>= subroutine sf_test_generator_apply (sf_int, scale, negative_sf, rescale, i_sub) class(sf_test_generator_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub call sf_int%set_matrix_element & (cmplx (1._default, kind=default)) sf_int%status = SF_EVALUATED end subroutine sf_test_generator_apply @ %def sf_test_generator_apply @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_base_1, "sf_base_1", & "structure function configuration", & u, results) <>= public :: sf_base_1 <>= subroutine sf_base_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_base_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") call model%init_test () pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle code:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_1" end subroutine sf_base_1 @ %def sf_base_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the test structure function. <>= call test (sf_base_2, "sf_base_2", & "structure function instance", & u, results) <>= public :: sf_base_2 <>= subroutine sf_base_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () pdg_in = 25 call flv%init (25, model) call reset_interaction_counter () allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics for x=1" write (u, "(A)") r = 1 rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5" write (u, "(A)") r = 0.5_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics with mapping for r=0.8" write (u, "(A)") r = 0.8_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics for x=0.64 and evaluate" write (u, "(A)") x = 0.64_default call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_2" end subroutine sf_base_2 @ %def sf_base_2 @ \subsubsection{Collinear kinematics} Scan over the possibilities for mass assignment and on-shell projections, collinear case. <>= call test (sf_base_3, "sf_base_3", & "alternatives for collinear kinematics", & u, results) <>= public :: sf_base_3 <>= subroutine sf_base_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_3" write (u, "(A)") "* Purpose: check various kinematical setups" write (u, "(A)") "* for collinear structure-function splitting." write (u, "(A)") " (two masses equal, one zero)" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () pdg_in = 25 call flv%init (25, model) call reset_interaction_counter () allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%write (u) allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set radiated mass to zero" sf_int%mr2 = 0 sf_int%mo2 = sf_int%mi2 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set outgoing mass to zero" sf_int%mr2 = sf_int%mi2 sf_int%mo2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set incoming mass to zero" k = vector4_moving (E, E, 3) call sf_int%seed_kinematics ([k]) sf_int%mr2 = sf_int%mi2 sf_int%mo2 = sf_int%mi2 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set all masses to zero" sf_int%mr2 = 0 sf_int%mo2 = 0 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_3" end subroutine sf_base_3 @ %def sf_base_3 @ \subsubsection{Non-collinear kinematics} Scan over the possibilities for mass assignment and on-shell projections, non-collinear case. <>= call test (sf_base_4, "sf_base_4", & "alternatives for non-collinear kinematics", & u, results) <>= public :: sf_base_4 <>= subroutine sf_base_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_4" write (u, "(A)") "* Purpose: check various kinematical setups" write (u, "(A)") "* for free structure-function splitting." write (u, "(A)") " (two masses equal, one zero)" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () pdg_in = 25 call flv%init (25, model) call reset_interaction_counter () allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in, collinear=.false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%write (u) allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set radiated mass to zero" sf_int%mr2 = 0 sf_int%mo2 = sf_int%mi2 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set outgoing mass to zero" sf_int%mr2 = sf_int%mi2 sf_int%mo2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set incoming mass to zero" k = vector4_moving (E, E, 3) call sf_int%seed_kinematics ([k]) sf_int%mr2 = sf_int%mi2 sf_int%mo2 = sf_int%mi2 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set all masses to zero" sf_int%mr2 = 0 sf_int%mo2 = 0 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Re-Initialize structure-function object with Q bounds" call reset_interaction_counter () select type (data) type is (sf_test_data_t) call data%init (model, pdg_in, collinear=.false., & qbounds = [1._default, 100._default]) end select call sf_int%init (data) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_4" end subroutine sf_base_4 @ %def sf_base_4 @ \subsubsection{Pair spectrum} Construct and display a structure function object for a pair spectrum (a structure function involving two particles simultaneously). <>= call test (sf_base_5, "sf_base_5", & "pair spectrum with radiation", & u, results) <>= public :: sf_base_5 <>= subroutine sf_base_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t), dimension(2) :: k type(vector4_t), dimension(4) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_5" write (u, "(A)") "* Purpose: initialize and fill & &a pair spectrum object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () allocate (sf_test_spectrum_data_t :: data) select type (data) type is (sf_test_spectrum_data_t) call data%init (model, pdg_in, with_radiation=.true.) end select write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 write (u, "(A)") write (u, "(A)") "* Initialize spectrum object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momenta with sqrts=1000" E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics (k) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.4,0.8" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.4_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics with mapping for r=0.6,0.8" write (u, "(A)") r = [0.6_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call reset_interaction_counter () call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%seed_kinematics (k) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics for x=0.36,0.64 & &and evaluate" write (u, "(A)") x = [0.36_default, 0.64_default] xb = 1 - x call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_5" end subroutine sf_base_5 @ %def sf_base_5 @ \subsubsection{Pair spectrum without radiation} Construct and display a structure function object for a pair spectrum (a structure function involving two particles simultaneously). <>= call test (sf_base_6, "sf_base_6", & "pair spectrum without radiation", & u, results) <>= public :: sf_base_6 <>= subroutine sf_base_6 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_6" write (u, "(A)") "* Purpose: initialize and fill & &a pair spectrum object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () allocate (sf_test_spectrum_data_t :: data) select type (data) type is (sf_test_spectrum_data_t) call data%init (model, pdg_in, with_radiation=.false.) end select write (u, "(A)") "* Initialize spectrum object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) write (u, "(A)") "* Initialize incoming momenta with sqrts=1000" E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics (k) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.4,0.8" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.4_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call reset_interaction_counter () call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%seed_kinematics (k) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics for x=0.4,0.8 & &and evaluate" write (u, "(A)") x = [0.4_default, 0.8_default] xb = 1 - x call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_6" end subroutine sf_base_6 @ %def sf_base_6 @ \subsubsection{Direct access to structure function} Probe a structure function directly. <>= call test (sf_base_7, "sf_base_7", & "direct access", & u, results) <>= public :: sf_base_7 <>= subroutine sf_base_7 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int real(default), dimension(:), allocatable :: value write (u, "(A)") "* Test output: sf_base_7" write (u, "(A)") "* Purpose: check direct access method" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select call data%allocate_sf_int (sf_int) call sf_int%init (data) write (u, "(A)") "* Probe structure function: states" write (u, "(A)") write (u, "(A,I0)") "n_states = ", sf_int%get_n_states () write (u, "(A,I0)") "n_in = ", sf_int%get_n_in () write (u, "(A,I0)") "n_rad = ", sf_int%get_n_rad () write (u, "(A,I0)") "n_out = ", sf_int%get_n_out () write (u, "(A)") write (u, "(A)", advance="no") "state(1) = " call quantum_numbers_write (sf_int%get_state (1), u) write (u, *) allocate (value (sf_int%get_n_states ())) call sf_int%compute_values (value, & E=[500._default], x=[0.5_default], xb=[0.5_default], scale=0._default) write (u, "(A)") write (u, "(A)", advance="no") "value (E=500, x=0.5) =" write (u, "(9(1x," // FMT_19 // "))") value call sf_int%compute_values (value, & x=[0.1_default], xb=[0.9_default], scale=0._default) write (u, "(A)") write (u, "(A)", advance="no") "value (E=500, x=0.1) =" write (u, "(9(1x," // FMT_19 // "))") value write (u, "(A)") write (u, "(A)") "* Initialize spectrum object" write (u, "(A)") deallocate (value) call sf_int%final () deallocate (sf_int) deallocate (data) allocate (sf_test_spectrum_data_t :: data) select type (data) type is (sf_test_spectrum_data_t) call data%init (model, pdg_in, with_radiation=.false.) end select call data%allocate_sf_int (sf_int) call sf_int%init (data) write (u, "(A)") "* Probe spectrum: states" write (u, "(A)") write (u, "(A,I0)") "n_states = ", sf_int%get_n_states () write (u, "(A,I0)") "n_in = ", sf_int%get_n_in () write (u, "(A,I0)") "n_rad = ", sf_int%get_n_rad () write (u, "(A,I0)") "n_out = ", sf_int%get_n_out () write (u, "(A)") write (u, "(A)", advance="no") "state(1) = " call quantum_numbers_write (sf_int%get_state (1), u) write (u, *) allocate (value (sf_int%get_n_states ())) call sf_int%compute_value (1, value(1), & E = [500._default, 500._default], & x = [0.5_default, 0.6_default], & xb= [0.5_default, 0.4_default], & scale = 0._default) write (u, "(A)") write (u, "(A)", advance="no") "value (E=500,500, x=0.5,0.6) =" write (u, "(9(1x," // FMT_19 // "))") value write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_7" end subroutine sf_base_7 @ %def sf_base_7 @ \subsubsection{Structure function chain configuration} <>= call test (sf_base_8, "sf_base_8", & "structure function chain configuration", & u, results) <>= public :: sf_base_8 <>= subroutine sf_base_8 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_spectrum type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_chain_t) :: sf_chain write (u, "(A)") "* Test output: sf_base_8" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_spectrum_data_t :: data_spectrum) select type (data_spectrum) type is (sf_test_spectrum_data_t) call data_spectrum%init (model, pdg_in, with_radiation=.true.) end select write (u, "(A)") "* Set up chain with beams only" write (u, "(A)") call sf_chain%init (beam_data) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with structure function" write (u, "(A)") allocate (sf_config (1)) call sf_config(1)%init ([1], data_strfun) call sf_chain%init (beam_data, sf_config) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with spectrum and structure function" write (u, "(A)") deallocate (sf_config) allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_spectrum) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_8" end subroutine sf_base_8 @ %def sf_base_8 @ \subsubsection{Structure function instance configuration} We create a structure-function chain instance which implements a configured structure-function chain. We link the momentum entries in the interactions and compute kinematics. We do not actually connect the interactions and create evaluators. We skip this step and manually advance the status of the chain instead. <>= call test (sf_base_9, "sf_base_9", & "structure function chain instance", & u, results) <>= public :: sf_base_9 <>= subroutine sf_base_9 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_spectrum type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance type(sf_channel_t), dimension(2) :: sf_channel type(vector4_t), dimension(2) :: p integer :: j write (u, "(A)") "* Test output: sf_base_9" write (u, "(A)") "* Purpose: set up a structure-function chain & &and create an instance" write (u, "(A)") "* compute kinematics" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_spectrum_data_t :: data_spectrum) select type (data_spectrum) type is (sf_test_spectrum_data_t) call data_spectrum%init (model, pdg_in, with_radiation=.true.) end select write (u, "(A)") "* Set up chain with beams only" write (u, "(A)") call sf_chain%init (beam_data) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics (1, [real(default) ::]) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%get_out_momenta (p) write (u, "(A)") write (u, "(A)") "* Outgoing momenta:" do j = 1, 2 write (u, "(A)") call vector4_write (p(j), u) end do call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with structure function" write (u, "(A)") allocate (sf_config (1)) call sf_config(1)%init ([1], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (1) call sf_channel(1)%activate_mapping ([1]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics (1, [0.8_default]) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%get_out_momenta (p) write (u, "(A)") write (u, "(A)") "* Outgoing momenta:" do j = 1, 2 write (u, "(A)") call vector4_write (p(j), u) end do call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with spectrum and structure function" write (u, "(A)") deallocate (sf_config) allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_spectrum) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics & (1, [0.5_default, 0.6_default, 0.8_default]) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%get_out_momenta (p) write (u, "(A)") write (u, "(A)") "* Outgoing momenta:" do j = 1, 2 write (u, "(A)") call vector4_write (p(j), u) end do call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_9" end subroutine sf_base_9 @ %def sf_base_9 @ \subsubsection{Structure function chain mappings} Set up a structure function chain instance with a pair of single-particle structure functions. We test different global mappings for this setup. Again, we skip evaluators. <>= call test (sf_base_10, "sf_base_10", & "structure function chain mapping", & u, results) <>= public :: sf_base_10 <>= subroutine sf_base_10 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance type(sf_channel_t), dimension(2) :: sf_channel real(default), dimension(2) :: x_saved write (u, "(A)") "* Test output: sf_base_10" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") "* and check mappings" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select write (u, "(A)") "* Set up chain with structure function pair & &and standard mapping" write (u, "(A)") allocate (sf_config (2)) call sf_config(1)%init ([1], data_strfun) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (2) call sf_channel(1)%set_s_mapping ([1,2]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default]) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Invert the kinematics calculation" write (u, "(A)") x_saved = sf_chain_instance%x call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%set_s_mapping ([1, 2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_10" end subroutine sf_base_10 @ %def sf_base_10 @ \subsubsection{Structure function chain evaluation} Here, we test the complete workflow for structure-function chains. First, we create the template chain, then initialize an instance. We set up links, mask, and evaluators. Finally, we set kinematics and evaluate the matrix elements and their products. <>= call test (sf_base_11, "sf_base_11", & "structure function chain evaluation", & u, results) <>= public :: sf_base_11 <>= subroutine sf_base_11 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_spectrum type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance type(sf_channel_t), dimension(2) :: sf_channel type(particle_set_t) :: pset type(interaction_t), pointer :: int logical :: ok write (u, "(A)") "* Test output: sf_base_11" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") "* create an instance and evaluate" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_spectrum_data_t :: data_spectrum) select type (data_spectrum) type is (sf_test_spectrum_data_t) call data_spectrum%init (model, pdg_in, with_radiation=.true.) end select write (u, "(A)") "* Set up chain with beams only" write (u, "(A)") call sf_chain%init (beam_data) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () call sf_chain_instance%compute_kinematics (1, [real(default) ::]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) int => sf_chain_instance%get_out_int_ptr () call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true.) call sf_chain_instance%final () write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover chain:" write (u, "(A)") call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () int => sf_chain_instance%get_out_int_ptr () call pset%fill_interaction (int, 2, check_match=.false.) call sf_chain_instance%recover_kinematics (1) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call pset%final () call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Set up chain with structure function" write (u, "(A)") allocate (sf_config (1)) call sf_config(1)%init ([1], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (1) call sf_channel(1)%activate_mapping ([1]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () call sf_chain_instance%compute_kinematics (1, [0.8_default]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) int => sf_chain_instance%get_out_int_ptr () call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true.) call sf_chain_instance%final () write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover chain:" write (u, "(A)") call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (1) call sf_channel(1)%activate_mapping ([1]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () int => sf_chain_instance%get_out_int_ptr () call pset%fill_interaction (int, 2, check_match=.false.) call sf_chain_instance%recover_kinematics (1) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call pset%final () call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Set up chain with spectrum and structure function" write (u, "(A)") deallocate (sf_config) allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_spectrum) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () call sf_chain_instance%compute_kinematics & (1, [0.5_default, 0.6_default, 0.8_default]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) int => sf_chain_instance%get_out_int_ptr () call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true.) call sf_chain_instance%final () write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover chain:" write (u, "(A)") call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () int => sf_chain_instance%get_out_int_ptr () call pset%fill_interaction (int, 2, check_match=.false.) call sf_chain_instance%recover_kinematics (1) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call pset%final () call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_11" end subroutine sf_base_11 @ %def sf_base_11 @ \subsubsection{Multichannel case} We set up a structure-function chain as before, but with three different parameterizations. The first instance is without mappings, the second one with single-particle mappings, and the third one with two-particle mappings. <>= call test (sf_base_12, "sf_base_12", & "multi-channel structure function chain", & u, results) <>= public :: sf_base_12 <>= subroutine sf_base_12 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance real(default), dimension(2) :: x_saved real(default), dimension(2,3) :: p_saved type(sf_channel_t), dimension(:), allocatable :: sf_channel write (u, "(A)") "* Test output: sf_base_12" write (u, "(A)") "* Purpose: set up and evaluate a multi-channel & &structure-function chain" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Set up chain with structure function pair & &and three different mappings" write (u, "(A)") allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 3) call allocate_sf_channels (sf_channel, n_channel = 3, n_strfun = 2) ! channel 1: no mapping call sf_chain_instance%set_channel (1, sf_channel(1)) ! channel 2: single-particle mappings call sf_channel(2)%activate_mapping ([1,2]) ! call sf_chain_instance%activate_mapping (2, [1,2]) call sf_chain_instance%set_channel (2, sf_channel(2)) ! channel 3: two-particle mapping call sf_channel(3)%set_s_mapping ([1,2]) ! call sf_chain_instance%set_s_mapping (3, [1, 2]) call sf_chain_instance%set_channel (3, sf_channel(3)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () write (u, "(A)") "* Compute kinematics in channel 1 and evaluate" write (u, "(A)") call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Invert the kinematics calculation" write (u, "(A)") x_saved = sf_chain_instance%x call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Compute kinematics in channel 2 and evaluate" write (u, "(A)") p_saved = sf_chain_instance%p call sf_chain_instance%compute_kinematics (2, p_saved(:,2)) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Compute kinematics in channel 3 and evaluate" write (u, "(A)") call sf_chain_instance%compute_kinematics (3, p_saved(:,3)) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_chain_instance%final () call sf_chain%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_12" end subroutine sf_base_12 @ %def sf_base_12 @ \subsubsection{Generated spectrum} Construct and evaluate a structure function object for a pair spectrum which is evaluated as a beam-event generator. <>= call test (sf_base_13, "sf_base_13", & "pair spectrum generator", & u, results) <>= public :: sf_base_13 <>= subroutine sf_base_13 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_base_13" write (u, "(A)") "* Purpose: initialize and fill & &a pair generator object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () allocate (sf_test_generator_data_t :: data) select type (data) type is (sf_test_generator_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize generator object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) write (u, "(A)") "* Generate free r values" write (u, "(A)") x_free = 1 call sf_int%generate_free (r, rb, x_free) write (u, "(A)") "* Initialize incoming momenta with sqrts=1000" E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics (k) write (u, "(A)") write (u, "(A)") "* Complete kinematics" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call reset_interaction_counter () call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%seed_kinematics (k) call sf_int%set_momenta (q, outgoing=.true.) x_free = 1 call sf_int%recover_x (x, xb, x_free) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics & &and evaluate" write (u, "(A)") call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_13" end subroutine sf_base_13 @ %def sf_base_13 @ \subsubsection{Structure function chain evaluation} Here, we test the complete workflow for a structure-function chain with generator. First, we create the template chain, then initialize an instance. We set up links, mask, and evaluators. Finally, we set kinematics and evaluate the matrix elements and their products. <>= call test (sf_base_14, "sf_base_14", & "structure function generator evaluation", & u, results) <>= public :: sf_base_14 <>= subroutine sf_base_14 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_generator type(sf_config_t), dimension(:), allocatable, target :: sf_config real(default), dimension(:), allocatable :: p_in type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance write (u, "(A)") "* Test output: sf_base_14" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") "* create an instance and evaluate" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_generator_data_t :: data_generator) select type (data_generator) type is (sf_test_generator_data_t) call data_generator%init (model, pdg_in) end select write (u, "(A)") "* Set up chain with generator and structure function" write (u, "(A)") allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_generator) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () write (u, "(A)") "* Inject integration parameter" write (u, "(A)") allocate (p_in (sf_chain%get_n_bound ()), source = 0.9_default) write (u, "(A,9(1x,F10.7))") "p_in =", p_in write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_chain_instance%compute_kinematics (1, p_in) call sf_chain_instance%evaluate (scale=0._default) call sf_chain_instance%write (u) write (u, "(A)") write (u, "(A)") "* Extract integration parameter" write (u, "(A)") call sf_chain_instance%get_mcpar (1, p_in) write (u, "(A,9(1x,F10.7))") "p_in =", p_in call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_14" end subroutine sf_base_14 @ %def sf_base_14 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Photon radiation: ISR} <<[[sf_isr.f90]]>>= <> module sf_isr <> <> use io_units use constants, only: pi use format_defs, only: FMT_15, FMT_19 use numeric_utils use diagnostics use physics_defs, only: PHOTON use lorentz use sm_physics, only: Li2 use pdg_arrays use model_data use flavors use colors use quantum_numbers use polarizations use sf_aux use sf_mappings use sf_base use electron_pdfs <> <> <> <> contains <> end module sf_isr @ %def sf_isr @ \subsection{Physics} The ISR structure function is in the most crude approximation (LLA without $\alpha$ corrections, i.e. $\epsilon^0$) \begin{equation} f_0(x) = \epsilon (1-x)^{-1+\epsilon} \qquad\text{with}\qquad \epsilon = \frac{\alpha}{\pi}q_e^2\ln\frac{s}{m^2}, \end{equation} where $m$ is the mass of the incoming (and outgoing) particle, which is initially assumed on-shell. In $f_0(x)$, there is an integrable singularity at $x=1$ which does not spoil the integration, but would lead to an unbounded $f_{\rm max}$. Therefore, we map this singularity like \begin{equation}\label{ISR-mapping} x = 1 - (1-x')^{1/\epsilon} \end{equation} such that \begin{equation} \int dx\,f_0(x) = \int dx' \end{equation} For the detailed form of the QED ISR structure function cf. Chap.~\ref{chap:qed_pdf}. \subsection{Implementation} In the concrete implementation, the zeroth order mapping (\ref{ISR-mapping}) is implemented, and the Jacobian is equal to $f_i(x)/f_0(x)$. This can be written as \begin{align} \frac{f_0(x)}{f_0(x)} &= 1 \\ \frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon - \frac{1-x^2}{2(1-x')} \\ \begin{split}\label{ISR-f2} \frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon + \frac{27 - 8\pi^2}{96}\epsilon^2 - \frac{1-x^2}{2(1-x')} \\ &\quad - \frac{(1+3x^2)\ln x + (1-x)\left(4(1+x)\ln(1-x) + 5 + x\right)}{8(1-x')}\epsilon \end{split} \end{align} %' For $x=1$ (i.e., numerically indistinguishable from $1$), this reduces to \begin{align} \frac{f_0(x)}{f_0(x)} &= 1 \\ \frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon \\ \frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon + \frac{27 - 8\pi^2}{96}\epsilon^2 \end{align} The last line in (\ref{ISR-f2}) is zero for \begin{equation} x_{\rm min} = 0.00714053329734592839549879772019 \end{equation} (Mathematica result), independent of $\epsilon$. For $x$ values less than this we ignore this correction because of the logarithmic singularity which should in principle be resummed. \subsection{The ISR data block} <>= public :: isr_data_t <>= type, extends (sf_data_t) :: isr_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:), allocatable :: flv_in type(qed_pdf_t) :: pdf real(default) :: alpha = 0 real(default) :: q_max = 0 real(default) :: real_mass = 0 real(default) :: mass = 0 real(default) :: eps = 0 real(default) :: log = 0 logical :: recoil = .false. logical :: keep_energy = .true. integer :: order = 3 integer :: error = NONE contains <> end type isr_data_t @ %def isr_data_t @ Error codes <>= integer, parameter :: NONE = 0 integer, parameter :: ZERO_MASS = 1 integer, parameter :: Q_MAX_TOO_SMALL = 2 integer, parameter :: EPS_TOO_LARGE = 3 integer, parameter :: INVALID_ORDER = 4 integer, parameter :: CHARGE_MIX = 5 integer, parameter :: CHARGE_ZERO = 6 integer, parameter :: MASS_MIX = 7 @ Generate flavor-dependent ISR data: <>= procedure :: init => isr_data_init <>= subroutine isr_data_init (data, model, pdg_in, alpha, q_max, & mass, order, recoil, keep_energy) class(isr_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in real(default), intent(in) :: alpha real(default), intent(in) :: q_max real(default), intent(in), optional :: mass integer, intent(in), optional :: order logical, intent(in), optional :: recoil logical, intent(in), optional :: keep_energy integer :: i, n_flv real(default) :: charge data%model => model n_flv = pdg_in%get_length () allocate (data%flv_in (n_flv)) do i = 1, n_flv call data%flv_in(i)%init (pdg_in%get (i), model) end do data%alpha = alpha data%q_max = q_max if (present (order)) then call data%set_order (order) end if if (present (recoil)) then data%recoil = recoil end if if (present (keep_energy)) then data%keep_energy = keep_energy end if data%real_mass = data%flv_in(1)%get_mass () if (present (mass)) then if (mass > 0) then data%mass = mass else data%mass = data%real_mass if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if else data%mass = data%real_mass if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if if (vanishes (data%mass)) then data%error = ZERO_MASS; return else if (data%mass >= data%q_max) then data%error = Q_MAX_TOO_SMALL; return end if data%log = log (1 + (data%q_max / data%mass)**2) charge = data%flv_in(1)%get_charge () if (any (abs (data%flv_in%get_charge ()) /= abs (charge))) then data%error = CHARGE_MIX; return else if (charge == 0) then data%error = CHARGE_ZERO; return end if data%eps = data%alpha / pi * charge ** 2 & * (2 * log (data%q_max / data%mass) - 1) if (data%eps > 1) then data%error = EPS_TOO_LARGE; return end if call data%pdf%init & (data%mass, data%alpha, charge, data%q_max, data%order) end subroutine isr_data_init @ %def isr_data_init @ Explicitly set ISR order <>= procedure :: set_order => isr_data_set_order <>= elemental subroutine isr_data_set_order (data, order) class(isr_data_t), intent(inout) :: data integer, intent(in) :: order if (order < 0 .or. order > 3) then data%error = INVALID_ORDER else data%order = order end if end subroutine isr_data_set_order @ %def isr_data_set_order @ Handle error conditions. Should always be done after initialization, unless we are sure everything is ok. <>= procedure :: check => isr_data_check <>= subroutine isr_data_check (data) class(isr_data_t), intent(in) :: data select case (data%error) case (ZERO_MASS) call msg_fatal ("ISR: Particle mass is zero") case (Q_MAX_TOO_SMALL) call msg_fatal ("ISR: Particle mass exceeds Qmax") case (EPS_TOO_LARGE) call msg_fatal ("ISR: Expansion parameter too large, " // & "perturbative expansion breaks down") case (INVALID_ORDER) call msg_error ("ISR: LLA order invalid (valid values are 0,1,2,3)") case (MASS_MIX) call msg_fatal ("ISR: Incoming particle masses must be uniform") case (CHARGE_MIX) call msg_fatal ("ISR: Incoming particle charges must be uniform") case (CHARGE_ZERO) call msg_fatal ("ISR: Incoming particle must be charged") end select end subroutine isr_data_check @ %def isr_data_check @ Output <>= procedure :: write => isr_data_write <>= subroutine isr_data_write (data, unit, verbose) class(isr_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "ISR data:" if (allocated (data%flv_in)) then write (u, "(3x,A)", advance="no") " flavor = " do i = 1, size (data%flv_in) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_in(i)%write (u) end do write (u, *) write (u, "(3x,A," // FMT_19 // ")") " alpha = ", data%alpha write (u, "(3x,A," // FMT_19 // ")") " q_max = ", data%q_max write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass write (u, "(3x,A," // FMT_19 // ")") " eps = ", data%eps write (u, "(3x,A," // FMT_19 // ")") " log = ", data%log write (u, "(3x,A,I2)") " order = ", data%order write (u, "(3x,A,L2)") " recoil = ", data%recoil write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy else write (u, "(3x,A)") "[undefined]" end if end subroutine isr_data_write @ %def isr_data_write @ For ISR, there is the option to generate transverse momentum is generated. Hence, there can be up to three parameters, $x$, and two angles. <>= procedure :: get_n_par => isr_data_get_n_par <>= function isr_data_get_n_par (data) result (n) class(isr_data_t), intent(in) :: data integer :: n if (data%recoil) then n = 3 else n = 1 end if end function isr_data_get_n_par @ %def isr_data_get_n_par @ Return the outgoing particles PDG codes. For ISR, these are identical to the incoming particles. <>= procedure :: get_pdg_out => isr_data_get_pdg_out <>= subroutine isr_data_get_pdg_out (data, pdg_out) class(isr_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = data%flv_in%get_pdg () end subroutine isr_data_get_pdg_out @ %def isr_data_get_pdg_out @ Return the [[eps]] value. We need it for an appropriate mapping of structure-function parameters. <>= procedure :: get_eps => isr_data_get_eps <>= function isr_data_get_eps (data) result (eps) class(isr_data_t), intent(in) :: data real(default) :: eps eps = data%eps end function isr_data_get_eps @ %def isr_data_get_eps @ Allocate the interaction record. <>= procedure :: allocate_sf_int => isr_data_allocate_sf_int <>= subroutine isr_data_allocate_sf_int (data, sf_int) class(isr_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (isr_t :: sf_int) end subroutine isr_data_allocate_sf_int @ %def isr_data_allocate_sf_int @ \subsection{The ISR object} The [[isr_t]] data type is a $1\to 2$ interaction, i.e., we allow for single-photon emission only (but use the multi-photon resummed radiator function). The particles are ordered as (incoming, photon, outgoing). There is no need to handle several flavors (and data blocks) in parallel, since ISR is always applied immediately after beam collision. (ISR for partons is accounted for by the PDFs themselves.) Polarization is carried through, i.e., we retain the polarization of the incoming particle and treat the emitted photon as unpolarized. Color is trivially carried through. This implies that particles 1 and 3 should be locked together. For ISR we don't need the q variable. <>= public :: isr_t <>= type, extends (sf_int_t) :: isr_t private type(isr_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: xb= 0 contains <> end type isr_t @ %def isr_t @ Type string: has to be here, but there is no string variable on which ISR depends. Hence, a dummy routine. <>= procedure :: type_string => isr_type_string <>= function isr_type_string (object) result (string) class(isr_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "ISR: e+ e- ISR spectrum" else string = "ISR: [undefined]" end if end function isr_type_string @ %def isr_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => isr_write <>= subroutine isr_write (object, unit, testflag) class(isr_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_15 // ")") "x =", object%x write (u, "(3x,A," // FMT_15 // ")") "xb=", object%xb end if call object%base_write (u, testflag) else write (u, "(1x,A)") "ISR data: [undefined]" end if end subroutine isr_write @ %def isr_write @ Explicitly set ISR order (for unit test). <>= procedure :: set_order => isr_set_order <>= subroutine isr_set_order (object, order) class(isr_t), intent(inout) :: object integer, intent(in) :: order call object%data%set_order (order) call object%data%pdf%set_order (order) end subroutine isr_set_order @ %def isr_set_order @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ were trivial. The ISR structure function allows for a straightforward mapping of the unit interval. So, to leading order, the structure function value is unity, but the $x$ value is transformed. Higher orders affect the function value. The structure function implementation applies the above mapping to the input (random) number [[r]] to generate the momentum fraction [[x]] and the function value [[f]]. For numerical stability reasons, we also output [[xb]], which is $\bar x=1-x$. For the ISR structure function, the mapping Jacobian cancels the structure function (to order zero). We apply the cancellation explicitly, therefore both the Jacobian [[f]] and the zeroth-order value (see the [[apply]] method) are unity if mapping is turned on. If mapping is turned off, the Jacobian [[f]] includes the value of the (zeroth-order) structure function, and strongly peaked. <>= procedure :: complete_kinematics => isr_complete_kinematics <>= subroutine isr_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default) :: eps eps = sf_int%data%eps if (map) then call map_power_1 (sf_int%xb, f, rb(1), eps) else sf_int%xb = rb(1) if (rb(1) > 0) then f = 1 else f = 0 end if end if sf_int%x = 1 - sf_int%xb x(1) = sf_int%x xb(1) = sf_int%xb if (size (x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS) sf_int%x = 0 sf_int%xb= 0 f = 0 end select end subroutine isr_complete_kinematics @ %def isr_complete_kinematics @ Overriding the default method: we compute the [[x]] array from the momentum configuration. In the specific case of ISR, we also set the internally stored $x$ and $\bar x$ values, so they can be used in the following routine. <>= procedure :: recover_x => sf_isr_recover_x <>= subroutine sf_isr_recover_x (sf_int, x, xb, x_free) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) sf_int%xb = xb(1) end subroutine sf_isr_recover_x @ %def sf_isr_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. For extracting $x$, we rely on the stored $\bar x$ value, since the $x$ value in the argument is likely imprecise. This means that either [[complete_kinematics]] or [[recover_x]] must be called first, for the current sampling point (but maybe another channel). <>= procedure :: inverse_kinematics => isr_inverse_kinematics <>= subroutine isr_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: eps logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta eps = sf_int%data%eps if (map) then call map_power_inverse_1 (xb(1), f, rb(1), eps) else rb(1) = xb(1) if (rb(1) > 0) then f = 1 else f = 0 end if end if r(1) = 1 - rb(1) if (size(r) == 3) then r(2:3) = x(2:3) rb(2:3)= xb(2:3) end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS) r = 0 rb= 0 f = 0 end select end if end subroutine isr_inverse_kinematics @ %def isr_inverse_kinematics @ <>= procedure :: init => isr_init <>= subroutine isr_init (sf_int, data) class(isr_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask integer, dimension(3) :: hel_lock type(polarization_t), target :: pol type(quantum_numbers_t), dimension(1) :: qn_fc type(flavor_t) :: flv_photon type(color_t) :: col_photon type(quantum_numbers_t) :: qn_hel, qn_photon, qn type(polarization_iterator_t) :: it_hel real(default) :: m2 integer :: i mask = quantum_numbers_mask (.false., .false., & mask_h = [.false., .true., .false.]) hel_lock = [3, 0, 1] select type (data) type is (isr_data_t) m2 = data%mass**2 call sf_int%base_init (mask, [m2], [0._default], [m2], & hel_lock = hel_lock) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col_photon%init () call qn_photon%init (flv_photon, col_photon) call qn_photon%tag_radiated () do i = 1, size (data%flv_in) call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init (& flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) call sf_int%add_state ([qn, qn_photon, qn]) call it_hel%advance () end do ! call pol%final () !!! Obsolete end do call sf_int%freeze () if (data%keep_energy) then sf_int%on_shell_mode = KEEP_ENERGY else sf_int%on_shell_mode = KEEP_MOMENTUM end if call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) sf_int%status = SF_INITIAL end select end subroutine isr_init @ %def isr_init @ \subsection{ISR application} For ISR, we could in principle compute kinematics and function value in a single step. In order to be able to reweight matrix elements including structure functions we split kinematics and structure function calculation. The structure function works on a single beam, assuming that the input momentum has been set. For the structure-function evaluation, we rely on the fact that the power mapping, which we apply in the kinematics method (if the [[map]] flag is set), has a Jacobian which is just the inverse lowest-order structure function. With mapping active, the two should cancel exactly. After splitting momenta, we set the outgoing momenta on-shell. We choose to conserve momentum, so energy conservation may be violated. <>= procedure :: apply => isr_apply <>= subroutine isr_apply (sf_int, scale, negative_sf, rescale, i_sub) class(isr_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f, finv, x, xb, eps, rb real(default) :: log_x, log_xb, x_2 associate (data => sf_int%data) eps = sf_int%data%eps x = sf_int%x xb = sf_int%xb call map_power_inverse_1 (xb, finv, rb, eps) if (finv > 0) then f = 1 / finv else f = 0 end if call data%pdf%evolve_qed_pdf (x, xb, rb, f) end associate call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine isr_apply @ %def isr_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_isr_ut.f90]]>>= <> module sf_isr_ut use unit_tests use sf_isr_uti <> <> contains <> end module sf_isr_ut @ %def sf_isr_ut @ <<[[sf_isr_uti.f90]]>>= <> module sf_isr_uti <> <> use io_units use format_defs, only: FMT_12 use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter - use interactions, only: interaction_pacify_momenta + use interactions, only: interaction_t use model_data use sf_aux, only: KEEP_ENERGY use sf_mappings use sf_base use sf_isr <> <> contains <> end module sf_isr_uti @ %def sf_isr_ut @ API: driver for the unit tests below. <>= public :: sf_isr_test <>= subroutine sf_isr_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_isr_test @ %def sf_isr_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_isr_1, "sf_isr_1", & "structure function configuration", & u, results) <>= public :: sf_isr_1 <>= subroutine sf_isr_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_isr_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_qed_test () pdg_in = ELECTRON allocate (isr_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 10._default, & 0.000511_default, order = 3, recoil = .false.) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_1" end subroutine sf_isr_1 @ %def sf_isr_1 @ \subsubsection{Structure function without mapping} Direct ISR evaluation. This is the use case for a double-beam structure function. The parameter pair is mapped in the calling program. <>= call test (sf_isr_2, "sf_isr_2", & "no ISR mapping", & u, results) <>= public :: sf_isr_2 <>= subroutine sf_isr_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, f_isr write (u, "(A)") "* Test output: sf_isr_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () pdg_in = ELECTRON call flv%init (ELECTRON, model) call reset_interaction_counter () allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.9, no ISR mapping, & &collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.9_default rb = 1 - r write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A)") write (u, "(A,9(1x," // FMT_12 // "))") "x =", x write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Invert kinematics" write (u, "(A)") call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Structure-function value, default order" write (u, "(A)") f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Re-evaluate structure function, leading order" write (u, "(A)") select type (sf_int) type is (isr_t) call sf_int%set_order (0) end select call sf_int%apply (scale = 100._default) f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_2" end subroutine sf_isr_2 @ %def sf_isr_2 @ \subsubsection{Structure function with mapping} Apply the optimal ISR mapping. This is the use case for a single-beam structure function. <>= call test (sf_isr_3, "sf_isr_3", & "ISR mapping", & u, results) <>= public :: sf_isr_3 <>= subroutine sf_isr_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, f_isr write (u, "(A)") "* Test output: sf_isr_3" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.7, with ISR mapping, & &collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.7_default rb = 1 - r write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A)") write (u, "(A,9(1x," // FMT_12 // "))") "x =", x write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Invert kinematics" write (u, "(A)") call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Structure-function value, default order" write (u, "(A)") f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Re-evaluate structure function, leading order" write (u, "(A)") select type (sf_int) type is (isr_t) call sf_int%set_order (0) end select call sf_int%apply (scale = 100._default) f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_3" end subroutine sf_isr_3 @ %def sf_isr_3 @ \subsubsection{Non-collinear ISR splitting} Construct and display a structure function object based on the ISR structure function. We blank out numerical fluctuations for 32bit. <>= call test (sf_isr_4, "sf_isr_4", & "ISR non-collinear", & u, results) <>= public :: sf_isr_4 <>= subroutine sf_isr_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, f_isr character(len=80) :: buffer integer :: u_scratch, iostat write (u, "(A)") "* Test output: sf_isr_4" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () write (u, "(A)") write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .true.) end select call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.25, with ISR mapping, " write (u, "(A)") " non-coll., keeping energy" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.5_default, 0.5_default, 0.25_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) - call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) + call sf_int%pacify_momenta (1e-10_default) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x and r from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) - call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) + call sf_int%pacify_momenta (1e-10_default) call sf_int%apply (scale = 10._default) u_scratch = free_unit () open (u_scratch, status="scratch", action = "readwrite") call sf_int%write (u_scratch, testflag = .true.) rewind (u_scratch) do read (u_scratch, "(A)", iostat=iostat) buffer if (iostat /= 0) exit if (buffer(1:25) == " P = 0.000000E+00 9.57") then buffer = replace (buffer, 26, "XXXX") end if if (buffer(1:25) == " P = 0.000000E+00 -9.57") then buffer = replace (buffer, 26, "XXXX") end if write (u, "(A)") buffer end do close (u_scratch) write (u, "(A)") write (u, "(A)") "* Structure-function value" write (u, "(A)") f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_4" end subroutine sf_isr_4 @ %def sf_isr_4 @ \subsubsection{Structure function pair with mapping} Apply the ISR mapping for a ISR pair. structure function. <>= call test (sf_isr_5, "sf_isr_5", & "ISR pair mapping", & u, results) <>= public :: sf_isr_5 <>= subroutine sf_isr_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_mapping_t), allocatable :: mapping class(sf_int_t), dimension(:), allocatable :: sf_int type(vector4_t), dimension(2) :: k real(default) :: E, f_map real(default), dimension(:), allocatable :: p, pb, r, rb, x, xb real(default), dimension(2) :: f, f_isr integer :: i write (u, "(A)") "* Test output: sf_isr_5" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .false.) end select allocate (sf_ip_mapping_t :: mapping) select type (mapping) type is (sf_ip_mapping_t) select type (data) type is (isr_data_t) call mapping%init (eps = data%get_eps ()) end select call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, "(A)") write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") allocate (isr_t :: sf_int (2)) do i = 1, 2 call sf_int(i)%init (data) call sf_int(i)%set_beam_index ([i]) end do write (u, "(A)") "* Initialize incoming momenta with E=500" write (u, "(A)") E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, - sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) do i = 1, 2 call vector4_write (k(i), u) call sf_int(i)%seed_kinematics (k(i:i)) end do write (u, "(A)") write (u, "(A)") "* Set kinematics for p=[0.7,0.4], collinear" write (u, "(A)") allocate (p (2 * data%get_n_par ())) allocate (pb(size (p))) allocate (r (size (p))) allocate (rb(size (p))) allocate (x (size (p))) allocate (xb(size (p))) p = [0.7_default, 0.4_default] pb= 1 - p call mapping%compute (r, rb, f_map, p, pb) write (u, "(A,9(1x," // FMT_12 // "))") "p =", p write (u, "(A,9(1x," // FMT_12 // "))") "pb=", pb write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "fm=", f_map do i = 1, 2 call sf_int(i)%complete_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), & map=.false.) end do write (u, "(A)") write (u, "(A,9(1x," // FMT_12 // "))") "x =", x write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Invert kinematics" write (u, "(A)") do i = 1, 2 call sf_int(i)%inverse_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), & map=.false.) end do call mapping%inverse (r, rb, f_map, p, pb) write (u, "(A,9(1x," // FMT_12 // "))") "p =", p write (u, "(A,9(1x," // FMT_12 // "))") "pb=", pb write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "fm=", f_map write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" call sf_int(1)%apply (scale = 100._default) call sf_int(2)%apply (scale = 100._default) write (u, "(A)") write (u, "(A)") "* Structure function #1" write (u, "(A)") call sf_int(1)%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Structure function #2" write (u, "(A)") call sf_int(2)%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Structure-function value, default order" write (u, "(A)") do i = 1, 2 f_isr(i) = sf_int(i)%get_matrix_element (1) end do write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", & product (f_isr) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", & product (f_isr * f) * f_map write (u, "(A)") write (u, "(A)") "* Cleanup" do i = 1, 2 call sf_int(i)%final () end do call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_5" end subroutine sf_isr_5 @ %def sf_isr_5 @ \clearpage %------------------------------------------------------------------------ \section{EPA} <<[[sf_epa.f90]]>>= <> module sf_epa <> <> use io_units use constants, only: pi use format_defs, only: FMT_17, FMT_19 use numeric_utils use diagnostics use physics_defs, only: PHOTON use lorentz use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use interactions use sf_aux use sf_base <> <> <> <> contains <> end module sf_epa @ %def sf_epa @ \subsection{Physics} The EPA structure function for a photon inside an (elementary) particle $p$ with energy $E$, mass $m$ and charge $q_p$ (e.g., electron) is given by ($\bar x \equiv 1-x$) There are several variants of the EPA, which are steered by the [[\$epa\_mode]] switch. The formula (6.17b) from the report by Budnev et al. is given by %% %\cite{Budnev:1974de} %% \bibitem{Budnev:1974de} %% V.~M.~Budnev, I.~F.~Ginzburg, G.~V.~Meledin and V.~G.~Serbo, %% %``The Two photon particle production mechanism. Physical problems. %% %Applications. Equivalent photon approximation,'' %% Phys.\ Rept.\ {\bf 15} (1974) 181. %% %%CITATION = PRPLC,15,181;%% \begin{multline} \label{EPA_617} f(x) = \frac{\alpha}{\pi}\,q_p^2\, \frac{1}{x}\, \biggl[\left(\bar x + \frac{x^2}{2}\right) \ln\frac{Q^2_{\rm max}}{Q^2_{\rm min}} \\ - \left(1 - \frac{x}{2}\right)^2 \ln\frac{x^2+\frac{Q^2_{\rm max}}{E^2}} {x^2+\frac{Q^2_{\rm min}}{E^2}} - x^2\frac{m^2}{Q^2_{\rm min}} \left(1 - \frac{Q^2_{\rm min}}{Q^2_{\rm max}}\right) \biggr]. \end{multline} If no explicit $Q$ bounds are provided, the kinematical bounds are \begin{align} -Q^2_{\rm max} &= t_0 = -2\bar x(E^2+p\bar p) + 2m^2 \approx -4\bar x E^2, \\ -Q^2_{\rm min} &= t_1 = -2\bar x(E^2-p\bar p) + 2m^2 \approx -\frac{x^2}{\bar x}m^2. \end{align} The second and third terms in (\ref{EPA_617}) are negative definite (and subleading). Noting that $\bar x + x^2/2$ is bounded between $1/2$ and $1$, we derive that $f(x)$ is always smaller than \begin{equation} \bar f(x) = \frac{\alpha}{\pi}\,q_p^2\,\frac{L - 2\ln x}{x} \qquad\text{where}\qquad L = \ln\frac{\min(4E_{\rm max}^2,Q^2_{\rm max})}{\max(m^2,Q_{\rm min}^2)}, \end{equation} where we allow for explicit $Q$ bounds that narrow the kinematical range. Therefore, we generate this distribution: \begin{equation}\label{EPA-subst} \int_{x_0}^{x_1} dx\,\bar f(x) = C(x_0,x_1)\int_0^1 dx' \end{equation} We set \begin{equation}\label{EPA-x(x')} \ln x = \frac12\left\{ L - \sqrt{L^2 - 4\left[ x'\ln x_1(L-\ln x_1) + \bar x'\ln x_0(L-\ln x_0) \right]} \right\} \end{equation} such that $x(0)=x_0$ and $x(1)=x_1$ and \begin{equation} \frac{dx}{dx'} = \left(\frac{\alpha}{\pi} q_p^2 \right)^{-1} x\frac{C(x_0,x_1)}{L - 2\ln x} \end{equation} with \begin{equation} C(x_0,x_1) = \frac{\alpha}{\pi} q_p^2\,\left[\ln x_1(L-\ln x_1) - \ln x_0(L-\ln x_0)\right] \end{equation} such that (\ref{EPA-subst}) is satisfied. Finally, we have \begin{equation} \int_{x_0}^{x_1} dx\,f(x) = C(x_0,x_1)\int_0^1 dx'\, \frac{f(x(x'))}{\bar f(x(x'))} \end{equation} where $x'$ is calculated from $x$ via (\ref{EPA-x(x')}). The structure of the mapping is most obvious from: \begin{equation} x'(x) = \frac{\log x ( L - \log x) - \log x_0 (L - \log x_0)} {\log x_1 ( L - \log x_1) - \log x_0 (L - \log x_0)} \; . \end{equation} Taking the Eq. (6.16e) from the Budnev et al. report, and integrating it over $q^2$ yields the modified result \begin{equation} \label{EPA_616e} f(x) = \frac{\alpha}{\pi}\,q_p^2\, \frac{1}{x}\, \biggl[\left(\bar x + \frac{x^2}{2}\right) \ln\frac{Q^2_{\rm max}}{Q^2_{\rm min}} - x^2\frac{m^2}{Q^2_{\rm min}} \left(1 - \frac{Q^2_{\rm min}}{Q^2_{\rm max}}\right) \biggr]. \end{equation} This is closer to many standard papers from LEP times, and to textbook formulae like e.g. in Peskin/Schroeder. For historical reasons, we keep Eq.~(\ref{EPA_617}) as the default in \whizard. \subsection{The EPA data block} The EPA parameters are: $\alpha$, $E_{\rm max}$, $m$, $Q_{\rm min}$, and $x_{\rm min}$. Instead of $m$ we can use the incoming particle PDG code as input; from this we can deduce the mass and charge. Internally we store in addition $C_{0/1} = \frac{\alpha}{\pi}q_e^2\ln x_{0/1} (L - \ln x_{0/1})$, the c.m. energy squared and the incoming particle mass. <>= public :: EPA_MODE_DEFAULT public :: EPA_MODE_BUDNEV_617 public :: EPA_MODE_BUDNEV_616E public :: EPA_MODE_LOG_POWER public :: EPA_MODE_LOG_SIMPLE public :: EPA_MODE_LOG <>= integer, parameter :: EPA_MODE_DEFAULT = 0 integer, parameter :: EPA_MODE_BUDNEV_617 = 0 integer, parameter :: EPA_MODE_BUDNEV_616E = 1 integer, parameter :: EPA_MODE_LOG_POWER = 2 integer, parameter :: EPA_MODE_LOG_SIMPLE = 3 integer, parameter :: EPA_MODE_LOG = 4 @ %def EPA_MODE_DEFAULT EPA_MODE_BUDNEV_617 EPA_MODE_BUDNEV_616E @ %def EPA_MODE_LOG_POWER EPA_MODE_LOG_SIMPLE EPA_MODE_LOG @ <>= public :: epa_data_t <>= type, extends(sf_data_t) :: epa_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:), allocatable :: flv_in real(default) :: alpha real(default) :: x_min real(default) :: x_max real(default) :: q_min real(default) :: q_max real(default) :: E_max real(default) :: mass real(default) :: log real(default) :: a real(default) :: c0 real(default) :: c1 real(default) :: dc integer :: mode = EPA_MODE_DEFAULT integer :: error = NONE logical :: recoil = .false. logical :: keep_energy = .true. contains <> end type epa_data_t @ %def epa_data_t @ Error codes <>= integer, parameter :: NONE = 0 integer, parameter :: ZERO_QMIN = 1 integer, parameter :: Q_MAX_TOO_SMALL = 2 integer, parameter :: ZERO_XMIN = 3 integer, parameter :: MASS_MIX = 4 integer, parameter :: NO_EPA = 5 <>= procedure :: init => epa_data_init <>= subroutine epa_data_init (data, model, mode, pdg_in, alpha, & x_min, q_min, q_max, mass, recoil, keep_energy) class(epa_data_t), intent(inout) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in integer, intent(in) :: mode real(default), intent(in) :: alpha, x_min, q_min, q_max real(default), intent(in), optional :: mass logical, intent(in), optional :: recoil logical, intent(in), optional :: keep_energy integer :: n_flv, i data%model => model data%mode = mode n_flv = pdg_in%get_length () allocate (data%flv_in (n_flv)) do i = 1, n_flv call data%flv_in(i)%init (pdg_in%get (i), model) end do data%alpha = alpha data%E_max = q_max / 2 data%x_min = x_min data%x_max = 1 if (vanishes (data%x_min)) then data%error = ZERO_XMIN; return end if data%q_min = q_min data%q_max = q_max select case (char (data%model%get_name ())) case ("QCD","Test") data%error = NO_EPA; return end select if (present (recoil)) then data%recoil = recoil end if if (present (keep_energy)) then data%keep_energy = keep_energy end if if (present (mass)) then data%mass = mass else data%mass = data%flv_in(1)%get_mass () if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if if (max (data%mass, data%q_min) == 0) then data%error = ZERO_QMIN; return else if (max (data%mass, data%q_min) >= data%E_max) then data%error = Q_MAX_TOO_SMALL; return end if data%log = log ((data%q_max / max (data%mass, data%q_min)) ** 2 ) data%a = data%alpha / pi data%c0 = log (data%x_min) * (data%log - log (data%x_min)) data%c1 = log (data%x_max) * (data%log - log (data%x_max)) data%dc = data%c1 - data%c0 end subroutine epa_data_init @ %def epa_data_init @ Handle error conditions. Should always be done after initialization, unless we are sure everything is ok. <>= procedure :: check => epa_data_check <>= subroutine epa_data_check (data) class(epa_data_t), intent(in) :: data select case (data%error) case (NO_EPA) call msg_fatal ("EPA structure function not available for model " & // char (data%model%get_name ()) // ".") case (ZERO_QMIN) call msg_fatal ("EPA: Particle mass is zero") case (Q_MAX_TOO_SMALL) call msg_fatal ("EPA: Particle mass exceeds Qmax") case (ZERO_XMIN) call msg_fatal ("EPA: x_min must be larger than zero") case (MASS_MIX) call msg_fatal ("EPA: incoming particle masses must be uniform") end select end subroutine epa_data_check @ %def epa_data_check @ Output <>= procedure :: write => epa_data_write <>= subroutine epa_data_write (data, unit, verbose) class(epa_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "EPA data:" if (allocated (data%flv_in)) then write (u, "(3x,A)", advance="no") " flavor = " do i = 1, size (data%flv_in) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_in(i)%write (u) end do write (u, *) write (u, "(3x,A," // FMT_19 // ")") " alpha = ", data%alpha write (u, "(3x,A," // FMT_19 // ")") " x_min = ", data%x_min write (u, "(3x,A," // FMT_19 // ")") " x_max = ", data%x_max write (u, "(3x,A," // FMT_19 // ")") " q_min = ", data%q_min write (u, "(3x,A," // FMT_19 // ")") " q_max = ", data%q_max write (u, "(3x,A," // FMT_19 // ")") " E_max = ", data%e_max write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass write (u, "(3x,A," // FMT_19 // ")") " a = ", data%a write (u, "(3x,A," // FMT_19 // ")") " c0 = ", data%c0 write (u, "(3x,A," // FMT_19 // ")") " c1 = ", data%c1 write (u, "(3x,A," // FMT_19 // ")") " log = ", data%log write (u, "(3x,A,L2)") " recoil = ", data%recoil write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy else write (u, "(3x,A)") "[undefined]" end if end subroutine epa_data_write @ %def epa_data_write @ The number of kinematic parameters. <>= procedure :: get_n_par => epa_data_get_n_par <>= function epa_data_get_n_par (data) result (n) class(epa_data_t), intent(in) :: data integer :: n if (data%recoil) then n = 3 else n = 1 end if end function epa_data_get_n_par @ %def epa_data_get_n_par @ Return the outgoing particles PDG codes. The outgoing particle is always the photon while the radiated particle is identical to the incoming one. <>= procedure :: get_pdg_out => epa_data_get_pdg_out <>= subroutine epa_data_get_pdg_out (data, pdg_out) class(epa_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = PHOTON end subroutine epa_data_get_pdg_out @ %def epa_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => epa_data_allocate_sf_int <>= subroutine epa_data_allocate_sf_int (data, sf_int) class(epa_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (epa_t :: sf_int) end subroutine epa_data_allocate_sf_int @ %def epa_data_allocate_sf_int @ \subsection{The EPA object} The [[epa_t]] data type is a $1\to 2$ interaction. We should be able to handle several flavors in parallel, since EPA is not necessarily applied immediately after beam collision: Photons may be radiated from quarks. In that case, the partons are massless and $q_{\rm min}$ applies instead, so we do not need to generate several kinematical configurations in parallel. The squared charge values multiply the matrix elements, depending on the flavour. We scan the interaction after building it, so we have the correct assignments. The particles are ordered as (incoming, radiated, photon), where the photon initiates the hard interaction. We generate an unpolarized photon and transfer initial polarization to the radiated parton. Color is transferred in the same way. <>= type, extends (sf_int_t) :: epa_t type(epa_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: xb = 0 real(default) :: E = 0 real(default), dimension(:), allocatable :: charge2 contains <> end type epa_t @ %def epa_t @ Type string: has to be here, but there is no string variable on which EPA depends. Hence, a dummy routine. <>= procedure :: type_string => epa_type_string <>= function epa_type_string (object) result (string) class(epa_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "EPA: equivalent photon approx." else string = "EPA: [undefined]" end if end function epa_type_string @ %def epa_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => epa_write <>= subroutine epa_write (object, unit, testflag) class(epa_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A," // FMT_17 // ")") "E =", object%E end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "EPA data: [undefined]" end if end subroutine epa_write @ %def epa_write @ Prepare the interaction object. We have to construct transition matrix elements for all flavor and helicity combinations. <>= procedure :: init => epa_init <>= subroutine epa_init (sf_int, data) class(epa_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask integer, dimension(3) :: hel_lock type(polarization_t), target :: pol type(quantum_numbers_t), dimension(1) :: qn_fc type(flavor_t) :: flv_photon type(color_t) :: col_photon type(quantum_numbers_t) :: qn_hel, qn_photon, qn, qn_rad type(polarization_iterator_t) :: it_hel integer :: i mask = quantum_numbers_mask (.false., .false., & mask_h = [.false., .false., .true.]) hel_lock = [2, 1, 0] select type (data) type is (epa_data_t) call sf_int%base_init (mask, [data%mass**2], & [data%mass**2], [0._default], hel_lock = hel_lock) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col_photon%init () call qn_photon%init (flv_photon, col_photon) do i = 1, size (data%flv_in) call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) qn_rad = qn call qn_rad%tag_radiated () call sf_int%add_state ([qn, qn_rad, qn_photon]) call it_hel%advance () end do ! call pol%final () end do call sf_int%freeze () if (data%keep_energy) then sf_int%on_shell_mode = KEEP_ENERGY else sf_int%on_shell_mode = KEEP_MOMENTUM end if call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) end select end subroutine epa_init @ %def epa_init @ Prepare the charge array. This is separate from the previous routine since the state matrix may be helicity-contracted. <>= procedure :: setup_constants => epa_setup_constants <>= subroutine epa_setup_constants (sf_int) class(epa_t), intent(inout), target :: sf_int type(state_iterator_t) :: it type(flavor_t) :: flv integer :: i, n_me n_me = sf_int%get_n_matrix_elements () allocate (sf_int%charge2 (n_me)) call it%init (sf_int%interaction_t%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () flv = it%get_flavor (1) sf_int%charge2(i) = flv%get_charge () ** 2 call it%advance () end do sf_int%status = SF_INITIAL end subroutine epa_setup_constants @ %def epa_setup_constants @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. The EPA structure function allows for a straightforward mapping of the unit interval. The $x$ value is transformed, and the mapped structure function becomes unity at its upper boundary. The structure function implementation applies the above mapping to the input (random) number [[r]] to generate the momentum fraction [[x]] and the function value [[f]]. For numerical stability reasons, we also output [[xb]], which is $\bar x=1-x$. <>= procedure :: complete_kinematics => epa_complete_kinematics <>= subroutine epa_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default) :: delta, sqrt_delta, lx if (map) then associate (data => sf_int%data) delta = data%log ** 2 - 4 * (r(1) * data%c1 + rb(1) * data%c0) if (delta > 0) then sqrt_delta = sqrt (delta) lx = (data%log - sqrt_delta) / 2 else sf_int%status = SF_FAILED_KINEMATICS f = 0 return end if x(1) = exp (lx) f = x(1) * data%dc / sqrt_delta end associate else x(1) = r(1) if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then f = 1 else sf_int%status = SF_FAILED_KINEMATICS f = 0 return end if end if xb(1) = 1 - x(1) if (size(x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) sf_int%xb= xb(1) sf_int%E = energy (sf_int%get_momentum (1)) case (SF_FAILED_KINEMATICS) sf_int%x = 0 sf_int%xb= 0 f = 0 end select end subroutine epa_complete_kinematics @ %def epa_complete_kinematics @ Overriding the default method: we compute the [[x]] array from the momentum configuration. In the specific case of EPA, we also set the internally stored $x$ and $\bar x$ values, so they can be used in the following routine. Note: the extraction of $\bar x$ is not numerically safe, but it cannot be as long as the base [[recover_x]] is not. <>= procedure :: recover_x => sf_epa_recover_x <>= subroutine sf_epa_recover_x (sf_int, x, xb, x_free) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) sf_int%xb = xb(1) end subroutine sf_epa_recover_x @ %def sf_epa_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => epa_inverse_kinematics <>= subroutine epa_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: lx, delta, sqrt_delta, c logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then associate (data => sf_int%data) lx = log (x(1)) sqrt_delta = data%log - 2 * lx delta = sqrt_delta ** 2 c = (data%log ** 2 - delta) / 4 r (1) = (c - data%c0) / data%dc rb(1) = (data%c1 - c) / data%dc f = x(1) * data%dc / sqrt_delta end associate else r (1) = x(1) rb(1) = xb(1) if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then f = 1 else f = 0 end if end if if (size(r) == 3) then r (2:3) = x(2:3) rb(2:3) = xb(2:3) end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if sf_int%E = energy (sf_int%get_momentum (1)) end subroutine epa_inverse_kinematics @ %def epa_inverse_kinematics @ \subsection{EPA application} For EPA, we can in principle compute kinematics and function value in a single step. In order to be able to reweight events, kinematics and structure function application are separated. This function works on a single beam, assuming that the input momentum has been set. We need three random numbers as input: one for $x$, and two for the polar and azimuthal angles. Alternatively, for the no-recoil case, we can skip $p_T$ generation; in this case, we only need one. For obtaining splitting kinematics, we rely on the assumption that all in-particles are mass-degenerate (or there is only one), so the generated $x$ values are identical. Fix 2020-03-10: Divide by two if there is polarization. In the polarized case, the outgoing electron/positron retains the incoming polarization. The latter is summed over when convoluting with the beam, but there are still two states with different outgoing polarization but identical structure-function value. This leads to double-counting for the overall cross section. <>= procedure :: apply => epa_apply <>= subroutine epa_apply (sf_int, scale, negative_sf, rescale, i_sub) class(epa_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: x, xb, qminsq, qmaxsq, f, E, m2 associate (data => sf_int%data) x = sf_int%x xb= sf_int%xb E = sf_int%E m2 = data%mass ** 2 qminsq = max (x ** 2 / xb * data%mass ** 2, data%q_min ** 2) select case (data%mode) case (0) qmaxsq = min (4 * xb * E ** 2, data%q_max ** 2) if (qminsq < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / qminsq) & - (1 - x / 2) ** 2 & * log ((x**2 + qmaxsq / E ** 2) / (x**2 + qminsq / E ** 2)) & - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq)) else f = 0 end if case (1) qmaxsq = min (4 * xb * E ** 2, data%q_max ** 2) if (qminsq < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / qminsq) & - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq)) else f = 0 end if case (2) qmaxsq = data%q_max ** 2 if (data%mass ** 2 < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / m2) & - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq)) else f = 0 end if case (3) qmaxsq = data%q_max ** 2 if (data%mass ** 2 < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / m2) & - x ** 2 * (1 - m2 / qmaxsq)) else f = 0 end if case (4) qmaxsq = data%q_max ** 2 if (data%mass ** 2 < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / m2)) else f = 0 end if end select f = f / sf_int%get_n_matrix_elements () call sf_int%set_matrix_element & (cmplx (f, kind=default) * sf_int%charge2) end associate sf_int%status = SF_EVALUATED end subroutine epa_apply @ %def epa_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_epa_ut.f90]]>>= <> module sf_epa_ut use unit_tests use sf_epa_uti <> <> contains <> end module sf_epa_ut @ %def sf_epa_ut @ <<[[sf_epa_uti.f90]]>>= <> module sf_epa_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter - use interactions, only: interaction_pacify_momenta use model_data use sf_aux use sf_base use sf_epa <> <> contains <> end module sf_epa_uti @ %def sf_epa_ut @ API: driver for the unit tests below. <>= public :: sf_epa_test <>= subroutine sf_epa_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_epa_test @ %def sf_epa_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_epa_1, "sf_epa_1", & "structure function configuration", & u, results) <>= public :: sf_epa_1 <>= subroutine sf_epa_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_epa_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_qed_test () pdg_in = ELECTRON allocate (epa_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (epa_data_t) call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, & 10._default, 100._default, 0.000511_default, recoil = .false.) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_1" end subroutine sf_epa_1 @ %def sf_epa_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the EPA structure function. <>= call test (sf_epa_2, "sf_epa_2", & "structure function instance", & u, results) <>= public :: sf_epa_2 <>= subroutine sf_epa_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, & 10._default, 100._default, 0.000511_default, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EPA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_2" end subroutine sf_epa_2 @ %def sf_epa_2 @ \subsubsection{Standard mapping} Construct and display a structure function object based on the EPA structure function, applying the standard single-particle mapping. <>= call test (sf_epa_3, "sf_epa_3", & "apply mapping", & u, results) <>= public :: sf_epa_3 <>= subroutine sf_epa_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_3" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, & 10._default, 100._default, 0.000511_default, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, with EPA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_3" end subroutine sf_epa_3 @ %def sf_epa_3 @ \subsubsection{Non-collinear case} Construct and display a structure function object based on the EPA structure function. <>= call test (sf_epa_4, "sf_epa_4", & "non-collinear", & u, results) <>= public :: sf_epa_4 <>= subroutine sf_epa_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E, m real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_4" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, & 10._default, 100._default, 5.0_default, recoil = .true.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500, me = 5 GeV" write (u, "(A)") E = 500 m = 5 k = vector4_moving (E, sqrt (E**2 - m**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.5/0.5/0.25, with EPA mapping, " write (u, "(A)") " non-coll., keeping energy, me = 5 GeV" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.5_default, 0.5_default, 0.25_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) - call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) + call sf_int%pacify_momenta (1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x and r from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) - call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) + call sf_int%pacify_momenta (1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_4" end subroutine sf_epa_4 @ %def sf_epa_4 @ \subsubsection{Structure function for multiple flavors} Construct and display a structure function object based on the EPA structure function. The incoming state has multiple particles with non-uniform charge. <>= call test (sf_epa_5, "sf_epa_5", & "multiple flavors", & u, results) <>= public :: sf_epa_5 <>= subroutine sf_epa_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_5" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (1, model) pdg_in = [1, 2, -1, -2] call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, & 10._default, 100._default, 0.000511_default, recoil = .false.) call data%check () end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EPA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_5" end subroutine sf_epa_5 @ %def sf_epa_5 @ \clearpage %------------------------------------------------------------------------ \section{EWA} <<[[sf_ewa.f90]]>>= <> module sf_ewa <> <> use io_units use constants, only: pi use format_defs, only: FMT_17, FMT_19 use numeric_utils use diagnostics use physics_defs, only: W_BOSON, Z_BOSON use lorentz use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use interactions use sf_aux use sf_base <> <> <> <> contains <> end module sf_ewa @ %def sf_ewa @ \subsection{Physics} The EWA structure function for a $Z$ or $W$ inside a fermion (lepton or quark) depends on the vector-boson polarization. We distinguish transversal ($\pm$) and longitudinal ($0$) polarization. \begin{align} F_{+}(x) &= \frac{1}{16\pi^2}\,\frac{(v-a)^2 + (v+a)^2\bar x^2}{x} \left[ \ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right) - \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2} \right] \\ F_{-}(x) &= \frac{1}{16\pi^2}\,\frac{(v+a)^2 + (v-a)^2\bar x^2}{x} \left[ \ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right) - \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2} \right] \\ F_0(x) &= \frac{v^2+a^2}{8\pi^2}\,\frac{2\bar x}{x}\, \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2} \end{align} where $p_{\perp,\textrm{max}}$ is the cutoff in transversal momentum, $M$ is the vector-boson mass, $v$ and $a$ are the vector and axial-vector couplings, and $\bar x\equiv 1-x$. Note that the longitudinal structure function is finite for large cutoff, while the transversal structure function is logarithmically divergent. The maximal transverse momentum is given by the kinematical limit, it is \begin{equation} p_{\perp,\textrm{max}} = \bar x \sqrt{s}/2. \end{equation} The vector and axial couplings for a fermion branching into a $W$ are \begin{align} v_W &= \frac{g}{2\sqrt 2}, & a_W &= \frac{g}{2\sqrt 2}. \end{align} For $Z$ emission, this is replaced by \begin{align} v_Z &= \frac{g}{2\cos\theta_w}\left(t_3 - 2q\sin^2\theta_w\right), & a_Z &= \frac{g}{2\cos\theta_w}t_3, \end{align} where $t_3=\pm\frac12$ is the fermion isospin, and $q$ its charge. For an initial antifermion, the signs of the axial couplings are inverted. Note that a common sign change of $v$ and $a$ is irrelevant. %% Differentiating with respect to the cutoff, we get structure functions %% \begin{align} %% f_{W,\pm}(x,p_T) &= \frac{g^2}{16\pi^2}\, %% \frac{1+\bar x^2}{x} %% \frac{p_\perp}{p_\perp^2 + \bar x M^2} %% \\ %% f_{W,0}(x,p_T) &= \frac{g^2}{16\pi^2}\, %% \frac{2\bar x}{x}\, %% \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2} %% \\ %% F_{Z,\pm}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2} %% \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\, %% \frac{1+\bar x^2}{x} %% \frac{p_\perp}{p_\perp^2 + \bar x M^2} %% \\ %% F_{Z,0}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2}\, %% \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\, %% \frac{2\bar x}{x}\, %% \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2} %% \end{align} %% Here, $t_3^f$ is the $SU(2)_L$ quantum number of the fermion %% $(\pm\frac12)$, and $q^f$ is the fermion charge in units of the %% positron charge. The EWA depends on the parameters $g$, $\sin^2\theta_w$, $M_W$, and $M_Z$. These can all be taken from the SM input, and the prefactors are calculated from those and the incoming particle type. Since these structure functions have a $1/x$ singularity (which is not really relevant in practice, however, since the vector boson mass is finite), we map this singularity allowing for nontrivial $x$ bounds: \begin{equation} x = \exp(\bar r\ln x_0 + r\ln x_1) \end{equation} such that \begin{equation} \int_{x_0}^{x_1}\frac{dx}{x} = (\ln x_1 - \ln x_0)\int_0^1 dr. \end{equation} As a user parameter, we have the cutoff $p_{\perp,\textrm{max}}$. The divergence $1/x$ also requires a $x_0$ cutoff; and for completeness we introduce a corresponding $x_1$. Physically, the minimal sensible value of $x$ is $M^2/s$, although the approximation loses its value already at higher $x$ values. \subsection{The EWA data block} The EWA parameters are: $p_{T,\rm max}$, $c_V$, $c_A$, and $m$. Instead of $m$ we can use the incoming particle PDG code as input; from this we can deduce the mass and charges. In the initialization phase it is not yet determined whether a $W$ or a $Z$ is radiated, hence we set the vector and axial-vector couplings equal to the common prefactors $g/2 = e/2/\sin\theta_W$. In principle, for EWA it would make sense to allow the user to also set the upper bound for $x$, $x_{\rm max}$, but we fix it to one here. <>= public :: ewa_data_t <>= type, extends(sf_data_t) :: ewa_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:), allocatable :: flv_in type(flavor_t), dimension(:), allocatable :: flv_out real(default) :: pt_max real(default) :: sqrts real(default) :: x_min real(default) :: x_max real(default) :: mass real(default) :: m_out real(default) :: q_min real(default) :: cv real(default) :: ca real(default) :: costhw real(default) :: sinthw real(default) :: mW real(default) :: mZ real(default) :: coeff logical :: mass_set = .false. logical :: recoil = .false. logical :: keep_energy = .false. integer :: id = 0 integer :: error = NONE contains <> end type ewa_data_t @ %def ewa_data_t @ Error codes <>= integer, parameter :: NONE = 0 integer, parameter :: ZERO_QMIN = 1 integer, parameter :: Q_MAX_TOO_SMALL = 2 integer, parameter :: ZERO_XMIN = 3 integer, parameter :: MASS_MIX = 4 integer, parameter :: ZERO_SW = 5 integer, parameter :: ISOSPIN_MIX = 6 integer, parameter :: WRONG_PRT = 7 integer, parameter :: MASS_MIX_OUT = 8 integer, parameter :: NO_EWA = 9 <>= procedure :: init => ewa_data_init <>= subroutine ewa_data_init (data, model, pdg_in, x_min, pt_max, & sqrts, recoil, keep_energy, mass) class(ewa_data_t), intent(inout) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in real(default), intent(in) :: x_min, pt_max, sqrts logical, intent(in) :: recoil, keep_energy real(default), intent(in), optional :: mass real(default) :: g, ee integer :: n_flv, i data%model => model if (.not. any (pdg_in .match. & [1,2,3,4,5,6,11,13,15,-1,-2,-3,-4,-5,-6,-11,-13,-15])) then data%error = WRONG_PRT; return end if n_flv = pdg_in%get_length () allocate (data%flv_in (n_flv)) allocate (data%flv_out(n_flv)) do i = 1, n_flv call data%flv_in(i)%init (pdg_in%get (i), model) end do data%pt_max = pt_max data%sqrts = sqrts data%x_min = x_min data%x_max = 1 if (vanishes (data%x_min)) then data%error = ZERO_XMIN; return end if select case (char (data%model%get_name ())) case ("QCD","QED","Test") data%error = NO_EWA; return end select ee = data%model%get_real (var_str ("ee")) data%sinthw = data%model%get_real (var_str ("sw")) data%costhw = data%model%get_real (var_str ("cw")) data%mZ = data%model%get_real (var_str ("mZ")) data%mW = data%model%get_real (var_str ("mW")) if (data%sinthw /= 0) then g = ee / data%sinthw else data%error = ZERO_SW; return end if data%cv = g / 2._default data%ca = g / 2._default data%coeff = 1._default / (8._default * PI**2) data%recoil = recoil data%keep_energy = keep_energy if (present (mass)) then data%mass = mass data%m_out = mass data%mass_set = .true. else data%mass = data%flv_in(1)%get_mass () if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if end subroutine ewa_data_init @ %def ewa_data_init @ Set the vector boson ID for distinguishing $W$ and $Z$ bosons. <>= procedure :: set_id => ewa_set_id <>= subroutine ewa_set_id (data, id) class(ewa_data_t), intent(inout) :: data integer, intent(in) :: id integer :: i, isospin, pdg if (.not. allocated (data%flv_in)) & call msg_bug ("EWA: incoming particles not set") data%id = id select case (data%id) case (23) data%m_out = data%mass data%flv_out = data%flv_in case (24) do i = 1, size (data%flv_in) pdg = data%flv_in(i)%get_pdg () isospin = data%flv_in(i)%get_isospin_type () if (isospin > 0) then !!! up-type quark or neutrinos if (data%flv_in(i)%is_antiparticle ()) then call data%flv_out(i)%init (pdg + 1, data%model) else call data%flv_out(i)%init (pdg - 1, data%model) end if else !!! down-type quark or lepton if (data%flv_in(i)%is_antiparticle ()) then call data%flv_out(i)%init (pdg - 1, data%model) else call data%flv_out(i)%init (pdg + 1, data%model) end if end if end do if (.not. data%mass_set) then data%m_out = data%flv_out(1)%get_mass () if (any (data%flv_out%get_mass () /= data%m_out)) then data%error = MASS_MIX_OUT; return end if end if end select end subroutine ewa_set_id @ %def ewa_set_id @ Handle error conditions. Should always be done after initialization, unless we are sure everything is ok. <>= procedure :: check => ewa_data_check <>= subroutine ewa_data_check (data) class(ewa_data_t), intent(in) :: data select case (data%error) case (WRONG_PRT) call msg_fatal ("EWA structure function only accessible for " & // "SM quarks and leptons.") case (NO_EWA) call msg_fatal ("EWA structure function not available for model " & // char (data%model%get_name ())) case (ZERO_SW) call msg_fatal ("EWA: Vanishing value of sin(theta_w)") case (ZERO_QMIN) call msg_fatal ("EWA: Particle mass is zero") case (Q_MAX_TOO_SMALL) call msg_fatal ("EWA: Particle mass exceeds Qmax") case (ZERO_XMIN) call msg_fatal ("EWA: x_min must be larger than zero") case (MASS_MIX) call msg_fatal ("EWA: incoming particle masses must be uniform") case (MASS_MIX_OUT) call msg_fatal ("EWA: outgoing particle masses must be uniform") case (ISOSPIN_MIX) call msg_fatal ("EWA: incoming particle isospins must be uniform") end select end subroutine ewa_data_check @ %def ewa_data_check @ Output <>= procedure :: write => ewa_data_write <>= subroutine ewa_data_write (data, unit, verbose) class(ewa_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "EWA data:" if (allocated (data%flv_in) .and. allocated (data%flv_out)) then write (u, "(3x,A)", advance="no") " flavor(in) = " do i = 1, size (data%flv_in) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_in(i)%write (u) end do write (u, *) write (u, "(3x,A)", advance="no") " flavor(out) = " do i = 1, size (data%flv_out) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_out(i)%write (u) end do write (u, *) write (u, "(3x,A," // FMT_19 // ")") " x_min = ", data%x_min write (u, "(3x,A," // FMT_19 // ")") " x_max = ", data%x_max write (u, "(3x,A," // FMT_19 // ")") " pt_max = ", data%pt_max write (u, "(3x,A," // FMT_19 // ")") " sqrts = ", data%sqrts write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass write (u, "(3x,A," // FMT_19 // ")") " cv = ", data%cv write (u, "(3x,A," // FMT_19 // ")") " ca = ", data%ca write (u, "(3x,A," // FMT_19 // ")") " coeff = ", data%coeff write (u, "(3x,A," // FMT_19 // ")") " costhw = ", data%costhw write (u, "(3x,A," // FMT_19 // ")") " sinthw = ", data%sinthw write (u, "(3x,A," // FMT_19 // ")") " mZ = ", data%mZ write (u, "(3x,A," // FMT_19 // ")") " mW = ", data%mW write (u, "(3x,A,L2)") " recoil = ", data%recoil write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy write (u, "(3x,A,I2)") " PDG (VB) = ", data%id else write (u, "(3x,A)") "[undefined]" end if end subroutine ewa_data_write @ %def ewa_data_write @ The number of parameters is one for collinear splitting, in case the [[recoil]] option is set, we take the recoil into account. <>= procedure :: get_n_par => ewa_data_get_n_par <>= function ewa_data_get_n_par (data) result (n) class(ewa_data_t), intent(in) :: data integer :: n if (data%recoil) then n = 3 else n = 1 end if end function ewa_data_get_n_par @ %def ewa_data_get_n_par @ Return the outgoing particles PDG codes. This depends, whether this is a charged-current or neutral-current interaction. <>= procedure :: get_pdg_out => ewa_data_get_pdg_out <>= subroutine ewa_data_get_pdg_out (data, pdg_out) class(ewa_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer, dimension(:), allocatable :: pdg1 integer :: i, n_flv if (allocated (data%flv_out)) then n_flv = size (data%flv_out) else n_flv = 0 end if allocate (pdg1 (n_flv)) do i = 1, n_flv pdg1(i) = data%flv_out(i)%get_pdg () end do pdg_out(1) = pdg1 end subroutine ewa_data_get_pdg_out @ %def ewa_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => ewa_data_allocate_sf_int <>= subroutine ewa_data_allocate_sf_int (data, sf_int) class(ewa_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (ewa_t :: sf_int) end subroutine ewa_data_allocate_sf_int @ %def ewa_data_allocate_sf_int @ \subsection{The EWA object} The [[ewa_t]] data type is a $1\to 2$ interaction. We should be able to handle several flavors in parallel, since EWA is not necessarily applied immediately after beam collision: $W/Z$ bosons may be radiated from quarks. In that case, the partons are massless and $q_{\rm min}$ applies instead, so we do not need to generate several kinematical configurations in parallel. The particles are ordered as (incoming, radiated, W/Z), where the W/Z initiates the hard interaction. In the case of EPA, we generated an unpolarized photon and transferred initial polarization to the radiated parton. Color is transferred in the same way. I do not know whether the same can/should be done for EWA, as the structure functions depend on the W/Z polarization. If we are having $Z$ bosons, both up- and down-type fermions can participate. Otherwise, with a $W^+$ an up-type fermion is transferred to a down-type fermion, and the other way round. <>= type, extends (sf_int_t) :: ewa_t type(ewa_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: xb = 0 integer :: n_me = 0 real(default), dimension(:), allocatable :: cv real(default), dimension(:), allocatable :: ca contains <> end type ewa_t @ %def ewa_t @ Type string: has to be here, but there is no string variable on which EWA depends. Hence, a dummy routine. <>= procedure :: type_string => ewa_type_string <>= function ewa_type_string (object) result (string) class(ewa_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "EWA: equivalent W/Z approx." else string = "EWA: [undefined]" end if end function ewa_type_string @ %def ewa_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => ewa_write <>= subroutine ewa_write (object, unit, testflag) class(ewa_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x write (u, "(3x,A," // FMT_17 // ")") "xb=", object%xb end if call object%base_write (u, testflag) else write (u, "(1x,A)") "EWA data: [undefined]" end if end subroutine ewa_write @ %def ewa_write @ The current implementation requires uniform isospin for all incoming particles, therefore we need to probe only the first one. <>= procedure :: init => ewa_init <>= subroutine ewa_init (sf_int, data) class(ewa_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask integer, dimension(3) :: hel_lock type(polarization_t), target :: pol type(quantum_numbers_t), dimension(1) :: qn_fc, qn_fc_fin type(flavor_t) :: flv_z, flv_wp, flv_wm type(color_t) :: col0 type(quantum_numbers_t) :: qn_hel, qn_z, qn_wp, qn_wm, qn, qn_rad, qn_w type(polarization_iterator_t) :: it_hel integer :: i, isospin select type (data) type is (ewa_data_t) mask = quantum_numbers_mask (.false., .false., & mask_h = [.false., .false., .true.]) hel_lock = [2, 1, 0] call col0%init () select case (data%id) case (23) !!! Z boson, flavor is not changing call sf_int%base_init (mask, [data%mass**2], [data%mass**2], & [data%mZ**2], hel_lock = hel_lock) sf_int%data => data call flv_z%init (Z_BOSON, data%model) call qn_z%init (flv_z, col0) do i = 1, size (data%flv_in) call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) qn_rad = qn call qn_rad%tag_radiated () call sf_int%add_state ([qn, qn_rad, qn_z]) call it_hel%advance () end do ! call pol%final () end do case (24) call sf_int%base_init (mask, [data%mass**2], [data%m_out**2], & [data%mW**2], hel_lock = hel_lock) sf_int%data => data call flv_wp%init (W_BOSON, data%model) call flv_wm%init (- W_BOSON, data%model) call qn_wp%init (flv_wp, col0) call qn_wm%init (flv_wm, col0) do i = 1, size (data%flv_in) isospin = data%flv_in(i)%get_isospin_type () if (isospin > 0) then !!! up-type quark or neutrinos if (data%flv_in(i)%is_antiparticle ()) then qn_w = qn_wm else qn_w = qn_wp end if else !!! down-type quark or lepton if (data%flv_in(i)%is_antiparticle ()) then qn_w = qn_wp else qn_w = qn_wm end if end if call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call qn_fc_fin(1)%init ( & flv = data%flv_out(i), & col = color_from_flavor (data%flv_out(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) qn_rad = qn_hel .merge. qn_fc_fin(1) call qn_rad%tag_radiated () call sf_int%add_state ([qn, qn_rad, qn_w]) call it_hel%advance () end do ! call pol%final () end do case default call msg_fatal ("EWA initialization failed: wrong particle type.") end select call sf_int%freeze () if (data%keep_energy) then sf_int%on_shell_mode = KEEP_ENERGY else sf_int%on_shell_mode = KEEP_MOMENTUM end if call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) end select end subroutine ewa_init @ %def ewa_init @ Prepare the coupling arrays. This is separate from the previous routine since the state matrix may be helicity-contracted. <>= procedure :: setup_constants => ewa_setup_constants <>= subroutine ewa_setup_constants (sf_int) class(ewa_t), intent(inout), target :: sf_int type(state_iterator_t) :: it type(flavor_t) :: flv real(default) :: q, t3 integer :: i sf_int%n_me = sf_int%get_n_matrix_elements () allocate (sf_int%cv (sf_int%n_me)) allocate (sf_int%ca (sf_int%n_me)) associate (data => sf_int%data) select case (data%id) case (23) call it%init (sf_int%interaction_t%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () flv = it%get_flavor (1) q = flv%get_charge () t3 = flv%get_isospin () if (flv%is_antiparticle ()) then sf_int%cv(i) = - data%cv & * (t3 - 2._default * q * data%sinthw**2) / data%costhw sf_int%ca(i) = data%ca * t3 / data%costhw else sf_int%cv(i) = data%cv & * (t3 - 2._default * q * data%sinthw**2) / data%costhw sf_int%ca(i) = data%ca * t3 / data%costhw end if call it%advance () end do case (24) call it%init (sf_int%interaction_t%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () flv = it%get_flavor (1) if (flv%is_antiparticle ()) then sf_int%cv(i) = data%cv / sqrt(2._default) sf_int%ca(i) = - data%ca / sqrt(2._default) else sf_int%cv(i) = data%cv / sqrt(2._default) sf_int%ca(i) = data%ca / sqrt(2._default) end if call it%advance () end do end select end associate sf_int%status = SF_INITIAL end subroutine ewa_setup_constants @ %def ewa_setup_constants @ \subsection{Kinematics} Set kinematics. The EWA structure function allows for a straightforward mapping of the unit interval. So, to leading order, the structure function value is unity, but the $x$ value is transformed. Higher orders affect the function value. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, the exponential mapping for the $1/x$ singularity discussed above is applied. <>= procedure :: complete_kinematics => ewa_complete_kinematics <>= subroutine ewa_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default) :: e_1 real(default) :: x0, x1, lx0, lx1, lx e_1 = energy (sf_int%get_momentum (1)) if (sf_int%data%recoil) then select case (sf_int%data%id) case (23) x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1) case (24) x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1) end select else x0 = sf_int%data%x_min end if x1 = sf_int%data%x_max if ( x0 >= x1) then f = 0 sf_int%status = SF_FAILED_KINEMATICS return end if if (map) then lx0 = log (x0) lx1 = log (x1) lx = lx1 * r(1) + lx0 * rb(1) x(1) = exp(lx) f = x(1) * (lx1 - lx0) else x(1) = r(1) if (x0 < x(1) .and. x(1) < x1) then f = 1 else sf_int%status = SF_FAILED_KINEMATICS f = 0 return end if end if xb(1) = 1 - x(1) if (size(x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) sf_int%xb = xb(1) case (SF_FAILED_KINEMATICS) sf_int%x = 0 sf_int%xb = 0 f = 0 end select end subroutine ewa_complete_kinematics @ %def ewa_complete_kinematics @ Overriding the default method: we compute the [[x]] array from the momentum configuration. In the specific case of EWA, we also set the internally stored $x$ and $\bar x$ values, so they can be used in the following routine. <>= procedure :: recover_x => sf_ewa_recover_x <>= subroutine sf_ewa_recover_x (sf_int, x, xb, x_free) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) sf_int%xb = xb(1) end subroutine sf_ewa_recover_x @ %def sf_ewa_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => ewa_inverse_kinematics <>= subroutine ewa_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: x0, x1, lx0, lx1, lx, e_1 logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta e_1 = energy (sf_int%get_momentum (1)) if (sf_int%data%recoil) then select case (sf_int%data%id) case (23) x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1) case (24) x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1) end select else x0 = sf_int%data%x_min end if x1 = sf_int%data%x_max if (map) then lx0 = log (x0) lx1 = log (x1) lx = log (x(1)) r(1) = (lx - lx0) / (lx1 - lx0) rb(1) = (lx1 - lx) / (lx1 - lx0) f = x(1) * (lx1 - lx0) else r (1) = x(1) rb(1) = 1 - x(1) if (x0 < x(1) .and. x(1) < x1) then f = 1 else f = 0 end if end if if (size(r) == 3) then r (2:3) = x(2:3) rb(2:3) = xb(2:3) end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine ewa_inverse_kinematics @ %def ewa_inverse_kinematics @ \subsection{EWA application} For EWA, we can compute kinematics and function value in a single step. This function works on a single beam, assuming that the input momentum has been set. We need four random numbers as input: one for $x$, one for $Q^2$, and two for the polar and azimuthal angles. Alternatively, we can skip $p_T$ generation; in this case, we only need one. For obtaining splitting kinematics, we rely on the assumption that all in-particles are mass-degenerate (or there is only one), so the generated $x$ values are identical. <>= procedure :: apply => ewa_apply <>= subroutine ewa_apply (sf_int, scale, negative_sf, rescale, i_sub) class(ewa_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: x, xb, pt2, c1, c2 real(default) :: cv, ca real(default) :: f, fm, fp, fL integer :: i associate (data => sf_int%data) x = sf_int%x xb = sf_int%xb pt2 = min ((data%pt_max)**2, (xb * data%sqrts / 2)**2) select case (data%id) case (23) !!! Z boson structure function c1 = log (1 + pt2 / (xb * (data%mZ)**2)) c2 = 1 / (1 + (xb * (data%mZ)**2) / pt2) case (24) !!! W boson structure function c1 = log (1 + pt2 / (xb * (data%mW)**2)) c2 = 1 / (1 + (xb * (data%mW)**2) / pt2) end select do i = 1, sf_int%n_me cv = sf_int%cv(i) ca = sf_int%ca(i) fm = data%coeff * & ((cv + ca)**2 + ((cv - ca) * xb)**2) * (c1 - c2) / (2 * x) fp = data%coeff * & ((cv - ca)**2 + ((cv + ca) * xb)**2) * (c1 - c2) / (2 * x) fL = data%coeff * & (cv**2 + ca**2) * (2 * xb / x) * c2 f = fp + fm + fL if (.not. vanishes (f)) then fp = fp / f fm = fm / f fL = fL / f end if call sf_int%set_matrix_element (i, cmplx (f, kind=default)) end do end associate sf_int%status = SF_EVALUATED end subroutine ewa_apply @ %def ewa_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_ewa_ut.f90]]>>= <> module sf_ewa_ut use unit_tests use sf_ewa_uti <> <> contains <> end module sf_ewa_ut @ %def sf_ewa_ut @ <<[[sf_ewa_uti.f90]]>>= <> module sf_ewa_uti <> use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter - use interactions, only: interaction_pacify_momenta use model_data use sf_aux use sf_base use sf_ewa <> <> contains <> end module sf_ewa_uti @ %def sf_ewa_ut @ API: driver for the unit tests below. <>= public :: sf_ewa_test <>= subroutine sf_ewa_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_ewa_test @ %def sf_ewa_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_ewa_1, "sf_ewa_1", & "structure function configuration", & u, results) <>= public :: sf_ewa_1 <>= subroutine sf_ewa_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_ewa_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_sm_test () pdg_in = 2 allocate (ewa_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize for Z boson" write (u, "(A)") select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 5000._default, .false., .false.) call data%set_id (23) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 write (u, "(A)") write (u, "(A)") "* Initialize for W boson" write (u, "(A)") deallocate (data) allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 5000._default, .false., .false.) call data%set_id (24) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_1" end subroutine sf_ewa_1 @ %def sf_ewa_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the EWA structure function. <>= call test (sf_ewa_2, "sf_ewa_2", & "structure function instance", & u, results) <>= public :: sf_ewa_2 <>= subroutine sf_ewa_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (2, model) pdg_in = 2 call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000._default, .false., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EWA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_2" end subroutine sf_ewa_2 @ %def sf_ewa_2 @ \subsubsection{Standard mapping} Construct and display a structure function object based on the EWA structure function, applying the standard single-particle mapping. <>= call test (sf_ewa_3, "sf_ewa_3", & "apply mapping", & u, results) <>= public :: sf_ewa_3 <>= subroutine sf_ewa_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_3" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (2, model) pdg_in = 2 call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000._default, .false., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, with EWA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_3" end subroutine sf_ewa_3 @ %def sf_ewa_3 @ \subsubsection{Non-collinear case} Construct and display a structure function object based on the EPA structure function. <>= call test (sf_ewa_4, "sf_ewa_4", & "non-collinear", & u, results) <>= public :: sf_ewa_4 <>= subroutine sf_ewa_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_4" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call modeL%init_sm_test () call flv%init (2, model) pdg_in = 2 call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000.0_default, .true., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.5/0.5/0.25, with EWA mapping, " write (u, "(A)") " non-coll., keeping energy" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.5_default, 0.5_default, 0.25_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) - call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) + call sf_int%pacify_momenta (1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x and r from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) - call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) + call sf_int%pacify_momenta (1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 1500._default) call sf_int%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_4" end subroutine sf_ewa_4 @ %def sf_ewa_4 @ \subsubsection{Structure function for multiple flavors} Construct and display a structure function object based on the EWA structure function. The incoming state has multiple particles with non-uniform quantum numbers. <>= call test (sf_ewa_5, "sf_ewa_5", & "structure function instance", & u, results) <>= public :: sf_ewa_5 <>= subroutine sf_ewa_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_5" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (2, model) pdg_in = [1, 2, -1, -2] call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000._default, .false., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EWA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_5" end subroutine sf_ewa_5 @ %def sf_ewa_5 @ \clearpage %------------------------------------------------------------------------ \section{Energy-scan spectrum} This spectrum is actually a trick that allows us to plot the c.m.\ energy dependence of a cross section without scanning the input energy. We start with the observation that a spectrum $f(x)$, applied to one of the incoming beams only, results in a cross section \begin{equation} \sigma = \int dx\,f(x)\,\hat\sigma(xs). \end{equation} We want to compute the distribution of $E=\sqrt{\hat s}=\sqrt{xs}$, i.e., \begin{equation} \frac{d\sigma}{dE} = \frac{2\sqrt{x}}{\sqrt{s}}\,\frac{d\sigma}{dx} = \frac{2\sqrt{x}}{\sqrt{s}}\,f(x)\,\hat\sigma(xs), \end{equation} so if we set \begin{equation} f(x) = \frac{\sqrt{s}}{2\sqrt{x}}, \end{equation} we get the distribution \begin{equation} \frac{d\sigma}{dE} = \hat\sigma(\hat s=E^2). \end{equation} We implement this as a spectrum with a single parameter $x$. The parameters for the individual beams are computed as $x_i=\sqrt{x}$, so they are equal and the kinematics is always symmetric. <<[[sf_escan.f90]]>>= <> module sf_escan <> <> use io_units use format_defs, only: FMT_12 use numeric_utils use diagnostics use lorentz use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use sf_base <> <> <> contains <> end module sf_escan @ %def sf_escan @ \subsection{Data type} The [[norm]] is unity if the total cross section should be normalized to one, and $\sqrt{s}$ if it should be normalized to the total energy. In the latter case, the differential distribution $d\sigma/d\sqrt{\hat s}$ coincides with the partonic cross section $\hat\sigma$ as a function of $\sqrt{\hat s}$. <>= public :: escan_data_t <>= type, extends(sf_data_t) :: escan_data_t private type(flavor_t), dimension(:,:), allocatable :: flv_in integer, dimension(2) :: n_flv = 0 real(default) :: norm = 1 contains <> end type escan_data_t @ %def escan_data_t <>= procedure :: init => escan_data_init <>= subroutine escan_data_init (data, model, pdg_in, norm) class(escan_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in), optional :: norm real(default), dimension(2) :: m2 integer :: i, j data%n_flv = pdg_in%get_length () allocate (data%flv_in (maxval (data%n_flv), 2)) do i = 1, 2 do j = 1, data%n_flv(i) call data%flv_in(j, i)%init (pdg_in(i)%get (j), model) end do end do m2 = data%flv_in(1,:)%get_mass () do i = 1, 2 if (.not. any (nearly_equal (data%flv_in(1:data%n_flv(i),i)%get_mass (), m2(i)))) then call msg_fatal ("Energy scan: incoming particle mass must be uniform") end if end do if (present (norm)) data%norm = norm end subroutine escan_data_init @ %def escan_data_init @ Output <>= procedure :: write => escan_data_write <>= subroutine escan_data_write (data, unit, verbose) class(escan_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i, j u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Energy-scan data:" write (u, "(3x,A)", advance="no") "prt_in = " do i = 1, 2 if (i > 1) write (u, "(',',1x)", advance="no") do j = 1, data%n_flv(i) if (j > 1) write (u, "(':')", advance="no") write (u, "(A)", advance="no") char (data%flv_in(j,i)%get_name ()) end do end do write (u, *) write (u, "(3x,A," // FMT_12 // ")") "norm =", data%norm end subroutine escan_data_write @ %def escan_data_write @ Kinematics is completely collinear, hence there is only one parameter for a pair spectrum. <>= procedure :: get_n_par => escan_data_get_n_par <>= function escan_data_get_n_par (data) result (n) class(escan_data_t), intent(in) :: data integer :: n n = 1 end function escan_data_get_n_par @ %def escan_data_get_n_par @ Return the outgoing particles PDG codes. This is always the same as the incoming particle, where we use two indices for the two beams. <>= procedure :: get_pdg_out => escan_data_get_pdg_out <>= subroutine escan_data_get_pdg_out (data, pdg_out) class(escan_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%flv_in(1:data%n_flv(i),i)%get_pdg () end do end subroutine escan_data_get_pdg_out @ %def escan_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => escan_data_allocate_sf_int <>= subroutine escan_data_allocate_sf_int (data, sf_int) class(escan_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (escan_t :: sf_int) end subroutine escan_data_allocate_sf_int @ %def escan_data_allocate_sf_int @ \subsection{The Energy-scan object} This is a spectrum, not a radiation. We create an interaction with two incoming and two outgoing particles, flavor, color, and helicity being carried through. $x$ nevertheless is only one-dimensional, as we are always using only one beam parameter. <>= type, extends (sf_int_t) :: escan_t type(escan_data_t), pointer :: data => null () contains <> end type escan_t @ %def escan_t @ Type string: for the energy scan this is just a dummy function. <>= procedure :: type_string => escan_type_string <>= function escan_type_string (object) result (string) class(escan_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "Escan: energy scan" else string = "Escan: [undefined]" end if end function escan_type_string @ %def escan_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => escan_write <>= subroutine escan_write (object, unit, testflag) class(escan_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "Energy scan data: [undefined]" end if end subroutine escan_write @ %def escan_write @ <>= procedure :: init => escan_init <>= subroutine escan_init (sf_int, data) class(escan_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(4) :: mask integer, dimension(4) :: hel_lock real(default), dimension(2) :: m2 real(default), dimension(0) :: mr2 type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn type(polarization_t), target :: pol1, pol2 type(polarization_iterator_t) :: it_hel1, it_hel2 integer :: j1, j2 select type (data) type is (escan_data_t) hel_lock = [3, 4, 1, 2] m2 = data%flv_in(1,:)%get_mass () call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock) sf_int%data => data do j1 = 1, data%n_flv(1) call qn_fc(1)%init ( & flv = data%flv_in(j1,1), & col = color_from_flavor (data%flv_in(j1,1))) call qn_fc(3)%init ( & flv = data%flv_in(j1,1), & col = color_from_flavor (data%flv_in(j1,1))) call pol1%init_generic (data%flv_in(j1,1)) do j2 = 1, data%n_flv(2) call qn_fc(2)%init ( & flv = data%flv_in(j2,2), & col = color_from_flavor (data%flv_in(j2,2))) call qn_fc(4)%init ( & flv = data%flv_in(j2,2), & col = color_from_flavor (data%flv_in(j2,2))) call pol2%init_generic (data%flv_in(j2,2)) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel(1) = it_hel1%get_quantum_numbers () qn_hel(3) = it_hel1%get_quantum_numbers () call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel(2) = it_hel2%get_quantum_numbers () qn_hel(4) = it_hel2%get_quantum_numbers () qn = qn_hel .merge. qn_fc call sf_int%add_state (qn) call it_hel2%advance () end do call it_hel1%advance () end do ! call pol2%final () end do ! call pol1%final () end do call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%freeze () sf_int%status = SF_INITIAL end select end subroutine escan_init @ %def escan_init @ \subsection{Kinematics} Set kinematics. We have a single parameter, but reduce both beams. The [[map]] flag is ignored. <>= procedure :: complete_kinematics => escan_complete_kinematics <>= subroutine escan_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default) :: sqrt_x real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map x = r xb= rb sqrt_x = sqrt (x(1)) if (sqrt_x > 0) then f = 1 / (2 * sqrt_x) else f = 0 sf_int%status = SF_FAILED_KINEMATICS return end if call sf_int%reduce_momenta ([sqrt_x, sqrt_x]) end subroutine escan_complete_kinematics @ %def escan_complete_kinematics @ Recover $x$. The base procedure should return two momentum fractions for the two beams, while we have only one parameter. This is the product of the extracted momentum fractions. <>= procedure :: recover_x => escan_recover_x <>= subroutine escan_recover_x (sf_int, x, xb, x_free) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: xi, xib call sf_int%base_recover_x (xi, xib, x_free) x = product (xi) xb= 1 - x end subroutine escan_recover_x @ %def escan_recover_x @ Compute inverse kinematics. <>= procedure :: inverse_kinematics => escan_inverse_kinematics <>= subroutine escan_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: sqrt_x logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta sqrt_x = sqrt (x(1)) if (sqrt_x > 0) then f = 1 / (2 * sqrt_x) else f = 0 sf_int%status = SF_FAILED_KINEMATICS return end if r = x rb = xb if (set_mom) then call sf_int%reduce_momenta ([sqrt_x, sqrt_x]) end if end subroutine escan_inverse_kinematics @ %def escan_inverse_kinematics @ \subsection{Energy scan application} Here, we insert the predefined norm. <>= procedure :: apply => escan_apply <>= subroutine escan_apply (sf_int, scale, negative_sf, rescale, i_sub) class(escan_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f associate (data => sf_int%data) f = data%norm end associate call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine escan_apply @ %def escan_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_escan_ut.f90]]>>= <> module sf_escan_ut use unit_tests use sf_escan_uti <> <> contains <> end module sf_escan_ut @ %def sf_escan_ut @ <<[[sf_escan_uti.f90]]>>= <> module sf_escan_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_aux use sf_base use sf_escan <> <> contains <> end module sf_escan_uti @ %def sf_escan_ut @ API: driver for the unit tests below. <>= public :: sf_escan_test <>= subroutine sf_escan_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_escan_test @ %def sf_escan_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_escan_1, "sf_escan_1", & "structure function configuration", & u, results) <>= public :: sf_escan_1 <>= subroutine sf_escan_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_escan_1" write (u, "(A)") "* Purpose: initialize and display & &energy-scan structure function data" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (escan_data_t :: data) select type (data) type is (escan_data_t) call data%init (model, pdg_in, norm = 2._default) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_escan_1" end subroutine sf_escan_1 @ %def sf_escan_1 g@ \subsubsection{Probe the structure-function object} Active the beam event reader, generate an event. <>= call test (sf_escan_2, "sf_escan_2", & "generate event", & u, results) <>= public :: sf_escan_2 <>= subroutine sf_escan_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: x_free, f write (u, "(A)") "* Test output: sf_escan_2" write (u, "(A)") "* Purpose: initialize and display & &beam-events structure function data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (escan_data_t :: data) select type (data) type is (escan_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set dummy parameters and generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.8 rb = 1 - r x_free = 1 call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call sf_int%recover_x (x, xb, x_free) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_escan_2" end subroutine sf_escan_2 @ %def sf_escan_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Gaussian beam spread} Instead of an analytic beam description, beam data may be provided in form of an event file. In its most simple form, the event file contains pairs of $x$ values, relative to nominal beam energies. More advanced formats may include polarization, etc. The current implementation carries beam polarization through, if specified. The code is very similar to the energy scan described above. However, we must include a file-handle manager for the beam-event files. Two different processes may access a given beam-event file at the same time (i.e., serially but alternating). Accessing an open file from two different units is non-standard and not supported by all compilers. Therefore, we keep a global registry of open files, associated units, and reference counts. The [[gaussian_t]] objects act as proxies to this registry. <<[[sf_gaussian.f90]]>>= <> module sf_gaussian <> <> use io_units use format_defs, only: FMT_12 use file_registries use diagnostics use lorentz use rng_base use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use sf_base <> <> <> contains <> end module sf_gaussian @ %def sf_gaussian @ \subsection{The beam-data file registry} We manage data files via the [[file_registries]] module. To this end, we keep the registry as a private module variable here. <>= type(file_registry_t), save :: beam_file_registry @ %def beam_file_registry @ \subsection{Data type} We store the spread for each beam, as a relative number related to the beam energy. For the actual generation, we include an (abstract) random-number generator factory. <>= public :: gaussian_data_t <>= type, extends(sf_data_t) :: gaussian_data_t private type(flavor_t), dimension(2) :: flv_in real(default), dimension(2) :: spread class(rng_factory_t), allocatable :: rng_factory contains <> end type gaussian_data_t @ %def gaussian_data_t <>= procedure :: init => gaussian_data_init <>= subroutine gaussian_data_init (data, model, pdg_in, spread, rng_factory) class(gaussian_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), dimension(2), intent(in) :: spread class(rng_factory_t), intent(inout), allocatable :: rng_factory if (any (spread < 0)) then call msg_fatal ("Gaussian beam spread: must not be negative") end if call data%flv_in(1)%init (pdg_in(1)%get (1), model) call data%flv_in(2)%init (pdg_in(2)%get (1), model) data%spread = spread call move_alloc (from = rng_factory, to = data%rng_factory) end subroutine gaussian_data_init @ %def gaussian_data_init @ Return true since this spectrum is always in generator mode. <>= procedure :: is_generator => gaussian_data_is_generator <>= function gaussian_data_is_generator (data) result (flag) class(gaussian_data_t), intent(in) :: data logical :: flag flag = .true. end function gaussian_data_is_generator @ %def gaussian_data_is_generator @ The number of parameters is two. They are free parameters. <>= procedure :: get_n_par => gaussian_data_get_n_par <>= function gaussian_data_get_n_par (data) result (n) class(gaussian_data_t), intent(in) :: data integer :: n n = 2 end function gaussian_data_get_n_par @ %def gaussian_data_get_n_par <>= procedure :: get_pdg_out => gaussian_data_get_pdg_out <>= subroutine gaussian_data_get_pdg_out (data, pdg_out) class(gaussian_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%flv_in(i)%get_pdg () end do end subroutine gaussian_data_get_pdg_out @ %def gaussian_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => gaussian_data_allocate_sf_int <>= subroutine gaussian_data_allocate_sf_int (data, sf_int) class(gaussian_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (gaussian_t :: sf_int) end subroutine gaussian_data_allocate_sf_int @ %def gaussian_data_allocate_sf_int @ Output <>= procedure :: write => gaussian_data_write <>= subroutine gaussian_data_write (data, unit, verbose) class(gaussian_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Gaussian beam spread data:" write (u, "(3x,A,A,A,A)") "prt_in = ", & char (data%flv_in(1)%get_name ()), & ", ", char (data%flv_in(2)%get_name ()) write (u, "(3x,A,2(1x," // FMT_12 // "))") "spread =", data%spread call data%rng_factory%write (u) end subroutine gaussian_data_write @ %def gaussian_data_write @ \subsection{The gaussian object} Flavor and polarization carried through, no radiated particles. The generator needs a random-number generator, obviously. <>= public :: gaussian_t <>= type, extends (sf_int_t) :: gaussian_t type(gaussian_data_t), pointer :: data => null () class(rng_t), allocatable :: rng contains <> end type gaussian_t @ %def gaussian_t @ Type string: show gaussian file. <>= procedure :: type_string => gaussian_type_string <>= function gaussian_type_string (object) result (string) class(gaussian_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "Gaussian: gaussian beam-energy spread" else string = "Gaussian: [undefined]" end if end function gaussian_type_string @ %def gaussian_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => gaussian_write <>= subroutine gaussian_write (object, unit, testflag) class(gaussian_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%rng%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "gaussian data: [undefined]" end if end subroutine gaussian_write @ %def gaussian_write @ <>= procedure :: init => gaussian_init <>= subroutine gaussian_init (sf_int, data) class(gaussian_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data real(default), dimension(2) :: m2 real(default), dimension(0) :: mr2 type(quantum_numbers_mask_t), dimension(4) :: mask integer, dimension(4) :: hel_lock type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn type(polarization_t), target :: pol1, pol2 type(polarization_iterator_t) :: it_hel1, it_hel2 integer :: i select type (data) type is (gaussian_data_t) m2 = data%flv_in%get_mass () ** 2 hel_lock = [3, 4, 1, 2] mask = quantum_numbers_mask (.false., .false., .false.) call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock) sf_int%data => data do i = 1, 2 call qn_fc(i)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) call qn_fc(i+2)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) end do call pol1%init_generic (data%flv_in(1)) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel(1) = it_hel1%get_quantum_numbers () qn_hel(3) = it_hel1%get_quantum_numbers () call pol2%init_generic (data%flv_in(2)) call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel(2) = it_hel2%get_quantum_numbers () qn_hel(4) = it_hel2%get_quantum_numbers () qn = qn_hel .merge. qn_fc call sf_int%add_state (qn) call it_hel2%advance () end do ! call pol2%final () call it_hel1%advance () end do ! call pol1%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) sf_int%status = SF_INITIAL end select call sf_int%data%rng_factory%make (sf_int%rng) end subroutine gaussian_init @ %def gaussian_init @ This spectrum type needs a finalizer, which closes the data file. <>= procedure :: final => sf_gaussian_final <>= subroutine sf_gaussian_final (object) class(gaussian_t), intent(inout) :: object call object%interaction_t%final () end subroutine sf_gaussian_final @ %def sf_gaussian_final @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => gaussian_is_generator <>= function gaussian_is_generator (sf_int) result (flag) class(gaussian_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function gaussian_is_generator @ %def gaussian_is_generator @ Generate free parameters. The $x$ value should be distributed with mean $1$ and $\sigma$ given by the spread. We reject negative $x$ values. (This cut slightly biases the distribution, but for reasonable (small) spreads negative $r$ should not occur. <>= procedure :: generate_free => gaussian_generate_free <>= subroutine gaussian_generate_free (sf_int, r, rb, x_free) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free real(default), dimension(size(r)) :: z associate (data => sf_int%data) do call sf_int%rng%generate_gaussian (z) rb = z * data%spread r = 1 - rb x_free = x_free * product (r) if (all (r > 0)) exit end do end associate end subroutine gaussian_generate_free @ %def gaussian_generate_free @ Set kinematics. Trivial transfer since this is a pure generator. The [[map]] flag doesn't apply. <>= procedure :: complete_kinematics => gaussian_complete_kinematics <>= subroutine gaussian_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("gaussian: map flag not supported") else x = r xb= rb f = 1 end if call sf_int%reduce_momenta (x) end subroutine gaussian_complete_kinematics @ %def gaussian_complete_kinematics @ Compute inverse kinematics. Trivial in this case. <>= procedure :: inverse_kinematics => gaussian_inverse_kinematics <>= subroutine gaussian_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("gaussian: map flag not supported") else r = x rb= xb f = 1 end if if (set_mom) then call sf_int%reduce_momenta (x) end if end subroutine gaussian_inverse_kinematics @ %def gaussian_inverse_kinematics @ \subsection{gaussian application} Trivial, just set the unit weight. <>= procedure :: apply => gaussian_apply <>= subroutine gaussian_apply (sf_int, scale, negative_sf, rescale, i_sub) class(gaussian_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f f = 1 call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine gaussian_apply @ %def gaussian_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_gaussian_ut.f90]]>>= <> module sf_gaussian_ut use unit_tests use sf_gaussian_uti <> <> contains <> end module sf_gaussian_ut @ %def sf_gaussian_ut @ <<[[sf_gaussian_uti.f90]]>>= <> module sf_gaussian_uti <> use numeric_utils, only: pacify use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use rng_base use sf_aux use sf_base use sf_gaussian use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module sf_gaussian_uti @ %def sf_gaussian_ut @ API: driver for the unit tests below. <>= public :: sf_gaussian_test <>= subroutine sf_gaussian_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_gaussian_test @ %def sf_gaussian_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_gaussian_1, "sf_gaussian_1", & "structure function configuration", & u, results) <>= public :: sf_gaussian_1 <>= subroutine sf_gaussian_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data class(rng_factory_t), allocatable :: rng_factory write (u, "(A)") "* Test output: sf_gaussian_1" write (u, "(A)") "* Purpose: initialize and display & &gaussian-spread structure function data" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (gaussian_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (gaussian_data_t) call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_gaussian_1" end subroutine sf_gaussian_1 @ %def sf_gaussian_1 @ \subsubsection{Probe the structure-function object} Active the beam event reader, generate an event. <>= call test (sf_gaussian_2, "sf_gaussian_2", & "generate event", & u, results) <>= public :: sf_gaussian_2 <>= subroutine sf_gaussian_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: x_free, f integer :: i write (u, "(A)") "* Test output: sf_gaussian_2" write (u, "(A)") "* Purpose: initialize and display & &gaussian-spread structure function data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (gaussian_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (gaussian_data_t) call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set dummy parameters and generate x." write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call pacify (rb, 1.e-8_default) call pacify (xb, 1.e-8_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Generate more events" write (u, "(A)") select type (sf_int) type is (gaussian_t) do i = 1, 3 call sf_int%generate_free (r, rb, x_free) write (u, "(A,9(1x,F10.7))") "r =", r end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_gaussian_2" end subroutine sf_gaussian_2 @ %def sf_gaussian_2 @ \clearpage @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Using beam event data} Instead of an analytic beam description, beam data may be provided in form of an event file. In its most simple form, the event file contains pairs of $x$ values, relative to nominal beam energies. More advanced formats may include polarization, etc. The current implementation carries beam polarization through, if specified. The code is very similar to the energy scan described above. However, we must include a file-handle manager for the beam-event files. Two different processes may access a given beam-event file at the same time (i.e., serially but alternating). Accessing an open file from two different units is non-standard and not supported by all compilers. Therefore, we keep a global registry of open files, associated units, and reference counts. The [[beam_events_t]] objects act as proxies to this registry. <<[[sf_beam_events.f90]]>>= <> module sf_beam_events <> <> use io_units use file_registries use diagnostics use lorentz use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use sf_base <> <> <> <> contains <> end module sf_beam_events @ %def sf_beam_events @ \subsection{The beam-data file registry} We manage data files via the [[file_registries]] module. To this end, we keep the registry as a private module variable here. This is public only for the unit tests. <>= public :: beam_file_registry <>= type(file_registry_t), save :: beam_file_registry @ %def beam_file_registry @ \subsection{Data type} <>= public :: beam_events_data_t <>= type, extends(sf_data_t) :: beam_events_data_t private type(flavor_t), dimension(2) :: flv_in type(string_t) :: dir type(string_t) :: file type(string_t) :: fqn integer :: unit = 0 logical :: warn_eof = .true. contains <> end type beam_events_data_t @ %def beam_events_data_t <>= procedure :: init => beam_events_data_init <>= subroutine beam_events_data_init (data, model, pdg_in, dir, file, warn_eof) class(beam_events_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in type(string_t), intent(in) :: dir type(string_t), intent(in) :: file logical, intent(in), optional :: warn_eof if (any (pdg_in%get_length () /= 1)) then call msg_fatal ("Beam events: incoming beam particles must be unique") end if call data%flv_in(1)%init (pdg_in(1)%get (1), model) call data%flv_in(2)%init (pdg_in(2)%get (1), model) data%dir = dir data%file = file if (present (warn_eof)) data%warn_eof = warn_eof end subroutine beam_events_data_init @ %def beam_events_data_init @ Return true since this spectrum is always in generator mode. <>= procedure :: is_generator => beam_events_data_is_generator <>= function beam_events_data_is_generator (data) result (flag) class(beam_events_data_t), intent(in) :: data logical :: flag flag = .true. end function beam_events_data_is_generator @ %def beam_events_data_is_generator @ The number of parameters is two. They are free parameters. <>= procedure :: get_n_par => beam_events_data_get_n_par <>= function beam_events_data_get_n_par (data) result (n) class(beam_events_data_t), intent(in) :: data integer :: n n = 2 end function beam_events_data_get_n_par @ %def beam_events_data_get_n_par <>= procedure :: get_pdg_out => beam_events_data_get_pdg_out <>= subroutine beam_events_data_get_pdg_out (data, pdg_out) class(beam_events_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%flv_in(i)%get_pdg () end do end subroutine beam_events_data_get_pdg_out @ %def beam_events_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => beam_events_data_allocate_sf_int <>= subroutine beam_events_data_allocate_sf_int (data, sf_int) class(beam_events_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (beam_events_t :: sf_int) end subroutine beam_events_data_allocate_sf_int @ %def beam_events_data_allocate_sf_int @ Output <>= procedure :: write => beam_events_data_write <>= subroutine beam_events_data_write (data, unit, verbose) class(beam_events_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Beam-event file data:" write (u, "(3x,A,A,A,A)") "prt_in = ", & char (data%flv_in(1)%get_name ()), & ", ", char (data%flv_in(2)%get_name ()) write (u, "(3x,A,A,A)") "file = '", char (data%file), "'" write (u, "(3x,A,I0)") "unit = ", data%unit write (u, "(3x,A,L1)") "warn = ", data%warn_eof end subroutine beam_events_data_write @ %def beam_events_data_write @ The data file needs to be opened and closed explicitly. The open/close message is communicated to the file handle registry, which does the actual work. We determine first whether to look in the local directory or in the given system directory. <>= procedure :: open => beam_events_data_open procedure :: close => beam_events_data_close <>= subroutine beam_events_data_open (data) class(beam_events_data_t), intent(inout) :: data logical :: exist if (data%unit == 0) then data%fqn = data%file if (data%fqn == "") & call msg_fatal ("Beam events: $beam_events_file is not set") inquire (file = char (data%fqn), exist = exist) if (.not. exist) then data%fqn = data%dir // "/" // data%file inquire (file = char (data%fqn), exist = exist) if (.not. exist) then data%fqn = "" call msg_fatal ("Beam events: file '" & // char (data%file) // "' not found") return end if end if call msg_message ("Beam events: reading from file '" & // char (data%file) // "'") call beam_file_registry%open (data%fqn, data%unit) else call msg_bug ("Beam events: file '" & // char (data%file) // "' is already open") end if end subroutine beam_events_data_open subroutine beam_events_data_close (data) class(beam_events_data_t), intent(inout) :: data if (data%unit /= 0) then call beam_file_registry%close (data%fqn) call msg_message ("Beam events: closed file '" & // char (data%file) // "'") data%unit = 0 end if end subroutine beam_events_data_close @ %def beam_events_data_close @ Return the beam event file. <>= procedure :: get_beam_file => beam_events_data_get_beam_file <>= function beam_events_data_get_beam_file (data) result (file) class(beam_events_data_t), intent(in) :: data type(string_t) :: file file = "Beam events: " // data%file end function beam_events_data_get_beam_file @ %def beam_events_data_get_beam_file @ \subsection{The beam events object} Flavor and polarization carried through, no radiated particles. <>= public :: beam_events_t <>= type, extends (sf_int_t) :: beam_events_t type(beam_events_data_t), pointer :: data => null () integer :: count = 0 contains <> end type beam_events_t @ %def beam_events_t @ Type string: show beam events file. <>= procedure :: type_string => beam_events_type_string <>= function beam_events_type_string (object) result (string) class(beam_events_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "Beam events: " // object%data%file else string = "Beam events: [undefined]" end if end function beam_events_type_string @ %def beam_events_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => beam_events_write <>= subroutine beam_events_write (object, unit, testflag) class(beam_events_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "Beam events data: [undefined]" end if end subroutine beam_events_write @ %def beam_events_write @ <>= procedure :: init => beam_events_init <>= subroutine beam_events_init (sf_int, data) class(beam_events_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data real(default), dimension(2) :: m2 real(default), dimension(0) :: mr2 type(quantum_numbers_mask_t), dimension(4) :: mask integer, dimension(4) :: hel_lock type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn type(polarization_t), target :: pol1, pol2 type(polarization_iterator_t) :: it_hel1, it_hel2 integer :: i select type (data) type is (beam_events_data_t) m2 = data%flv_in%get_mass () ** 2 hel_lock = [3, 4, 1, 2] mask = quantum_numbers_mask (.false., .false., .false.) call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock) sf_int%data => data do i = 1, 2 call qn_fc(i)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) call qn_fc(i+2)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) end do call pol1%init_generic (data%flv_in(1)) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel(1) = it_hel1%get_quantum_numbers () qn_hel(3) = it_hel1%get_quantum_numbers () call pol2%init_generic (data%flv_in(2)) call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel(2) = it_hel2%get_quantum_numbers () qn_hel(4) = it_hel2%get_quantum_numbers () qn = qn_hel .merge. qn_fc call sf_int%add_state (qn) call it_hel2%advance () end do ! call pol2%final () call it_hel1%advance () end do ! call pol1%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%data%open () sf_int%status = SF_INITIAL end select end subroutine beam_events_init @ %def beam_events_init @ This spectrum type needs a finalizer, which closes the data file. <>= procedure :: final => sf_beam_events_final <>= subroutine sf_beam_events_final (object) class(beam_events_t), intent(inout) :: object call object%data%close () call object%interaction_t%final () end subroutine sf_beam_events_final @ %def sf_beam_events_final @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => beam_events_is_generator <>= function beam_events_is_generator (sf_int) result (flag) class(beam_events_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function beam_events_is_generator @ %def beam_events_is_generator @ Generate free parameters. We read them from file. <>= procedure :: generate_free => beam_events_generate_free <>= recursive subroutine beam_events_generate_free (sf_int, r, rb, x_free) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free integer :: iostat associate (data => sf_int%data) if (data%unit /= 0) then read (data%unit, fmt=*, iostat=iostat) r if (iostat > 0) then write (msg_buffer, "(A,I0,A)") & "Beam events: I/O error after reading ", sf_int%count, & " events" call msg_fatal () else if (iostat < 0) then if (sf_int%count == 0) then call msg_fatal ("Beam events: file is empty") else if (sf_int%data%warn_eof) then write (msg_buffer, "(A,I0,A)") & "Beam events: End of file after reading ", sf_int%count, & " events, rewinding" call msg_warning () end if rewind (data%unit) sf_int%count = 0 call sf_int%generate_free (r, rb, x_free) else sf_int%count = sf_int%count + 1 rb = 1 - r x_free = x_free * product (r) end if else call msg_bug ("Beam events: file is not open for reading") end if end associate end subroutine beam_events_generate_free @ %def beam_events_generate_free @ Set kinematics. Trivial transfer since this is a pure generator. The [[map]] flag doesn't apply. <>= procedure :: complete_kinematics => beam_events_complete_kinematics <>= subroutine beam_events_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("Beam events: map flag not supported") else x = r xb= rb f = 1 end if call sf_int%reduce_momenta (x) end subroutine beam_events_complete_kinematics @ %def beam_events_complete_kinematics @ Compute inverse kinematics. Trivial in this case. <>= procedure :: inverse_kinematics => beam_events_inverse_kinematics <>= subroutine beam_events_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("Beam events: map flag not supported") else r = x rb= xb f = 1 end if if (set_mom) then call sf_int%reduce_momenta (x) end if end subroutine beam_events_inverse_kinematics @ %def beam_events_inverse_kinematics @ \subsection{Beam events application} Trivial, just set the unit weight. <>= procedure :: apply => beam_events_apply <>= subroutine beam_events_apply (sf_int, scale, negative_sf, rescale, i_sub) class(beam_events_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f f = 1 call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine beam_events_apply @ %def beam_events_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_beam_events_ut.f90]]>>= <> module sf_beam_events_ut use unit_tests use sf_beam_events_uti <> <> contains <> end module sf_beam_events_ut @ %def sf_beam_events_ut @ <<[[sf_beam_events_uti.f90]]>>= <> module sf_beam_events_uti <> <> use io_units use numeric_utils, only: pacify use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_aux use sf_base use sf_beam_events <> <> contains <> end module sf_beam_events_uti @ %def sf_beam_events_ut @ API: driver for the unit tests below. <>= public :: sf_beam_events_test <>= subroutine sf_beam_events_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_beam_events_test @ %def sf_beam_events_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_beam_events_1, "sf_beam_events_1", & "structure function configuration", & u, results) <>= public :: sf_beam_events_1 <>= subroutine sf_beam_events_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_beam_events_1" write (u, "(A)") "* Purpose: initialize and display & &beam-events structure function data" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (beam_events_data_t :: data) select type (data) type is (beam_events_data_t) call data%init (model, pdg_in, var_str (""), var_str ("beam_events.dat")) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_beam_events_1" end subroutine sf_beam_events_1 @ %def sf_beam_events_1 @ \subsubsection{Probe the structure-function object} Active the beam event reader, generate an event. <>= call test (sf_beam_events_2, "sf_beam_events_2", & "generate event", & u, results) <>= public :: sf_beam_events_2 <>= subroutine sf_beam_events_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: x_free, f integer :: i write (u, "(A)") "* Test output: sf_beam_events_2" write (u, "(A)") "* Purpose: initialize and display & &beam-events structure function data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (beam_events_data_t :: data) select type (data) type is (beam_events_data_t) call data%init (model, pdg_in, & var_str (""), var_str ("test_beam_events.dat")) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set dummy parameters and generate x." write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free select type (sf_int) type is (beam_events_t) write (u, "(A,1x,I0)") "count =", sf_int%count end select write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Generate more events, rewind" write (u, "(A)") select type (sf_int) type is (beam_events_t) do i = 1, 3 call sf_int%generate_free (r, rb, x_free) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,1x,I0)") "count =", sf_int%count end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_beam_events_2" end subroutine sf_beam_events_2 @ %def sf_beam_events_2 @ \subsubsection{Check the file handle registry} Open and close some files, checking the registry contents. <>= call test (sf_beam_events_3, "sf_beam_events_3", & "check registry", & u, results) <>= public :: sf_beam_events_3 <>= subroutine sf_beam_events_3 (u) integer, intent(in) :: u integer :: u1 write (u, "(A)") "* Test output: sf_beam_events_2" write (u, "(A)") "* Purpose: check file handle registry" write (u, "(A)") write (u, "(A)") "* Create some empty files" write (u, "(A)") u1 = free_unit () open (u1, file = "sf_beam_events_f1.tmp", action="write", status="new") close (u1) open (u1, file = "sf_beam_events_f2.tmp", action="write", status="new") close (u1) open (u1, file = "sf_beam_events_f3.tmp", action="write", status="new") close (u1) write (u, "(A)") "* Empty registry" write (u, "(A)") call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Insert three entries" write (u, "(A)") call beam_file_registry%open (var_str ("sf_beam_events_f3.tmp")) call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%open (var_str ("sf_beam_events_f1.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Open a second channel" write (u, "(A)") call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Close second entry twice" write (u, "(A)") call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Close last entry" write (u, "(A)") call beam_file_registry%close (var_str ("sf_beam_events_f3.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Close remaining entry" write (u, "(A)") call beam_file_registry%close (var_str ("sf_beam_events_f1.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" open (u1, file = "sf_beam_events_f1.tmp", action="write") close (u1, status = "delete") open (u1, file = "sf_beam_events_f2.tmp", action="write") close (u1, status = "delete") open (u1, file = "sf_beam_events_f3.tmp", action="write") close (u1, status = "delete") write (u, "(A)") write (u, "(A)") "* Test output end: sf_beam_events_3" end subroutine sf_beam_events_3 @ %def sf_beam_events_3 @ \clearpage %------------------------------------------------------------------------ \section{Lepton collider beamstrahlung: CIRCE1} <<[[sf_circe1.f90]]>>= <> module sf_circe1 <> use kinds, only: double <> use io_units use format_defs, only: FMT_17, FMT_19 use diagnostics use physics_defs, only: ELECTRON, PHOTON use lorentz use rng_base use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use sf_mappings use sf_base use circe1, circe1_rng_t => rng_type !NODEP! <> <> <> contains <> end module sf_circe1 @ %def sf_circe1 @ \subsection{Physics} Beamstrahlung is applied before ISR. The [[CIRCE1]] implementation has a single structure function for both beams (which makes sense since it has to be switched on or off for both beams simultaneously). Nevertheless it is factorized: The functional form in the [[CIRCE1]] parameterization is defined for electrons or photons \begin{equation} f(x) = \alpha\,x^\beta\,(1-x)^\gamma \end{equation} for $x<1-\epsilon$ (resp.\ $x>\epsilon$ in the photon case). In the remaining interval, the standard form is zero, with a delta singularity at $x=1$ (resp.\ $x=0$). Equivalently, the delta part may be distributed uniformly among this interval. This latter form is implemented in the [[kirke]] version of the [[CIRCE1]] subroutines, and is used here. The parameter [[circe1\_eps]] sets the peak mapping of the [[CIRCE1]] structure function. Its default value is $10^{-5}$. The other parameters are the parameterization version and revision number, the accelerator type, and the $\sqrt{s}$ value used by [[CIRCE1]]. The chattiness can also be set. Since the energy is distributed in a narrow region around unity (for electrons) or zero (for photons), it is advantageous to map the interval first. The mapping is controlled by the parameter [[circe1\_epsilon]] which is taken from the [[CIRCE1]] internal data structure. The $\sqrt{s}$ value, if not explicitly set, is taken from the process data. Note that interpolating $\sqrt{s}$ is not recommended; one should rather choose one of the distinct values known to [[CIRCE1]]. \subsection{The CIRCE1 data block} The CIRCE1 parameters are: The incoming flavors, the flags whether the photon or the lepton is the parton in the hard interaction, the flags for the generation mode (generator/mapping/no mapping), the mapping parameter $\epsilon$, $\sqrt{s}$ and several steering parameters: [[ver]], [[rev]], [[acc]], [[chat]]. In generator mode, the $x$ values are actually discarded and a random number generator is used instead. <>= public :: circe1_data_t <>= type, extends (sf_data_t) :: circe1_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(2) :: flv_in integer, dimension(2) :: pdg_in real(default), dimension(2) :: m_in = 0 logical, dimension(2) :: photon = .false. logical :: generate = .false. class(rng_factory_t), allocatable :: rng_factory real(default) :: sqrts = 0 real(default) :: eps = 0 integer :: ver = 0 integer :: rev = 0 character(6) :: acc = "?" integer :: chat = 0 logical :: with_radiation = .false. contains <> end type circe1_data_t @ %def circe1_data_t @ <>= procedure :: init => circe1_data_init <>= subroutine circe1_data_init & (data, model, pdg_in, sqrts, eps, out_photon, & ver, rev, acc, chat, with_radiation) class(circe1_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in) :: sqrts real(default), intent(in) :: eps logical, dimension(2), intent(in) :: out_photon character(*), intent(in) :: acc integer, intent(in) :: ver, rev, chat logical, intent(in) :: with_radiation data%model => model if (any (pdg_in%get_length () /= 1)) then call msg_fatal ("CIRCE1: incoming beam particles must be unique") end if call data%flv_in(1)%init (pdg_in(1)%get (1), model) call data%flv_in(2)%init (pdg_in(2)%get (1), model) data%pdg_in = data%flv_in%get_pdg () data%m_in = data%flv_in%get_mass () data%sqrts = sqrts data%eps = eps data%photon = out_photon data%ver = ver data%rev = rev data%acc = acc data%chat = chat data%with_radiation = with_radiation call data%check () call circex (0.d0, 0.d0, dble (data%sqrts), & data%acc, data%ver, data%rev, data%chat) end subroutine circe1_data_init @ %def circe1_data_init @ Activate the generator mode. We import a RNG factory into the data type, which can then spawn RNG generator objects. <>= procedure :: set_generator_mode => circe1_data_set_generator_mode <>= subroutine circe1_data_set_generator_mode (data, rng_factory) class(circe1_data_t), intent(inout) :: data class(rng_factory_t), intent(inout), allocatable :: rng_factory data%generate = .true. call move_alloc (from = rng_factory, to = data%rng_factory) end subroutine circe1_data_set_generator_mode @ %def circe1_data_set_generator_mode @ Handle error conditions. <>= procedure :: check => circe1_data_check <>= subroutine circe1_data_check (data) class(circe1_data_t), intent(in) :: data type(flavor_t) :: flv_electron, flv_photon call flv_electron%init (ELECTRON, data%model) call flv_photon%init (PHOTON, data%model) if (.not. flv_electron%is_defined () & .or. .not. flv_photon%is_defined ()) then call msg_fatal ("CIRCE1: model must contain photon and electron") end if if (any (abs (data%pdg_in) /= ELECTRON) & .or. (data%pdg_in(1) /= - data%pdg_in(2))) then call msg_fatal ("CIRCE1: applicable only for e+e- or e-e+ collisions") end if if (data%eps <= 0) then call msg_error ("CIRCE1: circe1_eps = 0: integration will & &miss x=1 peak") end if end subroutine circe1_data_check @ %def circe1_data_check @ Output <>= procedure :: write => circe1_data_write <>= subroutine circe1_data_write (data, unit, verbose) class(circe1_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u logical :: verb verb = .false.; if (present (verbose)) verb = verbose u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "CIRCE1 data:" write (u, "(3x,A,2(1x,A))") "prt_in =", & char (data%flv_in(1)%get_name ()), & char (data%flv_in(2)%get_name ()) write (u, "(3x,A,2(1x,L1))") "photon =", data%photon write (u, "(3x,A,L1)") "generate = ", data%generate write (u, "(3x,A,2(1x," // FMT_19 // "))") "m_in =", data%m_in write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", data%sqrts write (u, "(3x,A," // FMT_19 // ")") "eps = ", data%eps write (u, "(3x,A,I0)") "ver = ", data%ver write (u, "(3x,A,I0)") "rev = ", data%rev write (u, "(3x,A,A)") "acc = ", data%acc write (u, "(3x,A,I0)") "chat = ", data%chat write (u, "(3x,A,L1)") "with rad.= ", data%with_radiation if (data%generate) then if (verb) then call data%rng_factory%write (u) end if end if end subroutine circe1_data_write @ %def circe1_data_write @ Return true if this structure function is in generator mode. In that case, all parameters are free, otherwise bound. (We do not support mixed cases.) Default is: no generator. <>= procedure :: is_generator => circe1_data_is_generator <>= function circe1_data_is_generator (data) result (flag) class(circe1_data_t), intent(in) :: data logical :: flag flag = data%generate end function circe1_data_is_generator @ %def circe1_data_is_generator @ The number of parameters is two, collinear splitting for the two beams. <>= procedure :: get_n_par => circe1_data_get_n_par <>= function circe1_data_get_n_par (data) result (n) class(circe1_data_t), intent(in) :: data integer :: n n = 2 end function circe1_data_get_n_par @ %def circe1_data_get_n_par @ Return the outgoing particles PDG codes. This is either the incoming particle (if a photon is radiated), or the photon if that is the particle of the hard interaction. The latter is determined via the [[photon]] flag. There are two entries for the two beams. <>= procedure :: get_pdg_out => circe1_data_get_pdg_out <>= subroutine circe1_data_get_pdg_out (data, pdg_out) class(circe1_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n if (data%photon(i)) then pdg_out(i) = PHOTON else pdg_out(i) = data%pdg_in(i) end if end do end subroutine circe1_data_get_pdg_out @ %def circe1_data_get_pdg_out @ This variant is not inherited, it returns integers. <>= procedure :: get_pdg_int => circe1_data_get_pdg_int <>= function circe1_data_get_pdg_int (data) result (pdg) class(circe1_data_t), intent(in) :: data integer, dimension(2) :: pdg integer :: i do i = 1, 2 if (data%photon(i)) then pdg(i) = PHOTON else pdg(i) = data%pdg_in(i) end if end do end function circe1_data_get_pdg_int @ %def circe1_data_get_pdg_int @ Allocate the interaction record. <>= procedure :: allocate_sf_int => circe1_data_allocate_sf_int <>= subroutine circe1_data_allocate_sf_int (data, sf_int) class(circe1_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (circe1_t :: sf_int) end subroutine circe1_data_allocate_sf_int @ %def circe1_data_allocate_sf_int @ Return the accelerator type. <>= procedure :: get_beam_file => circe1_data_get_beam_file <>= function circe1_data_get_beam_file (data) result (file) class(circe1_data_t), intent(in) :: data type(string_t) :: file file = "CIRCE1: " // data%acc end function circe1_data_get_beam_file @ %def circe1_data_get_beam_file @ \subsection{Random Number Generator for CIRCE} The CIRCE implementation now supports a generic random-number generator object that allows for a local state as a component. To support this, we must extend the abstract type provided by CIRCE and delegate the generator call to the (also abstract) RNG used by WHIZARD. <>= type, extends (circe1_rng_t) :: rng_obj_t class(rng_t), allocatable :: rng contains procedure :: generate => rng_obj_generate end type rng_obj_t @ %def rng_obj_t <>= subroutine rng_obj_generate (rng_obj, u) class(rng_obj_t), intent(inout) :: rng_obj real(double), intent(out) :: u real(default) :: x call rng_obj%rng%generate (x) u = x end subroutine rng_obj_generate @ %def rng_obj_generate @ \subsection{The CIRCE1 object} This is a $2\to 4$ interaction, where, depending on the parameters, any two of the four outgoing particles are connected to the hard interactions, the others are radiated. Knowing that all particles are colorless, we do not have to deal with color. The flavors are sorted such that the first two particles are the incoming leptons, the next two are the radiated particles, and the last two are the partons initiating the hard interaction. CIRCE1 does not support polarized beams explicitly. For simplicity, we nevertheless carry beam polarization through to the outgoing electrons and make the photons unpolarized. In the case that no radiated particle is kept (which actually is the default), polarization is always transferred to the electrons, too. If there is a recoil photon in the event, the radiated particles are 3 and 4, respectively, and 5 and 6 are the outgoing ones (triggering the hard scattering process), while in the case of no radiation, the outgoing particles are 3 and 4, respectively. In the case of the electron being the radiated particle, helicity is not kept. <>= public :: circe1_t <>= type, extends (sf_int_t) :: circe1_t type(circe1_data_t), pointer :: data => null () real(default), dimension(2) :: x = 0 real(default), dimension(2) :: xb= 0 real(default) :: f = 0 logical, dimension(2) :: continuum = .true. logical, dimension(2) :: peak = .true. type(rng_obj_t) :: rng_obj contains <> end type circe1_t @ %def circe1_t @ Type string: has to be here, but there is no string variable on which CIRCE1 depends. Hence, a dummy routine. <>= procedure :: type_string => circe1_type_string <>= function circe1_type_string (object) result (string) class(circe1_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "CIRCE1: beamstrahlung" else string = "CIRCE1: [undefined]" end if end function circe1_type_string @ %def circe1_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => circe1_write <>= subroutine circe1_write (object, unit, testflag) class(circe1_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%data%generate) call object%rng_obj%rng%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(3x,A,2(1x," // FMT_17 // "))") "x =", object%x write (u, "(3x,A,2(1x," // FMT_17 // "))") "xb=", object%xb if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A,1x," // FMT_17 // ")") "f =", object%f end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "CIRCE1 data: [undefined]" end if end subroutine circe1_write @ %def circe1_write @ <>= procedure :: init => circe1_init <>= subroutine circe1_init (sf_int, data) class(circe1_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data logical, dimension(6) :: mask_h type(quantum_numbers_mask_t), dimension(6) :: mask integer, dimension(6) :: hel_lock type(polarization_t), target :: pol1, pol2 type(quantum_numbers_t), dimension(1) :: qn_fc1, qn_fc2 type(flavor_t) :: flv_photon type(color_t) :: col0 real(default), dimension(2) :: mi2, mr2, mo2 type(quantum_numbers_t) :: qn_hel1, qn_hel2, qn_photon, qn1, qn2 type(quantum_numbers_t), dimension(6) :: qn type(polarization_iterator_t) :: it_hel1, it_hel2 hel_lock = 0 mask_h = .false. select type (data) type is (circe1_data_t) mi2 = data%m_in**2 if (data%with_radiation) then if (data%photon(1)) then hel_lock(1) = 3; hel_lock(3) = 1; mask_h(5) = .true. mr2(1) = mi2(1) mo2(1) = 0._default else hel_lock(1) = 5; hel_lock(5) = 1; mask_h(3) = .true. mr2(1) = 0._default mo2(1) = mi2(1) end if if (data%photon(2)) then hel_lock(2) = 4; hel_lock(4) = 2; mask_h(6) = .true. mr2(2) = mi2(2) mo2(2) = 0._default else hel_lock(2) = 6; hel_lock(6) = 2; mask_h(4) = .true. mr2(2) = 0._default mo2(2) = mi2(2) end if mask = quantum_numbers_mask (.false., .false., mask_h) call sf_int%base_init (mask, mi2, mr2, mo2, & hel_lock = hel_lock) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col0%init () call qn_photon%init (flv_photon, col0) call pol1%init_generic (data%flv_in(1)) call qn_fc1(1)%init (flv = data%flv_in(1), col = col0) call pol2%init_generic (data%flv_in(2)) call qn_fc2(1)%init (flv = data%flv_in(2), col = col0) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel1 = it_hel1%get_quantum_numbers () qn1 = qn_hel1 .merge. qn_fc1(1) qn(1) = qn1 if (data%photon(1)) then qn(3) = qn1; qn(5) = qn_photon else qn(3) = qn_photon; qn(5) = qn1 end if call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel2 = it_hel2%get_quantum_numbers () qn2 = qn_hel2 .merge. qn_fc2(1) qn(2) = qn2 if (data%photon(2)) then qn(4) = qn2; qn(6) = qn_photon else qn(4) = qn_photon; qn(6) = qn2 end if call qn(3:4)%tag_radiated () call sf_int%add_state (qn) call it_hel2%advance () end do call it_hel1%advance () end do ! call pol1%final () ! call pol2%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_radiated ([3,4]) call sf_int%set_outgoing ([5,6]) else if (data%photon(1)) then mask_h(3) = .true. mo2(1) = 0._default else hel_lock(1) = 3; hel_lock(3) = 1 mo2(1) = mi2(1) end if if (data%photon(2)) then mask_h(4) = .true. mo2(2) = 0._default else hel_lock(2) = 4; hel_lock(4) = 2 mo2(2) = mi2(2) end if mask = quantum_numbers_mask (.false., .false., mask_h) call sf_int%base_init (mask(1:4), mi2, [real(default) :: ], mo2, & hel_lock = hel_lock(1:4)) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col0%init () call qn_photon%init (flv_photon, col0) call pol1%init_generic (data%flv_in(1)) call qn_fc1(1)%init (flv = data%flv_in(1), col = col0) call pol2%init_generic (data%flv_in(2)) call qn_fc2(1)%init (flv = data%flv_in(2), col = col0) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel1 = it_hel1%get_quantum_numbers () qn1 = qn_hel1 .merge. qn_fc1(1) qn(1) = qn1 if (data%photon(1)) then qn(3) = qn_photon else qn(3) = qn1 end if call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel2 = it_hel2%get_quantum_numbers () qn2 = qn_hel2 .merge. qn_fc2(1) qn(2) = qn2 if (data%photon(2)) then qn(4) = qn_photon else qn(4) = qn2 end if call sf_int%add_state (qn(1:4)) call it_hel2%advance () end do call it_hel1%advance () end do ! call pol1%final () ! call pol2%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) end if sf_int%status = SF_INITIAL end select if (sf_int%data%generate) then call sf_int%data%rng_factory%make (sf_int%rng_obj%rng) end if end subroutine circe1_init @ %def circe1_init @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => circe1_is_generator <>= function circe1_is_generator (sf_int) result (flag) class(circe1_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function circe1_is_generator @ %def circe1_is_generator @ Generate free parameters, if generator mode is on. Otherwise, the parameters will be discarded. <>= procedure :: generate_free => circe1_generate_free <>= subroutine circe1_generate_free (sf_int, r, rb, x_free) class(circe1_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free if (sf_int%data%generate) then call circe_generate (r, sf_int%data%get_pdg_int (), sf_int%rng_obj) rb = 1 - r x_free = x_free * product (r) else r = 0 rb= 1 end if end subroutine circe1_generate_free @ %def circe1_generate_free @ Generator mode: depending on the particle codes, call one of the available [[girce]] generators. Illegal particle code combinations should have been caught during data initialization. <>= subroutine circe_generate (x, pdg, rng_obj) real(default), dimension(2), intent(out) :: x integer, dimension(2), intent(in) :: pdg class(rng_obj_t), intent(inout) :: rng_obj real(double) :: xc1, xc2 select case (abs (pdg(1))) case (ELECTRON) select case (abs (pdg(2))) case (ELECTRON) call gircee (xc1, xc2, rng_obj = rng_obj) case (PHOTON) call girceg (xc1, xc2, rng_obj = rng_obj) end select case (PHOTON) select case (abs (pdg(2))) case (ELECTRON) call girceg (xc2, xc1, rng_obj = rng_obj) case (PHOTON) call gircgg (xc1, xc2, rng_obj = rng_obj) end select end select x = [xc1, xc2] end subroutine circe_generate @ %def circe_generate @ Set kinematics. The $r$ values (either from integration or from the generator call above) are copied to $x$ unchanged, and $f$ is unity. We store the $x$ values, so we can use them for the evaluation later. <>= procedure :: complete_kinematics => circe1_complete_kinematics <>= subroutine circe1_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(circe1_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map x = r xb = rb sf_int%x = x sf_int%xb= xb f = 1 if (sf_int%data%with_radiation) then call sf_int%split_momenta (x, xb) else call sf_int%reduce_momenta (x) end if select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end subroutine circe1_complete_kinematics @ %def circe1_complete_kinematics @ Compute inverse kinematics. In generator mode, the $r$ values are meaningless, but we copy them anyway. <>= procedure :: inverse_kinematics => circe1_inverse_kinematics <>= subroutine circe1_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(circe1_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta r = x rb = xb sf_int%x = x sf_int%xb= xb f = 1 if (set_mom) then call sf_int%split_momenta (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine circe1_inverse_kinematics @ %def circe1_inverse_kinematics @ \subsection{CIRCE1 application} CIRCE is applied for the two beams at once. We can safely assume that no structure functions are applied before this, so the incoming particles are on-shell electrons/positrons. The scale is ignored. <>= procedure :: apply => circe1_apply <>= subroutine circe1_apply (sf_int, scale, negative_sf, rescale, i_sub) class(circe1_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default), dimension(2) :: xb real(double), dimension(2) :: xc real(double), parameter :: one = 1 associate (data => sf_int%data) xc = sf_int%x xb = sf_int%xb if (data%generate) then sf_int%f = 1 else sf_int%f = 0 if (all (sf_int%continuum)) then sf_int%f = circe (xc(1), xc(2), data%pdg_in(1), data%pdg_in(2)) end if if (sf_int%continuum(2) .and. sf_int%peak(1)) then sf_int%f = sf_int%f & + circe (one, xc(2), data%pdg_in(1), data%pdg_in(2)) & * peak (xb(1), data%eps) end if if (sf_int%continuum(1) .and. sf_int%peak(2)) then sf_int%f = sf_int%f & + circe (xc(1), one, data%pdg_in(1), data%pdg_in(2)) & * peak (xb(2), data%eps) end if if (all (sf_int%peak)) then sf_int%f = sf_int%f & + circe (one, one, data%pdg_in(1), data%pdg_in(2)) & * peak (xb(1), data%eps) * peak (xb(2), data%eps) end if end if end associate call sf_int%set_matrix_element (cmplx (sf_int%f, kind=default)) sf_int%status = SF_EVALUATED end subroutine circe1_apply @ %def circe1_apply @ This is a smeared delta peak at zero, as an endpoint singularity. We choose an exponentially decreasing function, starting at zero, with integral (from $0$ to $1$) $1-e^{-1/\epsilon}$. For small $\epsilon$, this reduces to one. <>= function peak (x, eps) result (f) real(default), intent(in) :: x, eps real(default) :: f f = exp (-x / eps) / eps end function peak @ %def peak @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_circe1_ut.f90]]>>= <> module sf_circe1_ut use unit_tests use sf_circe1_uti <> <> contains <> end module sf_circe1_ut @ %def sf_circe1_ut @ <<[[sf_circe1_uti.f90]]>>= <> module sf_circe1_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use rng_base use sf_aux use sf_base use sf_circe1 use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module sf_circe1_uti @ %def sf_circe1_ut @ API: driver for the unit tests below. <>= public :: sf_circe1_test <>= subroutine sf_circe1_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_circe1_test @ %def sf_circe1_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_circe1_1, "sf_circe1_1", & "structure function configuration", & u, results) <>= public :: sf_circe1_1 <>= subroutine sf_circe1_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_circe1_1" write (u, "(A)") "* Purpose: initialize and display & &CIRCE structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (circe1_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (circe1_data_t) call data%init (model, pdg_in, & sqrts = 500._default, & eps = 1e-6_default, & out_photon = [.false., .false.], & ver = 0, & rev = 0, & acc = "SBAND", & chat = 0, & with_radiation = .true.) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe1_1" end subroutine sf_circe1_1 @ %def sf_circe1_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the PDF builtin structure function. <>= call test (sf_circe1_2, "sf_circe1_2", & "structure function instance", & u, results) <>= public :: sf_circe1_2 <>= subroutine sf_circe1_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 type(vector4_t), dimension(4) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_circe1_2" write (u, "(A)") "* Purpose: initialize and fill & &circe1 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (circe1_data_t :: data) select type (data) type is (circe1_data_t) call data%init (model, pdg_in, & sqrts = 500._default, & eps = 1e-6_default, & out_photon = [.false., .false.], & ver = 0, & rev = 0, & acc = "SBAND", & chat = 0, & with_radiation = .true.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.95,0.85." write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.9_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1, 2]) call sf_int%seed_kinematics ([k1, k2]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe1_2" end subroutine sf_circe1_2 @ %def sf_circe1_2 @ \subsubsection{Generator mode} Construct and evaluate a structure function object in generator mode. <>= call test (sf_circe1_3, "sf_circe1_3", & "generator mode", & u, results) <>= public :: sf_circe1_3 <>= subroutine sf_circe1_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_circe1_3" write (u, "(A)") "* Purpose: initialize and fill & &circe1 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (circe1_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe1_data_t) call data%init (model, pdg_in, & sqrts = 500._default, & eps = 1e-6_default, & out_photon = [.false., .false.], & ver = 0, & rev = 0, & acc = "SBAND", & chat = 0, & with_radiation = .true.) call data%set_generator_mode (rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) select type (sf_int) type is (circe1_t) call sf_int%rng_obj%rng%init (3) end select write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe1_3" end subroutine sf_circe1_3 @ %def sf_circe1_3 @ \clearpage %------------------------------------------------------------------------ \section{Lepton Collider Beamstrahlung and Photon collider: CIRCE2} <<[[sf_circe2.f90]]>>= <> module sf_circe2 <> <> use io_units use format_defs, only: FMT_19 use numeric_utils use diagnostics use os_interface use physics_defs, only: PHOTON, ELECTRON use lorentz use rng_base use selectors use pdg_arrays use model_data use flavors use colors use helicities use quantum_numbers use state_matrices use polarizations use sf_base use circe2, circe2_rng_t => rng_type !NODEP! <> <> <> contains <> end module sf_circe2 @ %def sf_circe2 @ \subsection{Physics} [[CIRCE2]] describes photon spectra Beamstrahlung is applied before ISR. The [[CIRCE2]] implementation has a single structure function for both beams (which makes sense since it has to be switched on or off for both beams simultaneously). \subsection{The CIRCE2 data block} The CIRCE2 parameters are: file and collider specification, incoming (= outgoing) particles. The luminosity is returned by [[circe2_luminosity]]. <>= public :: circe2_data_t <>= type, extends (sf_data_t) :: circe2_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(2) :: flv_in integer, dimension(2) :: pdg_in real(default) :: sqrts = 0 logical :: polarized = .false. logical :: beams_polarized = .false. class(rng_factory_t), allocatable :: rng_factory type(string_t) :: filename type(string_t) :: file type(string_t) :: design real(default) :: lumi = 0 real(default), dimension(4) :: lumi_hel_frac = 0 integer, dimension(0:4) :: h1 = [0, -1, -1, 1, 1] integer, dimension(0:4) :: h2 = [0, -1, 1,-1, 1] integer :: error = 1 contains <> end type circe2_data_t @ %def circe2_data_t <>= type(circe2_state) :: circe2_global_state @ <>= procedure :: init => circe2_data_init <>= subroutine circe2_data_init (data, os_data, model, pdg_in, & sqrts, polarized, beam_pol, file, design) class(circe2_data_t), intent(out) :: data type(os_data_t), intent(in) :: os_data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in) :: sqrts logical, intent(in) :: polarized, beam_pol type(string_t), intent(in) :: file, design integer :: h data%model => model if (any (pdg_in%get_length () /= 1)) then call msg_fatal ("CIRCE2: incoming beam particles must be unique") end if call data%flv_in(1)%init (pdg_in(1)%get (1), model) call data%flv_in(2)%init (pdg_in(2)%get (1), model) data%pdg_in = data%flv_in%get_pdg () data%sqrts = sqrts data%polarized = polarized data%beams_polarized = beam_pol data%filename = file data%design = design call data%check_file (os_data) call circe2_load (circe2_global_state, trim (char(data%file)), & trim (char(data%design)), data%sqrts, data%error) call data%check () data%lumi = circe2_luminosity (circe2_global_state, data%pdg_in, [0, 0]) if (vanishes (data%lumi)) then call msg_fatal ("CIRCE2: luminosity vanishes for specified beams.") end if if (data%polarized) then do h = 1, 4 data%lumi_hel_frac(h) = & circe2_luminosity (circe2_global_state, data%pdg_in, & [data%h1(h), data%h2(h)]) & / data%lumi end do end if end subroutine circe2_data_init @ %def circe2_data_init @ Activate the generator mode. We import a RNG factory into the data type, which can then spawn RNG generator objects. <>= procedure :: set_generator_mode => circe2_data_set_generator_mode <>= subroutine circe2_data_set_generator_mode (data, rng_factory) class(circe2_data_t), intent(inout) :: data class(rng_factory_t), intent(inout), allocatable :: rng_factory call move_alloc (from = rng_factory, to = data%rng_factory) end subroutine circe2_data_set_generator_mode @ %def circe2_data_set_generator_mode @ Check whether the requested data file is in the system directory or in the current directory. <>= procedure :: check_file => circe2_check_file <>= subroutine circe2_check_file (data, os_data) class(circe2_data_t), intent(inout) :: data type(os_data_t), intent(in) :: os_data logical :: exist type(string_t) :: file file = data%filename if (file == "") & call msg_fatal ("CIRCE2: $circe2_file is not set") inquire (file = char (file), exist = exist) if (exist) then data%file = file else file = os_data%whizard_circe2path // "/" // data%filename inquire (file = char (file), exist = exist) if (exist) then data%file = file else call msg_fatal ("CIRCE2: data file '" // char (data%filename) & // "' not found") end if end if end subroutine circe2_check_file @ %def circe2_check_file @ Handle error conditions. <>= procedure :: check => circe2_data_check <>= subroutine circe2_data_check (data) class(circe2_data_t), intent(in) :: data type(flavor_t) :: flv_photon, flv_electron call flv_photon%init (PHOTON, data%model) if (.not. flv_photon%is_defined ()) then call msg_fatal ("CIRCE2: model must contain photon") end if call flv_electron%init (ELECTRON, data%model) if (.not. flv_electron%is_defined ()) then call msg_fatal ("CIRCE2: model must contain electron") end if if (any (abs (data%pdg_in) /= PHOTON .and. abs (data%pdg_in) /= ELECTRON)) & then call msg_fatal ("CIRCE2: applicable only for e+e- or photon collisions") end if select case (data%error) case (-1) call msg_fatal ("CIRCE2: data file not found.") case (-2) call msg_fatal ("CIRCE2: beam setup does not match data file.") case (-3) call msg_fatal ("CIRCE2: invalid format of data file.") case (-4) call msg_fatal ("CIRCE2: data file too large.") end select end subroutine circe2_data_check @ %def circe2_data_check @ Output <>= procedure :: write => circe2_data_write <>= subroutine circe2_data_write (data, unit, verbose) class(circe2_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, h logical :: verb verb = .false.; if (present (verbose)) verb = verbose u = given_output_unit (unit) write (u, "(1x,A)") "CIRCE2 data:" write (u, "(3x,A,A)") "file = ", char(data%filename) write (u, "(3x,A,A)") "design = ", char(data%design) write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", data%sqrts write (u, "(3x,A,A,A,A)") "prt_in = ", & char (data%flv_in(1)%get_name ()), & ", ", char (data%flv_in(2)%get_name ()) write (u, "(3x,A,L1)") "polarized = ", data%polarized write (u, "(3x,A,L1)") "beams pol. = ", data%beams_polarized write (u, "(3x,A," // FMT_19 // ")") "luminosity = ", data%lumi if (data%polarized) then do h = 1, 4 write (u, "(6x,'(',I2,1x,I2,')',1x,'=',1x)", advance="no") & data%h1(h), data%h2(h) write (u, "(6x, " // FMT_19 // ")") data%lumi_hel_frac(h) end do end if if (verb) then call data%rng_factory%write (u) end if end subroutine circe2_data_write @ %def circe2_data_write @ This is always in generator mode. <>= procedure :: is_generator => circe2_data_is_generator <>= function circe2_data_is_generator (data) result (flag) class(circe2_data_t), intent(in) :: data logical :: flag flag = .true. end function circe2_data_is_generator @ %def circe2_data_is_generator @ The number of parameters is two, collinear splitting for the two beams. <>= procedure :: get_n_par => circe2_data_get_n_par <>= function circe2_data_get_n_par (data) result (n) class(circe2_data_t), intent(in) :: data integer :: n n = 2 end function circe2_data_get_n_par @ %def circe2_data_get_n_par @ Return the outgoing particles PDG codes. They are equal to the incoming ones. <>= procedure :: get_pdg_out => circe2_data_get_pdg_out <>= subroutine circe2_data_get_pdg_out (data, pdg_out) class(circe2_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%pdg_in(i) end do end subroutine circe2_data_get_pdg_out @ %def circe2_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => circe2_data_allocate_sf_int <>= subroutine circe2_data_allocate_sf_int (data, sf_int) class(circe2_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (circe2_t :: sf_int) end subroutine circe2_data_allocate_sf_int @ %def circe2_data_allocate_sf_int @ Return the beam file. <>= procedure :: get_beam_file => circe2_data_get_beam_file <>= function circe2_data_get_beam_file (data) result (file) class(circe2_data_t), intent(in) :: data type(string_t) :: file file = "CIRCE2: " // data%filename end function circe2_data_get_beam_file @ %def circe2_data_get_beam_file @ \subsection{Random Number Generator for CIRCE} The CIRCE implementation now supports a generic random-number generator object that allows for a local state as a component. To support this, we must extend the abstract type provided by CIRCE and delegate the generator call to the (also abstract) RNG used by WHIZARD. <>= type, extends (circe2_rng_t) :: rng_obj_t class(rng_t), allocatable :: rng contains procedure :: generate => rng_obj_generate end type rng_obj_t @ %def rng_obj_t <>= subroutine rng_obj_generate (rng_obj, u) class(rng_obj_t), intent(inout) :: rng_obj real(default), intent(out) :: u real(default) :: x call rng_obj%rng%generate (x) u = x end subroutine rng_obj_generate @ %def rng_obj_generate @ \subsection{The CIRCE2 object} For CIRCE2 spectra it does not make sense to describe the state matrix as a radiation interaction, even if photons originate from laser backscattering. Instead, it is a $2\to 2$ interaction where the incoming particles are identical to the outgoing ones. The current implementation of CIRCE2 does support polarization and classical correlations, but no entanglement, so the density matrix of the outgoing particles is diagonal. The incoming particles are unpolarized (user-defined polarization for beams is meaningless, since polarization is described by the data file). The outgoing particles are polarized or polarization-averaged, depending on user request. When assigning matrix elements, we scan the previously initialized state matrix. For each entry, we extract helicity and call the structure function. In the unpolarized case, the helicity is undefined and replaced by value zero. In the polarized case, there are four entries. If the generator is used, only one entry is nonzero in each call. Which one, is determined by comparing with a previously (randomly, distributed by relative luminosity) selected pair of helicities. <>= public :: circe2_t <>= type, extends (sf_int_t) :: circe2_t type(circe2_data_t), pointer :: data => null () type(rng_obj_t) :: rng_obj type(selector_t) :: selector integer :: h_sel = 0 contains <> end type circe2_t @ %def circe2_t @ Type string: show file and design of [[CIRCE2]] structure function. <>= procedure :: type_string => circe2_type_string <>= function circe2_type_string (object) result (string) class(circe2_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "CIRCE2: " // object%data%design else string = "CIRCE2: [undefined]" end if end function circe2_type_string @ %def circe2_type_string @ @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => circe2_write <>= subroutine circe2_write (object, unit, testflag) class(circe2_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "CIRCE2 data: [undefined]" end if end subroutine circe2_write @ %def circe2_write @ <>= procedure :: init => circe2_init <>= subroutine circe2_init (sf_int, data) class(circe2_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data logical, dimension(4) :: mask_h real(default), dimension(2) :: m2_array real(default), dimension(0) :: null_array type(quantum_numbers_mask_t), dimension(4) :: mask type(quantum_numbers_t), dimension(4) :: qn type(helicity_t) :: hel type(color_t) :: col0 integer :: h select type (data) type is (circe2_data_t) if (data%polarized .and. data%beams_polarized) then call msg_fatal ("CIRCE2: Beam polarization can't be set & &for polarized data file") else if (data%beams_polarized) then call msg_warning ("CIRCE2: User-defined beam polarization set & &for unpolarized CIRCE2 data file") end if mask_h(1:2) = .not. data%beams_polarized mask_h(3:4) = .not. (data%polarized .or. data%beams_polarized) mask = quantum_numbers_mask (.false., .false., mask_h) m2_array(:) = (data%flv_in(:)%get_mass ())**2 call sf_int%base_init (mask, m2_array, null_array, m2_array) sf_int%data => data if (data%polarized) then if (vanishes (sum (data%lumi_hel_frac)) .or. & any (data%lumi_hel_frac < 0)) then call msg_fatal ("CIRCE2: Helicity-dependent lumi " & // "fractions all vanish or", & [var_str ("are negative: Please inspect the " & // "CIRCE2 file or "), & var_str ("switch off the polarized" // & " option for CIRCE2.")]) else call sf_int%selector%init (data%lumi_hel_frac) end if end if call col0%init () if (data%beams_polarized) then do h = 1, 4 call hel%init (data%h1(h)) call qn(1)%init & (flv = data%flv_in(1), col = col0, hel = hel) call qn(3)%init & (flv = data%flv_in(1), col = col0, hel = hel) call hel%init (data%h2(h)) call qn(2)%init & (flv = data%flv_in(2), col = col0, hel = hel) call qn(4)%init & (flv = data%flv_in(2), col = col0, hel = hel) call sf_int%add_state (qn) end do else if (data%polarized) then call qn(1)%init (flv = data%flv_in(1), col = col0) call qn(2)%init (flv = data%flv_in(2), col = col0) do h = 1, 4 call hel%init (data%h1(h)) call qn(3)%init & (flv = data%flv_in(1), col = col0, hel = hel) call hel%init (data%h2(h)) call qn(4)%init & (flv = data%flv_in(2), col = col0, hel = hel) call sf_int%add_state (qn) end do else call qn(1)%init (flv = data%flv_in(1), col = col0) call qn(2)%init (flv = data%flv_in(2), col = col0) call qn(3)%init (flv = data%flv_in(1), col = col0) call qn(4)%init (flv = data%flv_in(2), col = col0) call sf_int%add_state (qn) end if call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%data%rng_factory%make (sf_int%rng_obj%rng) sf_int%status = SF_INITIAL end select end subroutine circe2_init @ %def circe2_init @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => circe2_is_generator <>= function circe2_is_generator (sf_int) result (flag) class(circe2_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function circe2_is_generator @ %def circe2_is_generator @ Generate free parameters. We first select a helicity, which we have to store, then generate $x$ values for that helicity. <>= procedure :: generate_free => circe2_generate_whizard_free <>= subroutine circe2_generate_whizard_free (sf_int, r, rb, x_free) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free integer :: h_sel if (sf_int%data%polarized) then call sf_int%selector%generate (sf_int%rng_obj%rng, h_sel) else h_sel = 0 end if sf_int%h_sel = h_sel call circe2_generate_whizard (r, sf_int%data%pdg_in, & [sf_int%data%h1(h_sel), sf_int%data%h2(h_sel)], & sf_int%rng_obj) rb = 1 - r x_free = x_free * product (r) end subroutine circe2_generate_whizard_free @ %def circe2_generate_whizard_free @ Generator mode: call the CIRCE2 generator for the given particles and helicities. (For unpolarized generation, helicities are zero.) <>= subroutine circe2_generate_whizard (x, pdg, hel, rng_obj) real(default), dimension(2), intent(out) :: x integer, dimension(2), intent(in) :: pdg integer, dimension(2), intent(in) :: hel class(rng_obj_t), intent(inout) :: rng_obj call circe2_generate (circe2_global_state, rng_obj, x, pdg, hel) end subroutine circe2_generate_whizard @ %def circe2_generate_whizard @ Set kinematics. Trivial here. <>= procedure :: complete_kinematics => circe2_complete_kinematics <>= subroutine circe2_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("CIRCE2: map flag not supported") else x = r xb= rb f = 1 end if call sf_int%reduce_momenta (x) end subroutine circe2_complete_kinematics @ %def circe2_complete_kinematics @ Compute inverse kinematics. <>= procedure :: inverse_kinematics => circe2_inverse_kinematics <>= subroutine circe2_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("CIRCE2: map flag not supported") else r = x rb= xb f = 1 end if if (set_mom) then call sf_int%reduce_momenta (x) end if end subroutine circe2_inverse_kinematics @ %def circe2_inverse_kinematics @ \subsection{CIRCE2 application} This function works on both beams. In polarized mode, we set only the selected helicity. In unpolarized mode, the interaction has only one entry, and the factor is unity. <>= procedure :: apply => circe2_apply <>= subroutine circe2_apply (sf_int, scale, negative_sf, rescale, i_sub) class(circe2_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub complex(default) :: f associate (data => sf_int%data) f = 1 if (data%beams_polarized) then call sf_int%set_matrix_element (f) else if (data%polarized) then call sf_int%set_matrix_element (sf_int%h_sel, f) else call sf_int%set_matrix_element (1, f) end if end associate sf_int%status = SF_EVALUATED end subroutine circe2_apply @ %def circe2_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_circe2_ut.f90]]>>= <> module sf_circe2_ut use unit_tests use sf_circe2_uti <> <> contains <> end module sf_circe2_ut @ %def sf_circe2_ut @ <<[[sf_circe2_uti.f90]]>>= <> module sf_circe2_uti <> <> use os_interface use physics_defs, only: PHOTON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use rng_base use sf_aux use sf_base use sf_circe2 use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module sf_circe2_uti @ %def sf_circe2_ut @ API: driver for the unit tests below. <>= public :: sf_circe2_test <>= subroutine sf_circe2_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_circe2_test @ %def sf_circe2_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_circe2_1, "sf_circe2_1", & "structure function configuration", & u, results) <>= public :: sf_circe2_1 <>= subroutine sf_circe2_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data class(rng_factory_t), allocatable :: rng_factory write (u, "(A)") "* Test output: sf_circe2_1" write (u, "(A)") "* Purpose: initialize and display & &CIRCE structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call os_data%init () call model%init_qed_test () pdg_in(1) = PHOTON pdg_in(2) = PHOTON allocate (circe2_data_t :: data) allocate (rng_test_factory_t :: rng_factory) write (u, "(A)") write (u, "(A)") "* Initialize (unpolarized)" write (u, "(A)") select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .false., & beam_pol = .false., & file = var_str ("teslagg_500_polavg.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select call data%write (u, verbose = .true.) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 write (u, "(A)") write (u, "(A)") "* Initialize (polarized)" write (u, "(A)") allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .true., & beam_pol = .false., & file = var_str ("teslagg_500.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select call data%write (u, verbose = .true.) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe2_1" end subroutine sf_circe2_1 @ %def sf_circe2_1 @ \subsubsection{Generator mode, unpolarized} Construct and evaluate a structure function object in generator mode. <>= call test (sf_circe2_2, "sf_circe2_2", & "generator, unpolarized", & u, results) <>= public :: sf_circe2_2 <>= subroutine sf_circe2_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_circe2_2" write (u, "(A)") "* Purpose: initialize and fill & &circe2 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () call model%init_qed_test () call flv(1)%init (PHOTON, model) call flv(2)%init (PHOTON, model) pdg_in(1) = PHOTON pdg_in(2) = PHOTON call reset_interaction_counter () allocate (circe2_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .false., & beam_pol = .false., & file = var_str ("teslagg_500_polavg.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) select type (sf_int) type is (circe2_t) call sf_int%rng_obj%rng%init (3) end select write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe2_2" end subroutine sf_circe2_2 @ %def sf_circe2_2 @ \subsubsection{Generator mode, polarized} Construct and evaluate a structure function object in generator mode. <>= call test (sf_circe2_3, "sf_circe2_3", & "generator, polarized", & u, results) <>= public :: sf_circe2_3 <>= subroutine sf_circe2_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_circe2_3" write (u, "(A)") "* Purpose: initialize and fill & &circe2 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () call model%init_qed_test () call flv(1)%init (PHOTON, model) call flv(2)%init (PHOTON, model) pdg_in(1) = PHOTON pdg_in(2) = PHOTON call reset_interaction_counter () allocate (circe2_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe2_data_t) call data%init (os_data, model, pdg_in, & sqrts = 500._default, & polarized = .true., & beam_pol = .false., & file = var_str ("teslagg_500.circe"), & design = var_str ("TESLA/GG")) call data%set_generator_mode (rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) select type (sf_int) type is (circe2_t) call sf_int%rng_obj%rng%init (3) end select write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe2_3" end subroutine sf_circe2_3 @ %def sf_circe2_3 @ \clearpage %------------------------------------------------------------------------ \section{HOPPET interface} Interface to the HOPPET wrapper necessary to perform the LO vs. NLO matching of processes containing an initial b quark. <<[[hoppet_interface.f90]]>>= <> module hoppet_interface use lhapdf !NODEP! <> public :: hoppet_init, hoppet_eval contains subroutine hoppet_init (pdf_builtin, pdf, pdf_id) logical, intent(in) :: pdf_builtin type(lhapdf_pdf_t), intent(inout), optional :: pdf integer, intent(in), optional :: pdf_id external InitForWhizard call InitForWhizard (pdf_builtin, pdf, pdf_id) end subroutine hoppet_init subroutine hoppet_eval (x, q, f) double precision, intent(in) :: x, q double precision, intent(out) :: f(-6:6) external EvalForWhizard call EvalForWhizard (x, q, f) end subroutine hoppet_eval end module hoppet_interface @ %def hoppet_interface @ \clearpage %------------------------------------------------------------------------ \section{Builtin PDF sets} For convenience in order not to depend on the external package LHAPDF, we ship some PDFs with WHIZARD. @ \subsection{The module} <<[[sf_pdf_builtin.f90]]>>= <> module sf_pdf_builtin <> use kinds, only: double <> use io_units use format_defs, only: FMT_17 use diagnostics use os_interface use physics_defs, only: PROTON, PHOTON, GLUON use physics_defs, only: HADRON_REMNANT_SINGLET use physics_defs, only: HADRON_REMNANT_TRIPLET use physics_defs, only: HADRON_REMNANT_OCTET use sm_qcd use lorentz use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use sf_base use pdf_builtin !NODEP! use hoppet_interface <> <> <> <> contains <> end module sf_pdf_builtin @ %def sf_pdf_builtin @ \subsection{Codes for default PDF sets} <>= character(*), parameter :: PDF_BUILTIN_DEFAULT_PROTON = "CTEQ6L" ! character(*), parameter :: PDF_BUILTIN_DEFAULT_PION = "NONE" ! character(*), parameter :: PDF_BUILTIN_DEFAULT_PHOTON = "MRST2004QEDp" @ %def PDF_BUILTIN_DEFAULT_SET @ \subsection{The PDF builtin data block} The data block holds the incoming flavor (which has to be proton, pion, or photon), the corresponding pointer to the global access data (1, 2, or 3), the flag [[invert]] which is set for an antiproton, the bounds as returned by LHAPDF for the specified set, and a mask that determines which partons will be actually in use. <>= public :: pdf_builtin_data_t <>= type, extends (sf_data_t) :: pdf_builtin_data_t private integer :: id = -1 type (string_t) :: name class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in logical :: invert logical :: has_photon logical :: photon logical, dimension(-6:6) :: mask logical :: mask_photon logical :: hoppet_b_matching = .false. contains <> end type pdf_builtin_data_t @ %def pdf_builtin_data_t @ Generate PDF data and initialize the requested set. Pion and photon PDFs are disabled at the moment until we ship appropiate structure functions. needed. <>= procedure :: init => pdf_builtin_data_init <>= subroutine pdf_builtin_data_init (data, & model, pdg_in, name, path, hoppet_b_matching) class(pdf_builtin_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in type(string_t), intent(in) :: name type(string_t), intent(in) :: path logical, intent(in), optional :: hoppet_b_matching data%model => model if (pdg_in%get_length () /= 1) & call msg_fatal ("PDF: incoming particle must be unique") call data%flv_in%init (pdg_in%get (1), model) data%mask = .true. data%mask_photon = .true. select case (pdg_in%get (1)) case (PROTON) data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON) data%invert = .false. data%photon = .false. case (-PROTON) data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON) data%invert = .true. data%photon = .false. ! case (PIPLUS) ! data%name = var_str (PDF_BUILTIN_DEFAULT_PION) ! data%invert = .false. ! data%photon = .false. ! case (-PIPLUS) ! data%name = var_str (PDF_BUILTIN_DEFAULT_PION) ! data%invert = .true. ! data%photon = .false. ! case (PHOTON) ! data%name = var_str (PDF_BUILTIN_DEFAULT_PHOTON) ! data%invert = .false. ! data%photon = .true. case default call msg_fatal ("PDF: " & // "incoming particle must either proton or antiproton.") return end select data%name = name data%id = pdf_get_id (data%name) if (data%id < 0) call msg_fatal ("unknown PDF set " // char (data%name)) data%has_photon = pdf_provides_photon (data%id) if (present (hoppet_b_matching)) data%hoppet_b_matching = hoppet_b_matching call pdf_init (data%id, path) if (data%hoppet_b_matching) call hoppet_init (.true., pdf_id = data%id) end subroutine pdf_builtin_data_init @ %def pdf_builtin_data_init @ Enable/disable partons explicitly. If a mask entry is true, applying the PDF will generate the corresponding flavor on output. <>= procedure :: set_mask => pdf_builtin_data_set_mask <>= subroutine pdf_builtin_data_set_mask (data, mask) class(pdf_builtin_data_t), intent(inout) :: data logical, dimension(-6:6), intent(in) :: mask data%mask = mask end subroutine pdf_builtin_data_set_mask @ %def pdf_builtin_data_set_mask @ Output. <>= procedure :: write => pdf_builtin_data_write <>= subroutine pdf_builtin_data_write (data, unit, verbose) class(pdf_builtin_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "PDF builtin data:" if (data%id < 0) then write (u, "(3x,A)") "[undefined]" return end if write (u, "(3x,A)", advance="no") "flavor = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A,A)") "name = ", char (data%name) write (u, "(3x,A,L1)") "invert = ", data%invert write (u, "(3x,A,L1)") "has photon = ", data%has_photon write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") & "mask =", & data%mask(-6:-1), "*", data%mask(0), "*", data%mask(1:6) write (u, "(3x,A,L1)") "photon mask = ", data%mask_photon write (u, "(3x,A,L1)") "hoppet_b = ", data%hoppet_b_matching end subroutine pdf_builtin_data_write @ %def pdf_builtin_data_write @ The number of parameters is one. We do not generate transverse momentum. <>= procedure :: get_n_par => pdf_builtin_data_get_n_par <>= function pdf_builtin_data_get_n_par (data) result (n) class(pdf_builtin_data_t), intent(in) :: data integer :: n n = 1 end function pdf_builtin_data_get_n_par @ %def pdf_builtin_data_get_n_par @ Return the outgoing particle PDG codes. This is based on the mask. <>= procedure :: get_pdg_out => pdf_builtin_data_get_pdg_out <>= subroutine pdf_builtin_data_get_pdg_out (data, pdg_out) class(pdf_builtin_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer, dimension(:), allocatable :: pdg1 integer :: n, np, i n = count (data%mask) np = 0; if (data%has_photon .and. data%mask_photon) np = 1 allocate (pdg1 (n + np)) pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask) if (np == 1) pdg1(n+np) = PHOTON pdg_out(1) = pdg1 end subroutine pdf_builtin_data_get_pdg_out @ %def pdf_builtin_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => pdf_builtin_data_allocate_sf_int <>= subroutine pdf_builtin_data_allocate_sf_int (data, sf_int) class(pdf_builtin_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (pdf_builtin_t :: sf_int) end subroutine pdf_builtin_data_allocate_sf_int @ %def pdf_builtin_data_allocate_sf_int @ Return the numerical PDF set index. <>= procedure :: get_pdf_set => pdf_builtin_data_get_pdf_set <>= elemental function pdf_builtin_data_get_pdf_set (data) result (pdf_set) class(pdf_builtin_data_t), intent(in) :: data integer :: pdf_set pdf_set = data%id end function pdf_builtin_data_get_pdf_set @ %def pdf_builtin_data_get_pdf_set @ \subsection{The PDF object} The PDF $1\to 2$ interaction which describes the splitting of an (anti)proton into a parton and a beam remnant. We stay in the strict forward-splitting limit, but allow some invariant mass for the beam remnant such that the outgoing parton is exactly massless. For a real event, we would replace this by a parton cascade, where the outgoing partons have virtuality as dictated by parton-shower kinematics, and transverse momentum is generated. The PDF application is a $1\to 2$ splitting process, where the particles are ordered as (hadron, remnant, parton). Polarization is ignored completely. The beam particle is colorless, while partons and beam remnant carry color. The remnant gets a special flavor code. <>= public :: pdf_builtin_t <>= type, extends (sf_int_t) :: pdf_builtin_t type(pdf_builtin_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: q = 0 contains <> end type pdf_builtin_t @ %def pdf_builtin_t @ Type string: display the chosen PDF set. <>= procedure :: type_string => pdf_builtin_type_string <>= function pdf_builtin_type_string (object) result (string) class(pdf_builtin_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "PDF builtin: " // object%data%name else string = "PDF builtin: [undefined]" end if end function pdf_builtin_type_string @ %def pdf_builtin_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => pdf_builtin_write <>= subroutine pdf_builtin_write (object, unit, testflag) class(pdf_builtin_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A," // FMT_17 // ")") "Q =", object%q end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "PDF builtin data: [undefined]" end if end subroutine pdf_builtin_write @ %def pdf_builtin_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. Optionally, we can provide minimum and maximum values for the momentum transfer. <>= procedure :: init => pdf_builtin_init <>= subroutine pdf_builtin_init (sf_int, data) class(pdf_builtin_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask type(flavor_t) :: flv, flv_remnant type(color_t) :: col0 type(quantum_numbers_t), dimension(3) :: qn integer :: i select type (data) type is (pdf_builtin_data_t) mask = quantum_numbers_mask (.false., .false., .true.) call col0%init () call sf_int%base_init (mask, [0._default], [0._default], [0._default]) sf_int%data => data do i = -6, 6 if (data%mask(i)) then call qn(1)%init (data%flv_in, col = col0) if (i == 0) then call flv%init (GLUON, data%model) call flv_remnant%init (HADRON_REMNANT_OCTET, data%model) else call flv%init (i, data%model) call flv_remnant%init & (sign (HADRON_REMNANT_TRIPLET, -i), data%model) end if call qn(2)%init ( & flv = flv_remnant, col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init ( & flv = flv, col = color_from_flavor (flv, 1, reverse=.true.)) call sf_int%add_state (qn) end if end do if (data%has_photon .and. data%mask_photon) then call flv%init (PHOTON, data%model) call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model) call qn(2)%init (flv = flv_remnant, & col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init (flv = flv, & col = color_from_flavor (flv, 1, reverse = .true.)) call sf_int%add_state (qn) end if call sf_int%freeze () call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) sf_int%status = SF_INITIAL end select end subroutine pdf_builtin_init @ %def pdf_builtin_init @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ and consequently $f(r)=2r$. <>= procedure :: complete_kinematics => pdf_builtin_complete_kinematics <>= subroutine pdf_builtin_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("PDF builtin: map flag not supported") else x(1) = r(1) xb(1)= rb(1) f = 1 end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) case (SF_FAILED_KINEMATICS) sf_int%x = 0 f = 0 end select end subroutine pdf_builtin_complete_kinematics @ %def pdf_builtin_complete_kinematics @ Overriding the default method: we compute the [[x]] value from the momentum configuration. In this specific case, we also set the internally stored $x$ value, so it can be used in the following routine. <>= procedure :: recover_x => pdf_builtin_recover_x <>= subroutine pdf_builtin_recover_x (sf_int, x, xb, x_free) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) end subroutine pdf_builtin_recover_x @ %def sf_pdf_builtin_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => pdf_builtin_inverse_kinematics <>= subroutine pdf_builtin_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("PDF builtin: map flag not supported") else r(1) = x(1) rb(1)= xb(1) f = 1 end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine pdf_builtin_inverse_kinematics @ %def pdf_builtin_inverse_kinematics @ \subsection{Structure function} Once the scale is also known, we can actually call the PDF and set the values. Contrary to LHAPDF, the wrapper already takes care of adjusting to the $x$ and $Q$ bounds. Account for the Jacobian. The parameter [[negative_sf]] is necessary to determine if we allow for negative PDF values. The class [[rescale]] gives rescaling prescription for NLO convolution of the structure function in combination with [[i_sub]]. <>= procedure :: apply => pdf_builtin_apply <>= subroutine pdf_builtin_apply (sf_int, scale, negative_sf, rescale, i_sub) class(pdf_builtin_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default), dimension(-6:6) :: ff real(double), dimension(-6:6) :: ff_dbl real(default) :: x, fph real(double) :: xx, qq complex(default), dimension(:), allocatable :: fc integer :: i, j_sub, i_sub_opt logical :: negative_sf_opt i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub negative_sf_opt = .false.; if (present(negative_sf)) negative_sf_opt = negative_sf associate (data => sf_int%data) sf_int%q = scale x = sf_int%x if (present (rescale)) call rescale%apply (x) if (debug2_active (D_BEAMS)) then call msg_debug2 (D_BEAMS, "pdf_builtin_apply") call msg_debug2 (D_BEAMS, "rescale: ", present(rescale)) call msg_debug2 (D_BEAMS, "i_sub: ", i_sub_opt) call msg_debug2 (D_BEAMS, "x: ", x) end if xx = x qq = scale if (data%invert) then if (data%has_photon) then call pdf_evolve (data%id, x, scale, ff(6:-6:-1), fph) else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff_dbl(6:-6:-1)) ff = ff_dbl else call pdf_evolve (data%id, x, scale, ff(6:-6:-1)) end if end if else if (data%has_photon) then call pdf_evolve (data%id, x, scale, ff, fph) else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff_dbl) ff = ff_dbl else call pdf_evolve (data%id, x, scale, ff) end if end if end if if (data%has_photon) then allocate (fc (count ([data%mask, data%mask_photon]))) if (negative_sf_opt) then fc = pack ([ff, fph], [data%mask, data%mask_photon]) else fc = max( pack ([ff, fph], [data%mask, data%mask_photon]), 0._default) end if else allocate (fc (count (data%mask))) if (negative_sf_opt) then fc = pack (ff, data%mask) else fc = max( pack (ff, data%mask), 0._default) end if end if end associate if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc) call sf_int%set_matrix_element (fc, [(i_sub_opt * size(fc) + i, i = 1, size(fc))]) sf_int%status = SF_EVALUATED end subroutine pdf_builtin_apply @ %def pdf_builtin_apply @ \subsection{Strong Coupling} Since the PDF codes provide a function for computing the running $\alpha_s$ value, we make this available as an implementation of the abstract [[alpha_qcd_t]] type, which is used for matrix element evaluation. <>= public :: alpha_qcd_pdf_builtin_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_pdf_builtin_t type(string_t) :: pdfset_name integer :: pdfset_id = -1 contains <> end type alpha_qcd_pdf_builtin_t @ %def alpha_qcd_pdf_builtin_t @ Output. <>= procedure :: write => alpha_qcd_pdf_builtin_write <>= subroutine alpha_qcd_pdf_builtin_write (object, unit) class(alpha_qcd_pdf_builtin_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A)") "QCD parameters (pdf_builtin):" write (u, "(5x,A,A)") "PDF set = ", char (object%pdfset_name) write (u, "(5x,A,I0)") "PDF ID = ", object%pdfset_id end subroutine alpha_qcd_pdf_builtin_write @ %def alpha_qcd_pdf_builtin_write @ Calculation: the numeric ID selects the correct PDF set, which must be properly initialized. <>= procedure :: get => alpha_qcd_pdf_builtin_get <>= function alpha_qcd_pdf_builtin_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_pdf_builtin_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha alpha = pdf_alphas (alpha_qcd%pdfset_id, scale) end function alpha_qcd_pdf_builtin_get @ %def alpha_qcd_pdf_builtin_get @ Initialization. We need to access the global initialization status. <>= procedure :: init => alpha_qcd_pdf_builtin_init <>= subroutine alpha_qcd_pdf_builtin_init (alpha_qcd, name, path) class(alpha_qcd_pdf_builtin_t), intent(out) :: alpha_qcd type(string_t), intent(in) :: name type(string_t), intent(in) :: path alpha_qcd%pdfset_name = name alpha_qcd%pdfset_id = pdf_get_id (name) if (alpha_qcd%pdfset_id < 0) & call msg_fatal ("QCD parameter initialization: PDF set " & // char (name) // " is unknown") call pdf_init (alpha_qcd%pdfset_id, path) end subroutine alpha_qcd_pdf_builtin_init @ %def alpha_qcd_pdf_builtin_init @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_pdf_builtin_ut.f90]]>>= <> module sf_pdf_builtin_ut use unit_tests use sf_pdf_builtin_uti <> <> contains <> end module sf_pdf_builtin_ut @ %def sf_pdf_builtin_ut @ <<[[sf_pdf_builtin_uti.f90]]>>= <> module sf_pdf_builtin_uti <> <> use os_interface use physics_defs, only: PROTON use sm_qcd use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_base use sf_pdf_builtin <> <> contains <> end module sf_pdf_builtin_uti @ %def sf_pdf_builtin_ut @ API: driver for the unit tests below. <>= public :: sf_pdf_builtin_test <>= subroutine sf_pdf_builtin_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_pdf_builtin_test @ %def sf_pdf_builtin_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_pdf_builtin_1, "sf_pdf_builtin_1", & "structure function configuration", & u, results) <>= public :: sf_pdf_builtin_1 <>= subroutine sf_pdf_builtin_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data type(string_t) :: name write (u, "(A)") "* Test output: sf_pdf_builtin_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call os_data%init () call model%init_sm_test () pdg_in = PROTON allocate (pdf_builtin_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") name = "CTEQ6L" select type (data) type is (pdf_builtin_data_t) call data%init (model, pdg_in, name, & os_data%pdf_builtin_datapath) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_pdf_builtin_1" end subroutine sf_pdf_builtin_1 @ %def sf_pdf_builtin_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the PDF builtin structure function. <>= call test (sf_pdf_builtin_2, "sf_pdf_builtin_2", & "structure function instance", & u, results) <>= public :: sf_pdf_builtin_2 <>= subroutine sf_pdf_builtin_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(string_t) :: name type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_pdf_builtin_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () call model%init_sm_test () call flv%init (PROTON, model) pdg_in = PROTON call reset_interaction_counter () name = "CTEQ6L" allocate (pdf_builtin_data_t :: data) select type (data) type is (pdf_builtin_data_t) call data%init (model, pdg_in, name, & os_data%pdf_builtin_datapath) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.5_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100 GeV" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_pdf_builtin_2" end subroutine sf_pdf_builtin_2 @ %def sf_pdf_builtin_2 @ \subsubsection{Strong Coupling} Test $\alpha_s$ as an implementation of the [[alpha_qcd_t]] abstract type. <>= call test (sf_pdf_builtin_3, "sf_pdf_builtin_3", & "running alpha_s", & u, results) <>= public :: sf_pdf_builtin_3 <>= subroutine sf_pdf_builtin_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(qcd_t) :: qcd type(string_t) :: name write (u, "(A)") "* Test output: sf_pdf_builtin_3" write (u, "(A)") "* Purpose: initialize and evaluate alpha_s" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call os_data%init () name = "CTEQ6L" write (u, "(A)") "* Initialize qcd object" write (u, "(A)") allocate (alpha_qcd_pdf_builtin_t :: qcd%alpha) select type (alpha => qcd%alpha) type is (alpha_qcd_pdf_builtin_t) call alpha%init (name, os_data%pdf_builtin_datapath) end select call qcd%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100" write (u, "(A)") write (u, "(1x,A,F8.5)") "alpha = ", qcd%alpha%get (100._default) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") write (u, "(A)") "* Test output end: sf_pdf_builtin_3" end subroutine sf_pdf_builtin_3 @ %def sf_pdf_builtin_3 @ \clearpage %------------------------------------------------------------------------ \section{LHAPDF} Parton distribution functions (PDFs) are available via an interface to the LHAPDF standard library. @ \subsection{The module} <<[[sf_lhapdf.f90]]>>= <> module sf_lhapdf <> <> use format_defs, only: FMT_17, FMT_19 use io_units use system_dependencies, only: LHAPDF_PDFSETS_PATH use system_dependencies, only: LHAPDF5_AVAILABLE use system_dependencies, only: LHAPDF6_AVAILABLE use diagnostics use physics_defs, only: PROTON, PHOTON, PIPLUS, GLUON use physics_defs, only: HADRON_REMNANT_SINGLET use physics_defs, only: HADRON_REMNANT_TRIPLET use physics_defs, only: HADRON_REMNANT_OCTET use lorentz use sm_qcd use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use sf_base use lhapdf !NODEP! use hoppet_interface <> <> <> <> <> <> contains <> end module sf_lhapdf @ %def sf_lhapdf @ \subsection{Codes for default PDF sets} The default PDF for protons set is chosen to be CTEQ6ll (LO fit with LO $\alpha_s$). <>= character(*), parameter :: LHAPDF5_DEFAULT_PROTON = "cteq6ll.LHpdf" character(*), parameter :: LHAPDF5_DEFAULT_PION = "ABFKWPI.LHgrid" character(*), parameter :: LHAPDF5_DEFAULT_PHOTON = "GSG960.LHgrid" character(*), parameter :: LHAPDF6_DEFAULT_PROTON = "CT10" @ %def LHAPDF5_DEFAULT_PROTON LHAPDF5_DEFAULT_PION @ %def LHAPDF5_DEFAULT_PHOTON LHAPDF6_DEFAULT_PROTON @ \subsection{LHAPDF library interface} Here we specify explicit interfaces for all LHAPDF routines that we use below. <>= interface subroutine InitPDFsetM (set, file) integer, intent(in) :: set character(*), intent(in) :: file end subroutine InitPDFsetM end interface @ %def InitPDFsetM <>= interface subroutine InitPDFM (set, mem) integer, intent(in) :: set, mem end subroutine InitPDFM end interface @ %def InitPDFM <>= interface subroutine numberPDFM (set, n_members) integer, intent(in) :: set integer, intent(out) :: n_members end subroutine numberPDFM end interface @ %def numberPDFM <>= interface subroutine evolvePDFM (set, x, q, ff) integer, intent(in) :: set double precision, intent(in) :: x, q double precision, dimension(-6:6), intent(out) :: ff end subroutine evolvePDFM end interface @ %def evolvePDFM <>= interface subroutine evolvePDFphotonM (set, x, q, ff, fphot) integer, intent(in) :: set double precision, intent(in) :: x, q double precision, dimension(-6:6), intent(out) :: ff double precision, intent(out) :: fphot end subroutine evolvePDFphotonM end interface @ %def evolvePDFphotonM <>= interface subroutine evolvePDFpM (set, x, q, s, scheme, ff) integer, intent(in) :: set double precision, intent(in) :: x, q, s integer, intent(in) :: scheme double precision, dimension(-6:6), intent(out) :: ff end subroutine evolvePDFpM end interface @ %def evolvePDFpM <>= interface subroutine GetXminM (set, mem, xmin) integer, intent(in) :: set, mem double precision, intent(out) :: xmin end subroutine GetXminM end interface @ %def GetXminM <>= interface subroutine GetXmaxM (set, mem, xmax) integer, intent(in) :: set, mem double precision, intent(out) :: xmax end subroutine GetXmaxM end interface @ %def GetXmaxM <>= interface subroutine GetQ2minM (set, mem, q2min) integer, intent(in) :: set, mem double precision, intent(out) :: q2min end subroutine GetQ2minM end interface @ %def GetQ2minM <>= interface subroutine GetQ2maxM (set, mem, q2max) integer, intent(in) :: set, mem double precision, intent(out) :: q2max end subroutine GetQ2maxM end interface @ %def GetQ2maxM <>= interface function has_photon () result(flag) logical :: flag end function has_photon end interface @ %def has_photon @ \subsection{The LHAPDF status} This type holds the initialization status of the LHAPDF system. Entry 1 is for proton PDFs, entry 2 for pion PDFs, entry 3 for photon PDFs. Since it is connected to the external LHAPDF library, this is a truly global object. We implement it as a a private module variable. To access it from elsewhere, the caller has to create and initialize an object of type [[lhapdf_status_t]], which acts as a proxy. <>= type :: lhapdf_global_status_t private logical, dimension(3) :: initialized = .false. end type lhapdf_global_status_t @ %def lhapdf_global_status_t <>= type(lhapdf_global_status_t), save :: lhapdf_global_status @ %def lhapdf_global_status <>= function lhapdf_global_status_is_initialized (set) result (flag) logical :: flag integer, intent(in), optional :: set if (present (set)) then select case (set) case (1:3); flag = lhapdf_global_status%initialized(set) case default; flag = .false. end select else flag = any (lhapdf_global_status%initialized) end if end function lhapdf_global_status_is_initialized @ %def lhapdf_global_status_is_initialized <>= subroutine lhapdf_global_status_set_initialized (set) integer, intent(in) :: set lhapdf_global_status%initialized(set) = .true. end subroutine lhapdf_global_status_set_initialized @ %def lhapdf_global_status_set_initialized @ This is the only public procedure, it tells the system to forget about previous initialization, allowing for changing the chosen PDF set. Note that such a feature works only if the global program flow is serial, so no two distinct sets are accessed simultaneously. But this applies to LHAPDF anyway. <>= public :: lhapdf_global_reset <>= subroutine lhapdf_global_reset () lhapdf_global_status%initialized = .false. end subroutine lhapdf_global_reset @ %def lhapdf_global_status_reset @ \subsection{LHAPDF initialization} Before using LHAPDF, we have to initialize it with a particular data set and member. This applies not just if we use structure functions, but also if we just use an $\alpha_s$ formula. The integer [[set]] should be $1$ for proton, $2$ for pion, and $3$ for photon, but this is just convention. It appears as if LHAPDF does not allow for multiple data sets being used concurrently (?), so multi-threaded usage with different sets (e.g., a scan) is excluded. The current setup with a global flag that indicates initialization is fine as long as Whizard itself is run in serial mode at the Sindarin level. If we introduce multithreading in any form from Sindarin, we have to rethink the implementation of the LHAPDF interface. (The same considerations apply to builtin PDFs.) If the particular set has already been initialized, do nothing. This implies that whenever we want to change the setup for a particular set, we have to reset the LHAPDF status. [[lhapdf_initialize]] has an obvious name clash with [[lhapdf_init]], the reason it works for [[pdf_builtin]] is that there things are outsourced to a separate module (inc. [[lhapdf_status]] etc.). <>= public :: lhapdf_initialize <>= subroutine lhapdf_initialize (set, prefix, file, member, pdf, b_match) integer, intent(in) :: set type(string_t), intent(inout) :: prefix type(string_t), intent(inout) :: file type(lhapdf_pdf_t), intent(inout), optional :: pdf integer, intent(inout) :: member logical, intent(in), optional :: b_match if (prefix == "") prefix = LHAPDF_PDFSETS_PATH if (LHAPDF5_AVAILABLE) then if (lhapdf_global_status_is_initialized (set)) return if (file == "") then select case (set) case (1); file = LHAPDF5_DEFAULT_PROTON case (2); file = LHAPDF5_DEFAULT_PION case (3); file = LHAPDF5_DEFAULT_PHOTON end select end if if (data_file_exists (prefix // "/" // file)) then call InitPDFsetM (set, char (prefix // "/" // file)) else call msg_fatal ("LHAPDF: Data file '" & // char (file) // "' not found in '" // char (prefix) // "'.") return end if if (.not. dataset_member_exists (set, member)) then call msg_error (" LHAPDF: Chosen member does not exist for set '" & // char (file) // "', using default.") member = 0 end if call InitPDFM (set, member) else if (LHAPDF6_AVAILABLE) then ! TODO: (bcn 2015-07-07) we should have a closer look why this global ! check must not be executed ! if (lhapdf_global_status_is_initialized (set) .and. & ! pdf%is_associated ()) return if (file == "") then select case (set) case (1); file = LHAPDF6_DEFAULT_PROTON case (2); call msg_fatal ("LHAPDF6: no pion PDFs supported") case (3); call msg_fatal ("LHAPDF6: no photon PDFs supported") end select end if if (data_file_exists (prefix // "/" // file // "/" // file // ".info")) then call pdf%init (char (file), member) else call msg_fatal ("LHAPDF: Data file '" & // char (file) // "' not found in '" // char (prefix) // "'.") return end if end if if (present (b_match)) then if (b_match) then if (LHAPDF5_AVAILABLE) then call hoppet_init (.false.) else if (LHAPDF6_AVAILABLE) then call hoppet_init (.false., pdf) end if end if end if call lhapdf_global_status_set_initialized (set) contains function data_file_exists (fq_name) result (exist) type(string_t), intent(in) :: fq_name logical :: exist inquire (file = char(fq_name), exist = exist) end function data_file_exists function dataset_member_exists (set, member) result (exist) integer, intent(in) :: set, member logical :: exist integer :: n_members call numberPDFM (set, n_members) exist = member >= 0 .and. member <= n_members end function dataset_member_exists end subroutine lhapdf_initialize @ %def lhapdf_initialize @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ and consequently $f(r)=2r$. <>= procedure :: complete_kinematics => lhapdf_complete_kinematics <>= subroutine lhapdf_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(lhapdf_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("LHAPDF: map flag not supported") else x(1) = r(1) xb(1)= rb(1) f = 1 end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) case (SF_FAILED_KINEMATICS) sf_int%x = 0 f = 0 end select end subroutine lhapdf_complete_kinematics @ %def lhapdf_complete_kinematics @ Overriding the default method: we compute the [[x]] value from the momentum configuration. In this specific case, we also set the internally stored $x$ value, so it can be used in the following routine. <>= procedure :: recover_x => lhapdf_recover_x <>= subroutine lhapdf_recover_x (sf_int, x, xb, x_free) class(lhapdf_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) end subroutine lhapdf_recover_x @ %def lhapdf_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => lhapdf_inverse_kinematics <>= subroutine lhapdf_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(lhapdf_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("LHAPDF: map flag not supported") else r(1) = x(1) rb(1)= xb(1) f = 1 end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine lhapdf_inverse_kinematics @ %def lhapdf_inverse_kinematics @ \subsection{The LHAPDF data block} The data block holds the incoming flavor (which has to be proton, pion, or photon), the corresponding pointer to the global access data (1, 2, or 3), the flag [[invert]] which is set for an antiproton, the bounds as returned by LHAPDF for the specified set, and a mask that determines which partons will be actually in use. <>= public :: lhapdf_data_t <>= type, extends (sf_data_t) :: lhapdf_data_t private type(string_t) :: prefix type(string_t) :: file type(lhapdf_pdf_t) :: pdf integer :: member = 0 class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in integer :: set = 0 logical :: invert = .false. logical :: photon = .false. logical :: has_photon = .false. integer :: photon_scheme = 0 real(default) :: xmin = 0, xmax = 0 real(default) :: qmin = 0, qmax = 0 logical, dimension(-6:6) :: mask = .true. logical :: mask_photon = .true. logical :: hoppet_b_matching = .false. contains <> end type lhapdf_data_t @ %def lhapdf_data_t @ Generate PDF data. This is provided as a function, but it has the side-effect of initializing the requested PDF set. A finalizer is not needed. The library uses double precision, so since the default precision may be extended or quadruple, we use auxiliary variables for type casting. <>= procedure :: init => lhapdf_data_init <>= subroutine lhapdf_data_init & (data, model, pdg_in, prefix, file, member, photon_scheme, & hoppet_b_matching) class(lhapdf_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in type(string_t), intent(in), optional :: prefix, file integer, intent(in), optional :: member integer, intent(in), optional :: photon_scheme logical, intent(in), optional :: hoppet_b_matching double precision :: xmin, xmax, q2min, q2max external :: InitPDFsetM, InitPDFM, numberPDFM external :: GetXminM, GetXmaxM, GetQ2minM, GetQ2maxM if (.not. LHAPDF5_AVAILABLE .and. .not. LHAPDF6_AVAILABLE) then call msg_fatal ("LHAPDF requested but library is not linked") return end if data%model => model if (pdg_in%get_length () /= 1) & call msg_fatal ("PDF: incoming particle must be unique") call data%flv_in%init (pdg_in%get (1), model) select case (pdg_in%get (1)) case (PROTON) data%set = 1 case (-PROTON) data%set = 1 data%invert = .true. case (PIPLUS) data%set = 2 case (-PIPLUS) data%set = 2 data%invert = .true. case (PHOTON) data%set = 3 data%photon = .true. if (present (photon_scheme)) data%photon_scheme = photon_scheme case default call msg_fatal (" LHAPDF: " & // "incoming particle must be (anti)proton, pion, or photon.") return end select if (present (prefix)) then data%prefix = prefix else data%prefix = "" end if if (present (file)) then data%file = file else data%file = "" end if if (present (hoppet_b_matching)) data%hoppet_b_matching = hoppet_b_matching if (LHAPDF5_AVAILABLE) then call lhapdf_initialize (data%set, & data%prefix, data%file, data%member, & b_match = data%hoppet_b_matching) call GetXminM (data%set, data%member, xmin) call GetXmaxM (data%set, data%member, xmax) call GetQ2minM (data%set, data%member, q2min) call GetQ2maxM (data%set, data%member, q2max) data%xmin = xmin data%xmax = xmax data%qmin = sqrt (q2min) data%qmax = sqrt (q2max) data%has_photon = has_photon () else if (LHAPDF6_AVAILABLE) then call lhapdf_initialize (data%set, & data%prefix, data%file, data%member, & data%pdf, data%hoppet_b_matching) data%xmin = data%pdf%getxmin () data%xmax = data%pdf%getxmax () data%qmin = sqrt(data%pdf%getq2min ()) data%qmax = sqrt(data%pdf%getq2max ()) data%has_photon = data%pdf%has_photon () end if end subroutine lhapdf_data_init @ %def lhapdf_data_init @ Enable/disable partons explicitly. If a mask entry is true, applying the PDF will generate the corresponding flavor on output. <>= procedure :: set_mask => lhapdf_data_set_mask <>= subroutine lhapdf_data_set_mask (data, mask) class(lhapdf_data_t), intent(inout) :: data logical, dimension(-6:6), intent(in) :: mask data%mask = mask end subroutine lhapdf_data_set_mask @ %def lhapdf_data_set_mask @ Return the public part of the data set. <>= public :: lhapdf_data_get_public_info <>= subroutine lhapdf_data_get_public_info & (data, lhapdf_dir, lhapdf_file, lhapdf_member) type(lhapdf_data_t), intent(in) :: data type(string_t), intent(out) :: lhapdf_dir, lhapdf_file integer, intent(out) :: lhapdf_member lhapdf_dir = data%prefix lhapdf_file = data%file lhapdf_member = data%member end subroutine lhapdf_data_get_public_info @ %def lhapdf_data_get_public_info @ Return the number of the member of the data set. <>= public :: lhapdf_data_get_set <>= function lhapdf_data_get_set(data) result(set) type(lhapdf_data_t), intent(in) :: data integer :: set set = data%set end function lhapdf_data_get_set @ %def lhapdf_data_get_set @ Output <>= procedure :: write => lhapdf_data_write <>= subroutine lhapdf_data_write (data, unit, verbose) class(lhapdf_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical :: verb integer :: u if (present (verbose)) then verb = verbose else verb = .false. end if u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "LHAPDF data:" if (data%set /= 0) then write (u, "(3x,A)", advance="no") "flavor = " call data%flv_in%write (u); write (u, *) if (verb) then write (u, "(3x,A,A)") " prefix = ", char (data%prefix) else write (u, "(3x,A,A)") " prefix = ", & " " end if write (u, "(3x,A,A)") " file = ", char (data%file) write (u, "(3x,A,I3)") " member = ", data%member write (u, "(3x,A," // FMT_19 // ")") " x(min) = ", data%xmin write (u, "(3x,A," // FMT_19 // ")") " x(max) = ", data%xmax write (u, "(3x,A," // FMT_19 // ")") " Q(min) = ", data%qmin write (u, "(3x,A," // FMT_19 // ")") " Q(max) = ", data%qmax write (u, "(3x,A,L1)") " invert = ", data%invert if (data%photon) write (u, "(3x,A,I3)") & " IP2 (scheme) = ", data%photon_scheme write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") & " mask = ", & data%mask(-6:-1), "*", data%mask(0), "*", data%mask(1:6) write (u, "(3x,A,L1)") " photon mask = ", data%mask_photon if (data%set == 1) write (u, "(3x,A,L1)") & " hoppet_b = ", data%hoppet_b_matching else write (u, "(3x,A)") "[undefined]" end if end subroutine lhapdf_data_write @ %def lhapdf_data_write @ The number of parameters is one. We do not generate transverse momentum. <>= procedure :: get_n_par => lhapdf_data_get_n_par <>= function lhapdf_data_get_n_par (data) result (n) class(lhapdf_data_t), intent(in) :: data integer :: n n = 1 end function lhapdf_data_get_n_par @ %def lhapdf_data_get_n_par @ Return the outgoing particle PDG codes. This is based on the mask. <>= procedure :: get_pdg_out => lhapdf_data_get_pdg_out <>= subroutine lhapdf_data_get_pdg_out (data, pdg_out) class(lhapdf_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer, dimension(:), allocatable :: pdg1 integer :: n, np, i n = count (data%mask) np = 0; if (data%has_photon .and. data%mask_photon) np = 1 allocate (pdg1 (n + np)) pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask) if (np == 1) pdg1(n+np) = PHOTON pdg_out(1) = pdg1 end subroutine lhapdf_data_get_pdg_out @ %def lhapdf_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => lhapdf_data_allocate_sf_int <>= subroutine lhapdf_data_allocate_sf_int (data, sf_int) class(lhapdf_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (lhapdf_t :: sf_int) end subroutine lhapdf_data_allocate_sf_int @ %def lhapdf_data_allocate_sf_int @ Return the numerical PDF set index. <>= procedure :: get_pdf_set => lhapdf_data_get_pdf_set <>= elemental function lhapdf_data_get_pdf_set (data) result (pdf_set) class(lhapdf_data_t), intent(in) :: data integer :: pdf_set pdf_set = data%set end function lhapdf_data_get_pdf_set @ %def lhapdf_data_get_pdf_set @ \subsection{The LHAPDF object} The [[lhapdf_t]] data type is a $1\to 2$ interaction which describes the splitting of an (anti)proton into a parton and a beam remnant. We stay in the strict forward-splitting limit, but allow some invariant mass for the beam remnant such that the outgoing parton is exactly massless. For a real event, we would replace this by a parton cascade, where the outgoing partons have virtuality as dictated by parton-shower kinematics, and transverse momentum is generated. This is the LHAPDF object which holds input data together with the interaction. We also store the $x$ momentum fraction and the scale, since kinematics and function value are requested at different times. The PDF application is a $1\to 2$ splitting process, where the particles are ordered as (hadron, remnant, parton). Polarization is ignored completely. The beam particle is colorless, while partons and beam remnant carry color. The remnant gets a special flavor code. <>= public :: lhapdf_t <>= type, extends (sf_int_t) :: lhapdf_t type(lhapdf_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: q = 0 real(default) :: s = 0 contains <> end type lhapdf_t @ %def lhapdf_t @ Type string: display the chosen PDF set. <>= procedure :: type_string => lhapdf_type_string <>= function lhapdf_type_string (object) result (string) class(lhapdf_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "LHAPDF: " // object%data%file else string = "LHAPDF: [undefined]" end if end function lhapdf_type_string @ %def lhapdf_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => lhapdf_write <>= subroutine lhapdf_write (object, unit, testflag) class(lhapdf_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A," // FMT_17 // ")") "Q =", object%q end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "LHAPDF data: [undefined]" end if end subroutine lhapdf_write @ %def lhapdf_write @ Initialize. We know that [[data]] will be of concrete type [[sf_lhapdf_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. <>= procedure :: init => lhapdf_init <>= subroutine lhapdf_init (sf_int, data) class(lhapdf_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask type(flavor_t) :: flv, flv_remnant type(color_t) :: col0 type(quantum_numbers_t), dimension(3) :: qn integer :: i select type (data) type is (lhapdf_data_t) mask = quantum_numbers_mask (.false., .false., .true.) call col0%init () call sf_int%base_init (mask, [0._default], [0._default], [0._default]) sf_int%data => data do i = -6, 6 if (data%mask(i)) then call qn(1)%init (data%flv_in, col = col0) if (i == 0) then call flv%init (GLUON, data%model) call flv_remnant%init (HADRON_REMNANT_OCTET, data%model) else call flv%init (i, data%model) call flv_remnant%init & (sign (HADRON_REMNANT_TRIPLET, -i), data%model) end if call qn(2)%init ( & flv = flv_remnant, col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init ( & flv = flv, col = color_from_flavor (flv, 1, reverse=.true.)) call sf_int%add_state (qn) end if end do if (data%has_photon .and. data%mask_photon) then call flv%init (PHOTON, data%model) call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model) call qn(2)%init (flv = flv_remnant, & col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init (flv = flv, & col = color_from_flavor (flv, 1, reverse=.true.)) call sf_int%add_state (qn) end if call sf_int%freeze () call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) sf_int%status = SF_INITIAL end select end subroutine lhapdf_init @ %def lhapdf_init @ \subsection{Structure function} We have to cast the LHAPDF arguments to/from double precision (possibly from/to extended/quadruple precision), if necessary. Some structure functions can yield negative results (sea quarks close to $x=1$). In an NLO computation, this is perfectly fine and we keep negative values. Unlike total cross sections, PDFs do not have to be positive definite. For LO however, negative PDFs would cause negative event weights so we set these values to zero instead. <>= procedure :: apply => lhapdf_apply <>= subroutine lhapdf_apply (sf_int, scale, negative_sf, rescale, i_sub) class(lhapdf_t), intent(inout) :: sf_int real(default), intent(in) :: scale logical, intent(in), optional :: negative_sf class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: x, s double precision :: xx, qq, ss double precision, dimension(-6:6) :: ff double precision :: fphot complex(default), dimension(:), allocatable :: fc integer :: i, i_sub_opt, j_sub logical :: negative_sf_opt external :: evolvePDFM, evolvePDFpM i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub negative_sf_opt = .false.; if (present(negative_sf)) negative_sf_opt = negative_sf associate (data => sf_int%data) sf_int%q = scale x = sf_int%x if (present (rescale)) call rescale%apply (x) s = sf_int%s xx = x if (debug2_active (D_BEAMS)) then call msg_debug2 (D_BEAMS, "lhapdf_apply") call msg_debug2 (D_BEAMS, "rescale: ", present(rescale)) call msg_debug2 (D_BEAMS, "i_sub: ", i_sub_opt) call msg_debug2 (D_BEAMS, "x: ", x) end if qq = min (data%qmax, scale) qq = max (data%qmin, qq) if (.not. data%photon) then if (data%invert) then if (data%has_photon) then if (LHAPDF5_AVAILABLE) then call evolvePDFphotonM & (data%set, xx, qq, ff(6:-6:-1), fphot) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfphotonm & (xx, qq, ff(6:-6:-1), fphot) end if else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff(6:-6:-1)) else if (LHAPDF5_AVAILABLE) then call evolvePDFM (data%set, xx, qq, ff(6:-6:-1)) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfm (xx, qq, ff(6:-6:-1)) end if end if end if else if (data%has_photon) then if (LHAPDF5_AVAILABLE) then call evolvePDFphotonM (data%set, xx, qq, ff, fphot) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfphotonm (xx, qq, ff, fphot) end if else if (data%hoppet_b_matching) then call hoppet_eval (xx, qq, ff) else if (LHAPDF5_AVAILABLE) then call evolvePDFM (data%set, xx, qq, ff) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfm (xx, qq, ff) end if end if end if end if else ss = s if (LHAPDF5_AVAILABLE) then call evolvePDFpM (data%set, xx, qq, & ss, data%photon_scheme, ff) else if (LHAPDF6_AVAILABLE) then call data%pdf%evolve_pdfpm (xx, qq, ss, & data%photon_scheme, ff) end if end if if (data%has_photon) then allocate (fc (count ([data%mask, data%mask_photon]))) if (negative_sf_opt) then fc = pack ([ff, fphot] / x, [data%mask, data%mask_photon]) else fc = max( pack ([ff, fphot] / x, [data%mask, data%mask_photon]), 0._default) end if else allocate (fc (count (data%mask))) if (negative_sf_opt) then fc = pack (ff / x, data%mask) else fc = max( pack (ff / x, data%mask), 0._default) end if end if end associate if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc) call sf_int%set_matrix_element (fc, [(i_sub_opt * size(fc) + i, i = 1, size(fc))]) sf_int%status = SF_EVALUATED end subroutine lhapdf_apply @ %def apply_lhapdf @ \subsection{Strong Coupling} Since the PDF codes provide a function for computing the running $\alpha_s$ value, we make this available as an implementation of the abstract [[alpha_qcd_t]] type, which is used for matrix element evaluation. <>= public :: alpha_qcd_lhapdf_t <>= type, extends (alpha_qcd_t) :: alpha_qcd_lhapdf_t type(string_t) :: pdfset_dir type(string_t) :: pdfset_file integer :: pdfset_member = -1 type(lhapdf_pdf_t) :: pdf contains <> end type alpha_qcd_lhapdf_t @ %def alpha_qcd_lhapdf_t @ Output. As in earlier versions we leave the LHAPDF path out. <>= procedure :: write => alpha_qcd_lhapdf_write <>= subroutine alpha_qcd_lhapdf_write (object, unit) class(alpha_qcd_lhapdf_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A)") "QCD parameters (lhapdf):" write (u, "(5x,A,A)") "PDF set = ", char (object%pdfset_file) write (u, "(5x,A,I0)") "PDF member = ", object%pdfset_member end subroutine alpha_qcd_lhapdf_write @ %def alpha_qcd_lhapdf_write @ Calculation: the numeric member ID selects the correct PDF set, which must be properly initialized. <>= interface double precision function alphasPDF (Q) double precision, intent(in) :: Q end function alphasPDF end interface @ %def alphasPDF @ <>= procedure :: get => alpha_qcd_lhapdf_get <>= function alpha_qcd_lhapdf_get (alpha_qcd, scale) result (alpha) class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd real(default), intent(in) :: scale real(default) :: alpha if (LHAPDF5_AVAILABLE) then alpha = alphasPDF (dble (scale)) else if (LHAPDF6_AVAILABLE) then alpha = alpha_qcd%pdf%alphas_pdf (dble (scale)) end if end function alpha_qcd_lhapdf_get @ %def alpha_qcd_lhapdf_get @ Initialization. We need to access the (quasi-global) initialization status. <>= procedure :: init => alpha_qcd_lhapdf_init <>= subroutine alpha_qcd_lhapdf_init (alpha_qcd, file, member, path) class(alpha_qcd_lhapdf_t), intent(out) :: alpha_qcd type(string_t), intent(inout) :: file integer, intent(inout) :: member type(string_t), intent(inout) :: path alpha_qcd%pdfset_file = file alpha_qcd%pdfset_member = member if (alpha_qcd%pdfset_member < 0) & call msg_fatal ("QCD parameter initialization: PDF set " & // char (file) // " is unknown") if (LHAPDF5_AVAILABLE) then call lhapdf_initialize (1, path, file, member) else if (LHAPDF6_AVAILABLE) then call lhapdf_initialize & (1, path, file, member, alpha_qcd%pdf) end if end subroutine alpha_qcd_lhapdf_init @ %def alpha_qcd_lhapdf_init @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_lhapdf_ut.f90]]>>= <> module sf_lhapdf_ut use unit_tests use system_dependencies, only: LHAPDF5_AVAILABLE use system_dependencies, only: LHAPDF6_AVAILABLE use sf_lhapdf_uti <> <> contains <> end module sf_lhapdf_ut @ %def sf_lhapdf_ut @ <<[[sf_lhapdf_uti.f90]]>>= <> module sf_lhapdf_uti <> <> use system_dependencies, only: LHAPDF5_AVAILABLE use system_dependencies, only: LHAPDF6_AVAILABLE use os_interface use physics_defs, only: PROTON use sm_qcd use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_base use sf_lhapdf <> <> contains <> end module sf_lhapdf_uti @ %def sf_lhapdf_ut @ API: driver for the unit tests below. <>= public :: sf_lhapdf_test <>= subroutine sf_lhapdf_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_lhapdf_test @ %def sf_lhapdf_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= if (LHAPDF5_AVAILABLE) then call test (sf_lhapdf_1, "sf_lhapdf5_1", & "structure function configuration", & u, results) else if (LHAPDF6_AVAILABLE) then call test (sf_lhapdf_1, "sf_lhapdf6_1", & "structure function configuration", & u, results) end if <>= public :: sf_lhapdf_1 <>= subroutine sf_lhapdf_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_lhapdf_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_sm_test () pdg_in = PROTON allocate (lhapdf_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (lhapdf_data_t) call data%init (model, pdg_in) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_lhapdf_1" end subroutine sf_lhapdf_1 @ %def sf_lhapdf_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the PDF builtin structure function. <>= if (LHAPDF5_AVAILABLE) then call test (sf_lhapdf_2, "sf_lhapdf5_2", & "structure function instance", & u, results) else if (LHAPDF6_AVAILABLE) then call test (sf_lhapdf_2, "sf_lhapdf6_2", & "structure function instance", & u, results) end if <>= public :: sf_lhapdf_2 <>= subroutine sf_lhapdf_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_lhapdf_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (PROTON, model) pdg_in = PROTON call lhapdf_global_reset () call reset_interaction_counter () allocate (lhapdf_data_t :: data) select type (data) type is (lhapdf_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.5_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100 GeV" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale = 100._default) call sf_int%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_lhapdf_2" end subroutine sf_lhapdf_2 @ %def sf_lhapdf_2 @ \subsubsection{Strong Coupling} Test $\alpha_s$ as an implementation of the [[alpha_qcd_t]] abstract type. <>= if (LHAPDF5_AVAILABLE) then call test (sf_lhapdf_3, "sf_lhapdf5_3", & "running alpha_s", & u, results) else if (LHAPDF6_AVAILABLE) then call test (sf_lhapdf_3, "sf_lhapdf6_3", & "running alpha_s", & u, results) end if <>= public :: sf_lhapdf_3 <>= subroutine sf_lhapdf_3 (u) integer, intent(in) :: u type(qcd_t) :: qcd type(string_t) :: name, path integer :: member write (u, "(A)") "* Test output: sf_lhapdf_3" write (u, "(A)") "* Purpose: initialize and evaluate alpha_s" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call lhapdf_global_reset () if (LHAPDF5_AVAILABLE) then name = "cteq6ll.LHpdf" member = 1 path = "" else if (LHAPDF6_AVAILABLE) then name = "CT10" member = 1 path = "" end if write (u, "(A)") "* Initialize qcd object" write (u, "(A)") allocate (alpha_qcd_lhapdf_t :: qcd%alpha) select type (alpha => qcd%alpha) type is (alpha_qcd_lhapdf_t) call alpha%init (name, member, path) end select call qcd%write (u) write (u, "(A)") write (u, "(A)") "* Evaluate for Q = 100" write (u, "(A)") write (u, "(1x,A,F8.5)") "alpha = ", qcd%alpha%get (100._default) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") write (u, "(A)") "* Test output end: sf_lhapdf_3" end subroutine sf_lhapdf_3 @ %def sf_lhapdf_3 @ \section{Easy PDF Access} For the shower, subtraction and matching, it is very useful to have direct access to $f(x,Q)$ independently of the used library. <<[[pdf.f90]]>>= <> module pdf <> use io_units use system_dependencies, only: LHAPDF5_AVAILABLE, LHAPDF6_AVAILABLE use diagnostics use beam_structures use lhapdf !NODEP! use pdf_builtin !NODEP! <> <> <> <> contains <> end module pdf @ %def pdf We support the following implementations: <>= integer, parameter, public :: STRF_NONE = 0 integer, parameter, public :: STRF_LHAPDF6 = 1 integer, parameter, public :: STRF_LHAPDF5 = 2 integer, parameter, public :: STRF_PDF_BUILTIN = 3 @ %def STRF_NONE STRF_LHAPDF6 STRF_LHAPDF5 STRF_PDF_BUILTIN @ A container to bundle all necessary PDF data. Could be moved to a more central location. <>= public :: pdf_data_t <>= type :: pdf_data_t type(lhapdf_pdf_t) :: pdf real(default) :: xmin, xmax, qmin, qmax integer :: type = STRF_NONE integer :: set = 0 contains <> end type pdf_data_t @ %def pdf_data @ <>= procedure :: init => pdf_data_init <>= subroutine pdf_data_init (pdf_data, pdf_data_in) class(pdf_data_t), intent(out) :: pdf_data type(pdf_data_t), target, intent(in) :: pdf_data_in pdf_data%xmin = pdf_data_in%xmin pdf_data%xmax = pdf_data_in%xmax pdf_data%qmin = pdf_data_in%qmin pdf_data%qmax = pdf_data_in%qmax pdf_data%set = pdf_data_in%set pdf_data%type = pdf_data_in%type if (pdf_data%type == STRF_LHAPDF6) then if (pdf_data_in%pdf%is_associated ()) then call lhapdf_copy_pointer (pdf_data_in%pdf, pdf_data%pdf) else call msg_bug ('pdf_data_init: pdf_data%pdf was not associated!') end if end if end subroutine pdf_data_init @ %def pdf_data_init @ <>= procedure :: write => pdf_data_write <>= subroutine pdf_data_write (pdf_data, unit) class(pdf_data_t), intent(in) :: pdf_data integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A,I0)") "PDF set = ", pdf_data%set write (u, "(3x,A,I0)") "PDF type = ", pdf_data%type end subroutine pdf_data_write @ %def pdf_data_write @ <>= procedure :: setup => pdf_data_setup <>= subroutine pdf_data_setup (pdf_data, caller, beam_structure, lhapdf_member, set) class(pdf_data_t), intent(inout) :: pdf_data character(len=*), intent(in) :: caller type(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: lhapdf_member, set real(default) :: xmin, xmax, q2min, q2max pdf_data%set = set if (beam_structure%contains ("lhapdf")) then if (LHAPDF6_AVAILABLE) then pdf_data%type = STRF_LHAPDF6 else if (LHAPDF5_AVAILABLE) then pdf_data%type = STRF_LHAPDF5 end if write (msg_buffer, "(A,I0)") caller & // ": interfacing LHAPDF set #", pdf_data%set call msg_message () else if (beam_structure%contains ("pdf_builtin")) then pdf_data%type = STRF_PDF_BUILTIN write (msg_buffer, "(A,I0)") caller & // ": interfacing PDF builtin set #", pdf_data%set call msg_message () end if select case (pdf_data%type) case (STRF_LHAPDF6) pdf_data%xmin = pdf_data%pdf%getxmin () pdf_data%xmax = pdf_data%pdf%getxmax () pdf_data%qmin = sqrt(pdf_data%pdf%getq2min ()) pdf_data%qmax = sqrt(pdf_data%pdf%getq2max ()) case (STRF_LHAPDF5) call GetXminM (1, lhapdf_member, xmin) call GetXmaxM (1, lhapdf_member, xmax) call GetQ2minM (1, lhapdf_member, q2min) call GetQ2maxM (1, lhapdf_member, q2max) pdf_data%xmin = xmin pdf_data%xmax = xmax pdf_data%qmin = sqrt(q2min) pdf_data%qmax = sqrt(q2max) end select end subroutine pdf_data_setup @ %def pdf_data_setup @ This could be overloaded with a version that only asks for a specific flavor as it is supported by LHAPDF6. <>= procedure :: evolve => pdf_data_evolve <>= subroutine pdf_data_evolve (pdf_data, x, q_in, f) class(pdf_data_t), intent(inout) :: pdf_data real(double), intent(in) :: x, q_in real(double), dimension(-6:6), intent(out) :: f real(double) :: q select case (pdf_data%type) case (STRF_PDF_BUILTIN) call pdf_evolve_LHAPDF (pdf_data%set, x, q_in, f) case (STRF_LHAPDF6) q = min (pdf_data%qmax, q_in) q = max (pdf_data%qmin, q) call pdf_data%pdf%evolve_pdfm (x, q, f) case (STRF_LHAPDF5) q = min (pdf_data%qmax, q_in) q = max (pdf_data%qmin, q) call evolvePDFM (pdf_data%set, x, q, f) case default call msg_fatal ("PDF function: unknown PDF method.") end select end subroutine pdf_data_evolve @ %def pdf_data_evolve @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Dispatch} @ <<[[dispatch_beams.f90]]>>= <> module dispatch_beams <> <> use diagnostics use os_interface, only: os_data_t use variables, only: var_list_t use constants, only: PI, one use numeric_utils, only: vanishes use physics_defs, only: PHOTON use rng_base, only: rng_factory_t use pdg_arrays use model_data, only: model_data_t use dispatch_rng, only: dispatch_rng_factory use dispatch_rng, only: update_rng_seed_in_var_list use flavors, only: flavor_t use sm_qcd, only: qcd_t, alpha_qcd_fixed_t, alpha_qcd_from_scale_t use sm_qcd, only: alpha_qcd_from_lambda_t use sm_qed, only: qed_t, alpha_qed_fixed_t, alpha_qed_from_scale_t use physics_defs, only: MZ_REF, ME_REF, ALPHA_QCD_MZ_REF, ALPHA_QED_ME_REF use beam_structures use sf_base use sf_mappings use sf_isr use sf_epa use sf_ewa use sf_escan use sf_gaussian use sf_beam_events use sf_circe1 use sf_circe2 use sf_pdf_builtin use sf_lhapdf <> <> <> <> contains <> end module dispatch_beams @ %def dispatch_beams @ This data type is a container for transferring structure-function specific data from the [[dispatch_sf_data]] to the [[dispatch_sf_channels]] subroutine. <>= public :: sf_prop_t <>= type :: sf_prop_t real(default), dimension(2) :: isr_eps = 1 end type sf_prop_t @ %def sf_prop_t @ Allocate a structure-function configuration object according to the [[sf_method]] string. The [[sf_prop]] object can be used to transfer structure-function specific data up and to the [[dispatch_sf_channels]] subroutine below, so they can be used for particular mappings. The [[var_list_global]] object is used for the RNG generator seed. It is intent(inout) because the RNG generator seed may change during initialization. The [[pdg_in]] array is the array of incoming flavors, corresponding to the upstream structure function or the beam array. This will be checked for the structure function in question and replaced by the outgoing flavors. The [[pdg_prc]] array is the array of incoming flavors (beam index, component index) for the hard process. <>= public :: dispatch_sf_data <>= subroutine dispatch_sf_data (data, sf_method, i_beam, sf_prop, & var_list, var_list_global, model, & os_data, sqrts, pdg_in, pdg_prc, polarized) class(sf_data_t), allocatable, intent(inout) :: data type(string_t), intent(in) :: sf_method integer, dimension(:), intent(in) :: i_beam type(pdg_array_t), dimension(:), intent(inout) :: pdg_in type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc type(sf_prop_t), intent(inout) :: sf_prop type(var_list_t), intent(in) :: var_list type(var_list_t), intent(inout) :: var_list_global integer :: next_rng_seed class(model_data_t), target, intent(in) :: model type(os_data_t), intent(in) :: os_data real(default), intent(in) :: sqrts logical, intent(in) :: polarized type(pdg_array_t), dimension(:), allocatable :: pdg_out real(default) :: isr_alpha, isr_q_max, isr_mass integer :: isr_order logical :: isr_recoil, isr_keep_energy real(default) :: epa_alpha, epa_x_min, epa_q_min, epa_q_max, epa_mass logical :: epa_recoil, epa_keep_energy integer :: epa_int_mode type(string_t) :: epa_mode real(default) :: ewa_x_min, ewa_pt_max, ewa_mass logical :: ewa_recoil, ewa_keep_energy type(pdg_array_t), dimension(:), allocatable :: pdg_prc1 integer :: ewa_id type(string_t) :: pdf_name type(string_t) :: lhapdf_dir, lhapdf_file type(string_t), dimension(13) :: lhapdf_photon_sets integer :: lhapdf_member, lhapdf_photon_scheme logical :: hoppet_b_matching class(rng_factory_t), allocatable :: rng_factory logical :: circe1_photon1, circe1_photon2, circe1_generate, & circe1_with_radiation real(default) :: circe1_sqrts, circe1_eps integer :: circe1_version, circe1_chattiness, & circe1_revision character(6) :: circe1_accelerator logical :: circe2_polarized type(string_t) :: circe2_design, circe2_file real(default), dimension(2) :: gaussian_spread logical :: beam_events_warn_eof type(string_t) :: beam_events_dir, beam_events_file logical :: escan_normalize integer :: i lhapdf_photon_sets = [var_str ("DOG0.LHgrid"), var_str ("DOG1.LHgrid"), & var_str ("DGG.LHgrid"), var_str ("LACG.LHgrid"), & var_str ("GSG0.LHgrid"), var_str ("GSG1.LHgrid"), & var_str ("GSG960.LHgrid"), var_str ("GSG961.LHgrid"), & var_str ("GRVG0.LHgrid"), var_str ("GRVG1.LHgrid"), & var_str ("ACFGPG.LHgrid"), var_str ("WHITG.LHgrid"), & var_str ("SASG.LHgrid")] select case (char (sf_method)) case ("pdf_builtin") allocate (pdf_builtin_data_t :: data) select type (data) type is (pdf_builtin_data_t) pdf_name = & var_list%get_sval (var_str ("$pdf_builtin_set")) hoppet_b_matching = & var_list%get_lval (var_str ("?hoppet_b_matching")) call data%init ( & model, pdg_in(i_beam(1)), & name = pdf_name, & path = os_data%pdf_builtin_datapath, & hoppet_b_matching = hoppet_b_matching) end select case ("pdf_builtin_photon") call msg_fatal ("Currently, there are no photon PDFs built into WHIZARD,", & [var_str ("for the photon content inside a proton or neutron use"), & var_str ("the 'lhapdf_photon' structure function.")]) case ("lhapdf") allocate (lhapdf_data_t :: data) if (pdg_in(i_beam(1))%get (1) == PHOTON) then call msg_fatal ("The 'lhapdf' structure is intended only for protons and", & [var_str ("pions, please use 'lhapdf_photon' for photon beams.")]) end if lhapdf_dir = & var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = & var_list%get_sval (var_str ("$lhapdf_file")) lhapdf_member = & var_list%get_ival (var_str ("lhapdf_member")) lhapdf_photon_scheme = & var_list%get_ival (var_str ("lhapdf_photon_scheme")) hoppet_b_matching = & var_list%get_lval (var_str ("?hoppet_b_matching")) select type (data) type is (lhapdf_data_t) call data%init & (model, pdg_in(i_beam(1)), & lhapdf_dir, lhapdf_file, lhapdf_member, & lhapdf_photon_scheme, hoppet_b_matching) end select case ("lhapdf_photon") allocate (lhapdf_data_t :: data) if (pdg_in(i_beam(1))%get_length () /= 1 .or. & pdg_in(i_beam(1))%get (1) /= PHOTON) then call msg_fatal ("The 'lhapdf_photon' structure function is exclusively for", & [var_str ("photon PDFs, i.e. for photons as beam particles")]) end if lhapdf_dir = & var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = & var_list%get_sval (var_str ("$lhapdf_photon_file")) lhapdf_member = & var_list%get_ival (var_str ("lhapdf_member")) lhapdf_photon_scheme = & var_list%get_ival (var_str ("lhapdf_photon_scheme")) if (.not. any (lhapdf_photon_sets == lhapdf_file)) then call msg_fatal ("This PDF set is not supported or not " // & "intended for photon beams.") end if select type (data) type is (lhapdf_data_t) call data%init & (model, pdg_in(i_beam(1)), & lhapdf_dir, lhapdf_file, lhapdf_member, & lhapdf_photon_scheme) end select case ("isr") allocate (isr_data_t :: data) isr_alpha = & var_list%get_rval (var_str ("isr_alpha")) if (vanishes (isr_alpha)) then isr_alpha = (var_list%get_rval (var_str ("ee"))) & ** 2 / (4 * PI) end if isr_q_max = & var_list%get_rval (var_str ("isr_q_max")) if (vanishes (isr_q_max)) then isr_q_max = sqrts end if isr_mass = var_list%get_rval (var_str ("isr_mass")) isr_order = var_list%get_ival (var_str ("isr_order")) isr_recoil = var_list%get_lval (var_str ("?isr_recoil")) isr_keep_energy = var_list%get_lval (var_str ("?isr_keep_energy")) select type (data) type is (isr_data_t) call data%init & (model, pdg_in (i_beam(1)), isr_alpha, isr_q_max, & isr_mass, isr_order, recoil = isr_recoil, keep_energy = & isr_keep_energy) call data%check () sf_prop%isr_eps(i_beam(1)) = data%get_eps () end select case ("epa") allocate (epa_data_t :: data) epa_mode = var_list%get_sval (var_str ("$epa_mode")) epa_int_mode = 0 epa_alpha = var_list%get_rval (var_str ("epa_alpha")) if (vanishes (epa_alpha)) then epa_alpha = (var_list%get_rval (var_str ("ee"))) & ** 2 / (4 * PI) end if epa_x_min = var_list%get_rval (var_str ("epa_x_min")) epa_q_min = var_list%get_rval (var_str ("epa_q_min")) epa_q_max = var_list%get_rval (var_str ("epa_q_max")) if (vanishes (epa_q_max)) then epa_q_max = sqrts end if select case (char (epa_mode)) case ("default", "Budnev_617") epa_int_mode = 0 case ("Budnev_616e") epa_int_mode = 1 case ("log_power") epa_int_mode = 2 epa_q_max = sqrts case ("log_simple") epa_int_mode = 3 epa_q_max = sqrts case ("log") epa_int_mode = 4 epa_q_max = sqrts case default call msg_fatal ("EPA: unsupported EPA mode; please choose " // & "'default', 'Budnev_616', 'Budnev_616e', 'log_power', " // & "'log_simple', or 'log'") end select epa_mass = var_list%get_rval (var_str ("epa_mass")) epa_recoil = var_list%get_lval (var_str ("?epa_recoil")) epa_keep_energy = var_list%get_lval (var_str ("?epa_keep_energy")) select type (data) type is (epa_data_t) call data%init & (model, epa_int_mode, pdg_in (i_beam(1)), epa_alpha, & epa_x_min, epa_q_min, epa_q_max, epa_mass, & recoil = epa_recoil, keep_energy = epa_keep_energy) call data%check () end select case ("ewa") allocate (ewa_data_t :: data) allocate (pdg_prc1 (size (pdg_prc, 2))) pdg_prc1 = pdg_prc(i_beam(1),:) if (any (pdg_prc1%get_length () /= 1) & .or. any (pdg_prc1 /= pdg_prc1(1))) then call msg_fatal & ("EWA: process incoming particle (W/Z) must be unique") end if ewa_id = abs (pdg_prc1(1)%get (1)) ewa_x_min = var_list%get_rval (var_str ("ewa_x_min")) ewa_pt_max = var_list%get_rval (var_str ("ewa_pt_max")) if (vanishes (ewa_pt_max)) then ewa_pt_max = sqrts end if ewa_mass = var_list%get_rval (var_str ("ewa_mass")) ewa_recoil = var_list%get_lval (& var_str ("?ewa_recoil")) ewa_keep_energy = var_list%get_lval (& var_str ("?ewa_keep_energy")) select type (data) type is (ewa_data_t) call data%init & (model, pdg_in (i_beam(1)), ewa_x_min, & ewa_pt_max, sqrts, ewa_recoil, & ewa_keep_energy, ewa_mass) call data%set_id (ewa_id) call data%check () end select case ("circe1") allocate (circe1_data_t :: data) select type (data) type is (circe1_data_t) circe1_photon1 = & var_list%get_lval (var_str ("?circe1_photon1")) circe1_photon2 = & var_list%get_lval (var_str ("?circe1_photon2")) circe1_sqrts = & var_list%get_rval (var_str ("circe1_sqrts")) circe1_eps = & var_list%get_rval (var_str ("circe1_eps")) if (circe1_sqrts <= 0) circe1_sqrts = sqrts circe1_generate = & var_list%get_lval (var_str ("?circe1_generate")) circe1_version = & var_list%get_ival (var_str ("circe1_ver")) circe1_revision = & var_list%get_ival (var_str ("circe1_rev")) circe1_accelerator = & char (var_list%get_sval (var_str ("$circe1_acc"))) circe1_chattiness = & var_list%get_ival (var_str ("circe1_chat")) circe1_with_radiation = & var_list%get_lval (var_str ("?circe1_with_radiation")) call data%init (model, pdg_in, circe1_sqrts, circe1_eps, & [circe1_photon1, circe1_photon2], & circe1_version, circe1_revision, circe1_accelerator, & circe1_chattiness, circe1_with_radiation) if (circe1_generate) then call msg_message ("CIRCE1: activating generator mode") call dispatch_rng_factory & (rng_factory, var_list_global, next_rng_seed) call update_rng_seed_in_var_list (var_list_global, next_rng_seed) call data%set_generator_mode (rng_factory) end if end select case ("circe2") allocate (circe2_data_t :: data) select type (data) type is (circe2_data_t) circe2_polarized = & var_list%get_lval (var_str ("?circe2_polarized")) circe2_file = & var_list%get_sval (var_str ("$circe2_file")) circe2_design = & var_list%get_sval (var_str ("$circe2_design")) call data%init (os_data, model, pdg_in, sqrts, & circe2_polarized, polarized, circe2_file, circe2_design) call msg_message ("CIRCE2: activating generator mode") call dispatch_rng_factory & (rng_factory, var_list_global, next_rng_seed) call update_rng_seed_in_var_list (var_list_global, next_rng_seed) call data%set_generator_mode (rng_factory) end select case ("gaussian") allocate (gaussian_data_t :: data) select type (data) type is (gaussian_data_t) gaussian_spread = & [var_list%get_rval (var_str ("gaussian_spread1")), & var_list%get_rval (var_str ("gaussian_spread2"))] call dispatch_rng_factory & (rng_factory, var_list_global, next_rng_seed) call update_rng_seed_in_var_list (var_list_global, next_rng_seed) call data%init (model, pdg_in, gaussian_spread, rng_factory) end select case ("beam_events") allocate (beam_events_data_t :: data) select type (data) type is (beam_events_data_t) beam_events_dir = os_data%whizard_beamsimpath beam_events_file = var_list%get_sval (& var_str ("$beam_events_file")) beam_events_warn_eof = var_list%get_lval (& var_str ("?beam_events_warn_eof")) call data%init (model, pdg_in, & beam_events_dir, beam_events_file, beam_events_warn_eof) end select case ("energy_scan") escan_normalize = & var_list%get_lval (var_str ("?energy_scan_normalize")) allocate (escan_data_t :: data) select type (data) type is (escan_data_t) if (escan_normalize) then call data%init (model, pdg_in) else call data%init (model, pdg_in, sqrts) end if end select case default if (associated (dispatch_sf_data_extra)) then call dispatch_sf_data_extra (data, sf_method, i_beam, & sf_prop, var_list, var_list_global, model, os_data, sqrts, pdg_in, & pdg_prc, polarized) end if if (.not. allocated (data)) then call msg_fatal ("Structure function '" & // char (sf_method) // "' not implemented") end if end select if (allocated (data)) then allocate (pdg_out (size (pdg_prc, 1))) call data%get_pdg_out (pdg_out) do i = 1, size (i_beam) pdg_in(i_beam(i)) = pdg_out(i) end do end if end subroutine dispatch_sf_data @ %def dispatch_sf_data @ This is a hook that allows us to inject further handlers for structure-function objects, in particular a test structure function. <>= public :: dispatch_sf_data_extra <>= procedure (dispatch_sf_data), pointer :: & dispatch_sf_data_extra => null () @ %def dispatch_sf_data_extra @ This is an auxiliary procedure, used by the beam-structure expansion: tell for a given structure function name, whether it corresponds to a pair spectrum ($n=2$), a single-particle structure function ($n=1$), or nothing ($n=0$). Though [[energy_scan]] can in principle also be a pair spectrum, it always has only one parameter. <>= public :: strfun_mode <>= function strfun_mode (name) result (n) type(string_t), intent(in) :: name integer :: n select case (char (name)) case ("none") n = 0 case ("sf_test_0", "sf_test_1") n = 1 case ("pdf_builtin","pdf_builtin_photon", & "lhapdf","lhapdf_photon") n = 1 case ("isr","epa","ewa") n = 1 case ("circe1", "circe2") n = 2 case ("gaussian") n = 2 case ("beam_events") n = 2 case ("energy_scan") n = 2 case default n = -1 call msg_bug ("Structure function '" // char (name) & // "' not supported yet") end select end function strfun_mode @ %def strfun_mode @ Dispatch a whole structure-function chain, given beam data and beam structure data. This could be done generically, but we should look at the specific combination of structure functions in order to select appropriate mappings. The [[beam_structure]] argument gets copied because we want to expand it to canonical form (one valid structure-function entry per record) before proceeding further. The [[pdg_prc]] argument is the array of incoming flavors. The first index is the beam index, the second one the process component index. Each element is itself a PDG array, notrivial if there is a flavor sum for the incoming state of this component. The dispatcher is divided in two parts. The first part configures the structure function data themselves. After this, we can configure the phase space for the elementary process. <>= public :: dispatch_sf_config <>= subroutine dispatch_sf_config (sf_config, sf_prop, beam_structure, & var_list, var_list_global, model, os_data, sqrts, pdg_prc) type(sf_config_t), dimension(:), allocatable, intent(out) :: sf_config type(sf_prop_t), intent(out) :: sf_prop type(beam_structure_t), intent(inout) :: beam_structure type(var_list_t), intent(in) :: var_list type(var_list_t), intent(inout) :: var_list_global class(model_data_t), target, intent(in) :: model type(os_data_t), intent(in) :: os_data real(default), intent(in) :: sqrts class(sf_data_t), allocatable :: sf_data type(beam_structure_t) :: beam_structure_tmp type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc type(string_t), dimension(:), allocatable :: prt_in type(pdg_array_t), dimension(:), allocatable :: pdg_in type(flavor_t) :: flv_in integer :: n_beam, n_record, i beam_structure_tmp = beam_structure call beam_structure_tmp%expand (strfun_mode) n_record = beam_structure_tmp%get_n_record () allocate (sf_config (n_record)) n_beam = beam_structure_tmp%get_n_beam () if (n_beam > 0) then allocate (prt_in (n_beam), pdg_in (n_beam)) prt_in = beam_structure_tmp%get_prt () do i = 1, n_beam call flv_in%init (prt_in(i), model) pdg_in(i) = flv_in%get_pdg () end do else n_beam = size (pdg_prc, 1) allocate (pdg_in (n_beam)) pdg_in = pdg_prc(:,1) end if do i = 1, n_record call dispatch_sf_data (sf_data, & beam_structure_tmp%get_name (i), & beam_structure_tmp%get_i_entry (i), & sf_prop, var_list, var_list_global, model, os_data, sqrts, & pdg_in, pdg_prc, & beam_structure_tmp%polarized ()) call sf_config(i)%init (beam_structure_tmp%get_i_entry (i), sf_data) deallocate (sf_data) end do end subroutine dispatch_sf_config @ %def dispatch_sf_config @ \subsection{QCD and QED coupling} Allocate the [[alpha]] (running coupling) component of the [[qcd]] block with a concrete implementation, depending on the variable settings in the [[global]] record. If a fixed $\alpha_s$ is requested, we do not allocate the [[qcd%alpha]] object. In this case, the matrix element code will just take the model parameter as-is, which implies fixed $\alpha_s$. If the object is allocated, the $\alpha_s$ value is computed and updated for each matrix-element call. Also fetch the [[alphas_nf]] variable from the list and store it in the QCD record. This is not used in the $\alpha_s$ calculation, but the QCD record thus becomes a messenger for this user parameter. <>= public :: dispatch_qcd <>= subroutine dispatch_qcd (qcd, var_list, os_data) type(qcd_t), intent(inout) :: qcd type(var_list_t), intent(in) :: var_list type(os_data_t), intent(in) :: os_data logical :: fixed, from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd real(default) :: mz, alpha_val, lambda integer :: nf, order, lhapdf_member type(string_t) :: pdfset, lhapdf_dir, lhapdf_file call unpack_variables () if (allocated (qcd%alpha)) deallocate (qcd%alpha) if (from_lhapdf .and. from_pdf_builtin) then call msg_fatal (" Mixing alphas evolution", & [var_str (" from LHAPDF and builtin PDF is not permitted")]) end if select case (count ([from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd])) case (0) if (fixed) then allocate (alpha_qcd_fixed_t :: qcd%alpha) else call msg_fatal ("QCD alpha: no calculation mode set") end if case (2:) call msg_fatal ("QCD alpha: calculation mode is ambiguous") case (1) if (fixed) then call msg_fatal ("QCD alpha: use '?alphas_is_fixed = false' for " // & "running alphas") else if (from_mz) then allocate (alpha_qcd_from_scale_t :: qcd%alpha) else if (from_pdf_builtin) then allocate (alpha_qcd_pdf_builtin_t :: qcd%alpha) else if (from_lhapdf) then allocate (alpha_qcd_lhapdf_t :: qcd%alpha) else if (from_lambda_qcd) then allocate (alpha_qcd_from_lambda_t :: qcd%alpha) end if call msg_message ("QCD alpha: using a running strong coupling") end select call init_alpha () qcd%n_f = var_list%get_ival (var_str ("alphas_nf")) contains <> end subroutine dispatch_qcd @ %def dispatch_qcd @ <>= subroutine unpack_variables () fixed = var_list%get_lval (var_str ("?alphas_is_fixed")) from_mz = var_list%get_lval (var_str ("?alphas_from_mz")) from_pdf_builtin = & var_list%get_lval (var_str ("?alphas_from_pdf_builtin")) from_lhapdf = & var_list%get_lval (var_str ("?alphas_from_lhapdf")) from_lambda_qcd = & var_list%get_lval (var_str ("?alphas_from_lambda_qcd")) pdfset = var_list%get_sval (var_str ("$pdf_builtin_set")) lambda = var_list%get_rval (var_str ("lambda_qcd")) nf = var_list%get_ival (var_str ("alphas_nf")) order = var_list%get_ival (var_str ("alphas_order")) lhapdf_dir = var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = var_list%get_sval (var_str ("$lhapdf_file")) lhapdf_member = var_list%get_ival (var_str ("lhapdf_member")) if (var_list%contains (var_str ("mZ"))) then mz = var_list%get_rval (var_str ("mZ")) else mz = MZ_REF end if if (var_list%contains (var_str ("alphas"))) then alpha_val = var_list%get_rval (var_str ("alphas")) else alpha_val = ALPHA_QCD_MZ_REF end if end subroutine unpack_variables @ <>= subroutine init_alpha () select type (alpha => qcd%alpha) type is (alpha_qcd_fixed_t) alpha%val = alpha_val type is (alpha_qcd_from_scale_t) alpha%mu_ref = mz alpha%ref = alpha_val alpha%order = order alpha%nf = nf type is (alpha_qcd_from_lambda_t) alpha%lambda = lambda alpha%order = order alpha%nf = nf type is (alpha_qcd_pdf_builtin_t) call alpha%init (pdfset, & os_data%pdf_builtin_datapath) type is (alpha_qcd_lhapdf_t) call alpha%init (lhapdf_file, lhapdf_member, lhapdf_dir) end select end subroutine init_alpha @ @ Same for QED. <>= public :: dispatch_qed <>= subroutine dispatch_qed (qed, var_list) type(qed_t), intent(inout) :: qed type(var_list_t), intent(in) :: var_list logical :: fixed, from_me, analytic real(default) :: me, alpha_val integer :: nf, nlep, order call unpack_variables () if (allocated (qed%alpha)) deallocate (qed%alpha) select case (count ([from_me])) case (0) if (fixed) then allocate (alpha_qed_fixed_t :: qed%alpha) else call msg_fatal ("QED alpha: no calculation mode set") end if case (2:) call msg_fatal ("QED alpha: calculation mode is ambiguous") case (1) if (fixed) then call msg_fatal ("QED alpha: use '?alphas_is_fixed = false' for " // & "running alpha") else if (from_me) then allocate (alpha_qed_from_scale_t :: qed%alpha) end if call msg_message ("QED alpha: using a running electromagnetic coupling") end select call init_alpha () if (var_list%get_ival (var_str ("alpha_nf")) == -1) then qed%n_f = var_list%get_ival (var_str ("alphas_nf")) else qed%n_f = var_list%get_ival (var_str ("alpha_nf")) end if qed%n_lep = var_list%get_ival (var_str ("alpha_nlep")) contains <> end subroutine dispatch_qed @ %def dispatch_qed @ <>= subroutine unpack_variables () fixed = var_list%get_lval (var_str ("?alpha_is_fixed")) from_me = var_list%get_lval (var_str ("?alpha_from_me")) if (var_list%get_ival (var_str ("alpha_nf")) == -1) then nf = var_list%get_ival (var_str ("alphas_nf")) else nf = var_list%get_ival (var_str ("alpha_nf")) end if analytic = var_list%get_lval (var_str ("?alpha_evolve_analytic")) nlep = var_list%get_ival (var_str ("alpha_nlep")) order = var_list%get_ival (var_str ("alpha_order")) if (var_list%contains (var_str ("me"))) then me = var_list%get_rval (var_str ("me")) else me = ME_REF end if if (var_list%contains (var_str ("alpha_em_i"))) then alpha_val = one / var_list%get_rval (var_str ("alpha_em_i")) else alpha_val = ALPHA_QED_ME_REF end if end subroutine unpack_variables @ <>= subroutine init_alpha () select type (alpha => qed%alpha) type is (alpha_qed_fixed_t) alpha%val = alpha_val type is (alpha_qed_from_scale_t) alpha%mu_ref = me alpha%ref = alpha_val alpha%order = order alpha%nf = nf alpha%nlep = nlep alpha%analytic = analytic end select end subroutine init_alpha @ Index: trunk/src/qft/Makefile.am =================================================================== --- trunk/src/qft/Makefile.am (revision 8778) +++ trunk/src/qft/Makefile.am (revision 8779) @@ -1,207 +1,231 @@ ## Makefile.am -- Makefile for WHIZARD ## ## Process this file with automake to produce Makefile.in # # Copyright (C) 1999-2022 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## ## The files in this directory implement quantum field theory concepts ## such as model representation and quantum numbers. ## We create a library which is still to be combined with auxiliary libs. noinst_LTLIBRARIES = libqft.la check_LTLIBRARIES = libqft_ut.la libqft_la_SOURCES = \ + $(QFT_MODULES) \ + $(QFT_SUBMODULES) + +QFT_MODULES = \ model_data.f90 \ helicities.f90 \ colors.f90 \ flavors.f90 \ quantum_numbers.f90 \ state_matrices.f90 \ interactions.f90 \ evaluators.f90 +QFT_SUBMODULES = \ + model_data_sub.f90 \ + helicities_sub.f90 \ + colors_sub.f90 \ + flavors_sub.f90 \ + quantum_numbers_sub.f90 \ + state_matrices_sub.f90 \ + interactions_sub.f90 \ + evaluators_sub.f90 + libqft_ut_la_SOURCES = \ model_testbed.f90 \ colors_uti.f90 colors_ut.f90 \ state_matrices_uti.f90 state_matrices_ut.f90 \ interactions_uti.f90 interactions_ut.f90 \ evaluators_uti.f90 evaluators_ut.f90 ## Omitting this would exclude it from the distribution dist_noinst_DATA = qft.nw # Modules and installation # Dump module names into file Modules execmoddir = $(fmoddir)/whizard nodist_execmod_HEADERS = \ - ${libqft_la_SOURCES:.f90=.$(FCMOD)} + ${QFT_MODULES:.f90=.$(FCMOD)} -# Dump module names into file Modules -libqft_Modules = ${libqft_la_SOURCES:.f90=} ${libqft_ut_la_SOURCES:.f90=} +# Submodules must not be included here +libqft_Modules = ${QFT_MODULES:.f90=} ${libqft_ut_la_SOURCES:.f90=} Modules: Makefile @for module in $(libqft_Modules); do \ echo $$module >> $@.new; \ done @if diff $@ $@.new -q >/dev/null; then \ rm $@.new; \ else \ mv $@.new $@; echo "Modules updated"; \ fi BUILT_SOURCES = Modules ## Fortran module dependencies # Get module lists from other directories module_lists = \ ../basics/Modules \ ../utilities/Modules \ ../testing/Modules \ ../system/Modules \ ../combinatorics/Modules \ ../expr_base/Modules \ ../physics/Modules \ ../types/Modules $(module_lists): $(MAKE) -C `dirname $@` Modules Module_dependencies.sed: $(libqft_la_SOURCES) $(libqft_ut_la_SOURCES) Module_dependencies.sed: $(module_lists) @rm -f $@ echo 's/, *only:.*//' >> $@ echo 's/, *&//' >> $@ echo 's/, *.*=>.*//' >> $@ echo 's/$$/.lo/' >> $@ for list in $(module_lists); do \ dir="`dirname $$list`"; \ for mod in `cat $$list`; do \ echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \ done \ done DISTCLEANFILES = Module_dependencies.sed # The following line just says # include Makefile.depend # but in a portable fashion (depending on automake's AM_MAKE_INCLUDE @am__include@ @am__quote@Makefile.depend@am__quote@ Makefile.depend: Module_dependencies.sed Makefile.depend: $(libqft_la_SOURCES) $(libqft_ut_la_SOURCES) @rm -f $@ for src in $^; do \ module="`basename $$src | sed 's/\.f[90][0358]//'`"; \ grep '^ *use ' $$src \ | grep -v '!NODEP!' \ | sed -e 's/^ *use */'$$module'.lo: /' \ -f Module_dependencies.sed; \ done > $@ DISTCLEANFILES += Makefile.depend # Fortran90 module files are generated at the same time as object files .lo.$(FCMOD): @: # touch $@ AM_FCFLAGS = -I../basics -I../utilities -I../testing -I../system -I../combinatorics -I../expr_base -I../physics -I../types +######################################################################## +# For the moment, the submodule dependencies will be hard-coded +model_data_sub.lo: model_data.lo +helicities_sub.lo: helicities.lo +colors_sub.lo: colors.lo +flavors_sub.lo: flavors.lo +quantum_numbers_sub.lo: quantum_numbers.lo +state_matrices_sub.lo: state_matrices.lo +interactions_sub.lo: interactions.lo +evaluators_sub.lo: evaluators.lo ######################################################################## ## Default Fortran compiler options ## Profiling if FC_USE_PROFILING AM_FCFLAGS += $(FCFLAGS_PROFILING) endif ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) endif ## MPI if FC_USE_MPI AM_FCFLAGS += $(FCFLAGS_MPI) endif ######################################################################## ## Non-standard targets and dependencies ## (Re)create F90 sources from NOWEB source. if NOWEB_AVAILABLE PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw qft.stamp: $(PRELUDE) $(srcdir)/qft.nw $(POSTLUDE) @rm -f qft.tmp @touch qft.tmp for src in $(libqft_la_SOURCES) $(libqft_ut_la_SOURCES); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \ done @mv -f qft.tmp qft.stamp $(libqft_la_SOURCES) $(libqft_ut_la_SOURCES): qft.stamp ## Recover from the removal of $@ @if test -f $@; then :; else \ rm -f qft.stamp; \ $(MAKE) $(AM_MAKEFLAGS) qft.stamp; \ fi endif ######################################################################## ## Non-standard cleanup tasks ## Remove sources that can be recreated using NOWEB if NOWEB_AVAILABLE maintainer-clean-noweb: -rm -f *.f90 *.c endif .PHONY: maintainer-clean-noweb ## Remove those sources also if builddir and srcdir are different if NOWEB_AVAILABLE clean-noweb: test "$(srcdir)" != "." && rm -f *.f90 *.c || true endif .PHONY: clean-noweb ## Remove F90 module files clean-local: clean-noweb -rm -f qft.stamp qft.tmp -rm -f *.$(FCMOD) if FC_SUBMODULES - -rm -f *.smod + -rm -f *.smod *.sub endif ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup Index: trunk/src/qft/qft.nw =================================================================== --- trunk/src/qft/qft.nw (revision 8778) +++ trunk/src/qft/qft.nw (revision 8779) @@ -1,15749 +1,18813 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: Quantum Field Theory concepts %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Quantum Field Theory Concepts} \includemodulegraph{qft} The objects and methods defined here implement concepts and data for the underlying quantum field theory that we use for computing matrix elements and processes. \begin{description} \item[model\_data] Fields and coupling parameters, operators as vertex structures, for a specific model. \item[model\_testbed] Provide hooks to deal with a [[model_data]] extension without referencing it explicitly. \item[helicities] Types and methods for spin density matrices. \item[colors] Dealing with colored particles, using the color-flow representation. \item[flavors] PDG codes and particle properties, depends on the model. \item[quantum\_numbers] Quantum numbers and density matrices for entangled particle systems. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Model Data} These data represent a specific Lagrangian in numeric terms. That is, we have the fields with their quantum numbers, the masses, widths and couplings as numerical values, and the vertices as arrays of fields. We do not store the relations between coupling parameters. They should be represented by expressions for evaluation, implemented as Sindarin objects in a distinct data structure. Neither do we need the algebraic structure of vertices. The field content of vertices is required for the sole purpose of setting up phase space. <<[[model_data.f90]]>>= <> module model_data use, intrinsic :: iso_c_binding !NODEP! <> use kinds, only: i8, i32 use kinds, only: c_default_float <> + use physics_defs, only: UNDEFINED, SCALAR + +<> + +<> + +<> + + interface +<> + end interface + +end module model_data +@ %def model_data +@ +<<[[model_data_sub.f90]]>>= +<> + +submodule (model_data) model_data_s + use format_defs, only: FMT_19 use io_units use diagnostics use md5 use hashes, only: hash - use physics_defs, only: UNDEFINED, SCALAR - -<> -<> + implicit none <> -<> - contains <> -end module model_data -@ %def model_data +end submodule model_data_s + +@ %def model_data_s @ \subsection{Physics Parameters} Couplings, masses, and widths are physics parameters. Each parameter has a unique name (used, essentially, for diagnostics output and debugging) and a value. The value may be a real or a complex number, so we provide to implementations of an abstract type. <>= public :: modelpar_data_t <>= type, abstract :: modelpar_data_t private type(string_t) :: name contains <> end type modelpar_data_t type, extends (modelpar_data_t) :: modelpar_real_t private real(default) :: value end type modelpar_real_t type, extends (modelpar_data_t) :: modelpar_complex_t private complex(default) :: value end type modelpar_complex_t @ %def modelpar_data_t modelpar_real_t modelpar_complex_t @ Output for diagnostics. Non-advancing. <>= procedure :: write => par_write +<>= + module subroutine par_write (par, unit) + class(modelpar_data_t), intent(in) :: par + integer, intent(in), optional :: unit + end subroutine <>= - subroutine par_write (par, unit) + module subroutine par_write (par, unit) class(modelpar_data_t), intent(in) :: par integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A,1x,A)", advance="no") char (par%name), "= " select type (par) type is (modelpar_real_t) write (u, "(" // FMT_19 // ")", advance="no") par%value type is (modelpar_complex_t) write (u, "(" // FMT_19 // ",1x,'+',1x," // FMT_19 // ",1x,'I')", & advance="no") par%value end select end subroutine par_write @ %def par_write @ Pretty-printed on separate line, with fixed line length <>= procedure :: show => par_show +<>= + module subroutine par_show (par, l, u) + class(modelpar_data_t), intent(in) :: par + integer, intent(in) :: l, u + end subroutine par_show <>= - subroutine par_show (par, l, u) + module subroutine par_show (par, l, u) class(modelpar_data_t), intent(in) :: par integer, intent(in) :: l, u character(len=l) :: buffer buffer = par%name select type (par) type is (modelpar_real_t) write (u, "(4x,A,1x,'=',1x," // FMT_19 // ")") buffer, par%value type is (modelpar_complex_t) write (u, "(4x,A,1x,'=',1x," // FMT_19 // ",1x,'+',1x," & // FMT_19 // ",1x,'I')") buffer, par%value end select end subroutine par_show @ %def par_show @ Initialize with name and value. The type depends on the argument type. If the type does not match, the value is converted following Fortran rules. <>= generic :: init => modelpar_data_init_real, modelpar_data_init_complex procedure, private :: modelpar_data_init_real procedure, private :: modelpar_data_init_complex +<>= + module subroutine modelpar_data_init_real (par, name, value) + class(modelpar_data_t), intent(out) :: par + type(string_t), intent(in) :: name + real(default), intent(in) :: value + end subroutine modelpar_data_init_real + module subroutine modelpar_data_init_complex (par, name, value) + class(modelpar_data_t), intent(out) :: par + type(string_t), intent(in) :: name + complex(default), intent(in) :: value + end subroutine modelpar_data_init_complex <>= - subroutine modelpar_data_init_real (par, name, value) + module subroutine modelpar_data_init_real (par, name, value) class(modelpar_data_t), intent(out) :: par type(string_t), intent(in) :: name real(default), intent(in) :: value par%name = name par = value end subroutine modelpar_data_init_real - subroutine modelpar_data_init_complex (par, name, value) + module subroutine modelpar_data_init_complex (par, name, value) class(modelpar_data_t), intent(out) :: par type(string_t), intent(in) :: name complex(default), intent(in) :: value par%name = name par = value end subroutine modelpar_data_init_complex @ %def modelpar_data_init_real modelpar_data_init_complex @ Modify the value. We assume that the parameter has been initialized. The type (real or complex) must not be changed, and the name is also fixed. <>= generic :: assignment(=) => modelpar_data_set_real, modelpar_data_set_complex procedure, private :: modelpar_data_set_real procedure, private :: modelpar_data_set_complex +<>= + elemental module subroutine modelpar_data_set_real (par, value) + class(modelpar_data_t), intent(inout) :: par + real(default), intent(in) :: value + end subroutine modelpar_data_set_real + elemental module subroutine modelpar_data_set_complex (par, value) + class(modelpar_data_t), intent(inout) :: par + complex(default), intent(in) :: value + end subroutine modelpar_data_set_complex <>= - elemental subroutine modelpar_data_set_real (par, value) + elemental module subroutine modelpar_data_set_real (par, value) class(modelpar_data_t), intent(inout) :: par real(default), intent(in) :: value select type (par) type is (modelpar_real_t) par%value = value type is (modelpar_complex_t) par%value = value end select end subroutine modelpar_data_set_real - elemental subroutine modelpar_data_set_complex (par, value) + elemental module subroutine modelpar_data_set_complex (par, value) class(modelpar_data_t), intent(inout) :: par complex(default), intent(in) :: value select type (par) type is (modelpar_real_t) par%value = value type is (modelpar_complex_t) par%value = value end select end subroutine modelpar_data_set_complex @ %def modelpar_data_set_real modelpar_data_set_complex @ Return the parameter name. <>= procedure :: get_name => modelpar_data_get_name +<>= + module function modelpar_data_get_name (par) result (name) + class(modelpar_data_t), intent(in) :: par + type(string_t) :: name + end function modelpar_data_get_name <>= - function modelpar_data_get_name (par) result (name) + module function modelpar_data_get_name (par) result (name) class(modelpar_data_t), intent(in) :: par type(string_t) :: name name = par%name end function modelpar_data_get_name @ %def modelpar_data_get_name @ Return the value. In case of a type mismatch, follow Fortran conventions. <>= procedure, pass :: get_real => modelpar_data_get_real procedure, pass :: get_complex => modelpar_data_get_complex +<>= + elemental module function modelpar_data_get_real (par) result (value) + class(modelpar_data_t), intent(in), target :: par + real(default) :: value + end function modelpar_data_get_real + elemental module function modelpar_data_get_complex (par) result (value) + class(modelpar_data_t), intent(in), target :: par + complex(default) :: value + end function modelpar_data_get_complex <>= - elemental function modelpar_data_get_real (par) result (value) + elemental module function modelpar_data_get_real (par) result (value) class(modelpar_data_t), intent(in), target :: par real(default) :: value select type (par) type is (modelpar_real_t) value = par%value type is (modelpar_complex_t) value = par%value end select end function modelpar_data_get_real - elemental function modelpar_data_get_complex (par) result (value) + elemental module function modelpar_data_get_complex (par) result (value) class(modelpar_data_t), intent(in), target :: par complex(default) :: value select type (par) type is (modelpar_real_t) value = par%value type is (modelpar_complex_t) value = par%value end select end function modelpar_data_get_complex @ %def modelpar_data_get_real @ %def modelpar_data_get_complex @ Return a pointer to the value. This makes sense only for matching types. <>= procedure :: get_real_ptr => modelpar_data_get_real_ptr procedure :: get_complex_ptr => modelpar_data_get_complex_ptr +<>= + module function modelpar_data_get_real_ptr (par) result (ptr) + class(modelpar_data_t), intent(in), target :: par + real(default), pointer :: ptr + end function modelpar_data_get_real_ptr + module function modelpar_data_get_complex_ptr (par) result (ptr) + class(modelpar_data_t), intent(in), target :: par + complex(default), pointer :: ptr + end function modelpar_data_get_complex_ptr <>= - function modelpar_data_get_real_ptr (par) result (ptr) + module function modelpar_data_get_real_ptr (par) result (ptr) class(modelpar_data_t), intent(in), target :: par real(default), pointer :: ptr select type (par) type is (modelpar_real_t) ptr => par%value class default ptr => null () end select end function modelpar_data_get_real_ptr - function modelpar_data_get_complex_ptr (par) result (ptr) + module function modelpar_data_get_complex_ptr (par) result (ptr) class(modelpar_data_t), intent(in), target :: par complex(default), pointer :: ptr select type (par) type is (modelpar_complex_t) ptr => par%value class default ptr => null () end select end function modelpar_data_get_complex_ptr @ %def modelpar_data_get_real_ptr @ %def modelpar_data_get_complex_ptr @ \subsection{Field Data} The field-data type holds all information that pertains to a particular field (or particle) within a particular model. Information such as spin type, particle code etc.\ is stored within the object itself, while mass and width are associated to parameters, otherwise assumed zero. <>= public :: field_data_t <>= type :: field_data_t private type(string_t) :: longname integer :: pdg = UNDEFINED logical :: visible = .true. logical :: parton = .false. logical :: gauge = .false. logical :: left_handed = .false. logical :: right_handed = .false. logical :: has_anti = .false. logical :: p_is_stable = .true. logical :: p_decays_isotropically = .false. logical :: p_decays_diagonal = .false. logical :: p_has_decay_helicity = .false. integer :: p_decay_helicity = 0 logical :: a_is_stable = .true. logical :: a_decays_isotropically = .false. logical :: a_decays_diagonal = .false. logical :: a_has_decay_helicity = .false. integer :: a_decay_helicity = 0 logical :: p_polarized = .false. logical :: a_polarized = .false. type(string_t), dimension(:), allocatable :: name, anti type(string_t) :: tex_name, tex_anti integer :: spin_type = UNDEFINED integer :: isospin_type = 1 integer :: charge_type = 1 integer :: color_type = 1 real(default), pointer :: mass_val => null () class(modelpar_data_t), pointer :: mass_data => null () real(default), pointer :: width_val => null () class(modelpar_data_t), pointer :: width_data => null () integer :: multiplicity = 1 type(string_t), dimension(:), allocatable :: p_decay type(string_t), dimension(:), allocatable :: a_decay contains <> end type field_data_t @ %def field_data_t @ Initialize field data with PDG long name and PDG code. \TeX\ names should be initialized to avoid issues with accessing unallocated string contents. <>= procedure :: init => field_data_init +<>= + module subroutine field_data_init (prt, longname, pdg) + class(field_data_t), intent(out) :: prt + type(string_t), intent(in) :: longname + integer, intent(in) :: pdg + end subroutine field_data_init <>= - subroutine field_data_init (prt, longname, pdg) + module subroutine field_data_init (prt, longname, pdg) class(field_data_t), intent(out) :: prt type(string_t), intent(in) :: longname integer, intent(in) :: pdg prt%longname = longname prt%pdg = pdg prt%tex_name = "" prt%tex_anti = "" end subroutine field_data_init @ %def field_data_init @ Copy quantum numbers from another particle. Do not compute the multiplicity yet, because this depends on the association of the [[mass_data]] pointer. <>= procedure :: copy_from => field_data_copy_from +<>= + module subroutine field_data_copy_from (prt, prt_src) + class(field_data_t), intent(inout) :: prt + class(field_data_t), intent(in) :: prt_src + end subroutine field_data_copy_from <>= - subroutine field_data_copy_from (prt, prt_src) + module subroutine field_data_copy_from (prt, prt_src) class(field_data_t), intent(inout) :: prt class(field_data_t), intent(in) :: prt_src prt%visible = prt_src%visible prt%parton = prt_src%parton prt%gauge = prt_src%gauge prt%left_handed = prt_src%left_handed prt%right_handed = prt_src%right_handed prt%p_is_stable = prt_src%p_is_stable prt%p_decays_isotropically = prt_src%p_decays_isotropically prt%p_decays_diagonal = prt_src%p_decays_diagonal prt%p_has_decay_helicity = prt_src%p_has_decay_helicity prt%p_decay_helicity = prt_src%p_decay_helicity prt%p_decays_diagonal = prt_src%p_decays_diagonal prt%a_is_stable = prt_src%a_is_stable prt%a_decays_isotropically = prt_src%a_decays_isotropically prt%a_decays_diagonal = prt_src%a_decays_diagonal prt%a_has_decay_helicity = prt_src%a_has_decay_helicity prt%a_decay_helicity = prt_src%a_decay_helicity prt%p_polarized = prt_src%p_polarized prt%a_polarized = prt_src%a_polarized prt%spin_type = prt_src%spin_type prt%isospin_type = prt_src%isospin_type prt%charge_type = prt_src%charge_type prt%color_type = prt_src%color_type prt%has_anti = prt_src%has_anti if (allocated (prt_src%name)) then if (allocated (prt%name)) deallocate (prt%name) allocate (prt%name (size (prt_src%name)), source = prt_src%name) end if if (allocated (prt_src%anti)) then if (allocated (prt%anti)) deallocate (prt%anti) allocate (prt%anti (size (prt_src%anti)), source = prt_src%anti) end if prt%tex_name = prt_src%tex_name prt%tex_anti = prt_src%tex_anti if (allocated (prt_src%p_decay)) then if (allocated (prt%p_decay)) deallocate (prt%p_decay) allocate (prt%p_decay (size (prt_src%p_decay)), source = prt_src%p_decay) end if if (allocated (prt_src%a_decay)) then if (allocated (prt%a_decay)) deallocate (prt%a_decay) allocate (prt%a_decay (size (prt_src%a_decay)), source = prt_src%a_decay) end if end subroutine field_data_copy_from @ %def field_data_copy_from @ Set particle quantum numbers. <>= procedure :: set => field_data_set +<>= + module subroutine field_data_set (prt, & + is_visible, is_parton, is_gauge, is_left_handed, is_right_handed, & + p_is_stable, p_decays_isotropically, p_decays_diagonal, & + p_decay_helicity, & + a_is_stable, a_decays_isotropically, a_decays_diagonal, & + a_decay_helicity, & + p_polarized, a_polarized, & + name, anti, tex_name, tex_anti, & + spin_type, isospin_type, charge_type, color_type, & + mass_data, width_data, & + p_decay, a_decay) + class(field_data_t), intent(inout) :: prt + logical, intent(in), optional :: is_visible, is_parton, is_gauge + logical, intent(in), optional :: is_left_handed, is_right_handed + logical, intent(in), optional :: p_is_stable + logical, intent(in), optional :: p_decays_isotropically, p_decays_diagonal + integer, intent(in), optional :: p_decay_helicity + logical, intent(in), optional :: a_is_stable + logical, intent(in), optional :: a_decays_isotropically, a_decays_diagonal + integer, intent(in), optional :: a_decay_helicity + logical, intent(in), optional :: p_polarized, a_polarized + type(string_t), dimension(:), intent(in), optional :: name, anti + type(string_t), intent(in), optional :: tex_name, tex_anti + integer, intent(in), optional :: spin_type, isospin_type + integer, intent(in), optional :: charge_type, color_type + class(modelpar_data_t), intent(in), pointer, optional :: mass_data, width_data + type(string_t), dimension(:), intent(in), optional :: p_decay, a_decay + end subroutine field_data_set <>= - subroutine field_data_set (prt, & + module subroutine field_data_set (prt, & is_visible, is_parton, is_gauge, is_left_handed, is_right_handed, & p_is_stable, p_decays_isotropically, p_decays_diagonal, & p_decay_helicity, & a_is_stable, a_decays_isotropically, a_decays_diagonal, & a_decay_helicity, & p_polarized, a_polarized, & name, anti, tex_name, tex_anti, & spin_type, isospin_type, charge_type, color_type, & mass_data, width_data, & p_decay, a_decay) class(field_data_t), intent(inout) :: prt logical, intent(in), optional :: is_visible, is_parton, is_gauge logical, intent(in), optional :: is_left_handed, is_right_handed logical, intent(in), optional :: p_is_stable logical, intent(in), optional :: p_decays_isotropically, p_decays_diagonal integer, intent(in), optional :: p_decay_helicity logical, intent(in), optional :: a_is_stable logical, intent(in), optional :: a_decays_isotropically, a_decays_diagonal integer, intent(in), optional :: a_decay_helicity logical, intent(in), optional :: p_polarized, a_polarized type(string_t), dimension(:), intent(in), optional :: name, anti type(string_t), intent(in), optional :: tex_name, tex_anti integer, intent(in), optional :: spin_type, isospin_type integer, intent(in), optional :: charge_type, color_type class(modelpar_data_t), intent(in), pointer, optional :: mass_data, width_data type(string_t), dimension(:), intent(in), optional :: p_decay, a_decay if (present (is_visible)) prt%visible = is_visible if (present (is_parton)) prt%parton = is_parton if (present (is_gauge)) prt%gauge = is_gauge if (present (is_left_handed)) prt%left_handed = is_left_handed if (present (is_right_handed)) prt%right_handed = is_right_handed if (present (p_is_stable)) prt%p_is_stable = p_is_stable if (present (p_decays_isotropically)) & prt%p_decays_isotropically = p_decays_isotropically if (present (p_decays_diagonal)) & prt%p_decays_diagonal = p_decays_diagonal if (present (p_decay_helicity)) then prt%p_has_decay_helicity = .true. prt%p_decay_helicity = p_decay_helicity end if if (present (a_is_stable)) prt%a_is_stable = a_is_stable if (present (a_decays_isotropically)) & prt%a_decays_isotropically = a_decays_isotropically if (present (a_decays_diagonal)) & prt%a_decays_diagonal = a_decays_diagonal if (present (a_decay_helicity)) then prt%a_has_decay_helicity = .true. prt%a_decay_helicity = a_decay_helicity end if if (present (p_polarized)) prt%p_polarized = p_polarized if (present (a_polarized)) prt%a_polarized = a_polarized if (present (name)) then if (allocated (prt%name)) deallocate (prt%name) allocate (prt%name (size (name)), source = name) end if if (present (anti)) then if (allocated (prt%anti)) deallocate (prt%anti) allocate (prt%anti (size (anti)), source = anti) prt%has_anti = .true. end if if (present (tex_name)) prt%tex_name = tex_name if (present (tex_anti)) prt%tex_anti = tex_anti if (present (spin_type)) prt%spin_type = spin_type if (present (isospin_type)) prt%isospin_type = isospin_type if (present (charge_type)) prt%charge_type = charge_type if (present (color_type)) prt%color_type = color_type if (present (mass_data)) then prt%mass_data => mass_data if (associated (mass_data)) then prt%mass_val => mass_data%get_real_ptr () else prt%mass_val => null () end if end if if (present (width_data)) then prt%width_data => width_data if (associated (width_data)) then prt%width_val => width_data%get_real_ptr () else prt%width_val => null () end if end if if (present (spin_type) .or. present (mass_data)) then call prt%set_multiplicity () end if if (present (p_decay)) then if (allocated (prt%p_decay)) deallocate (prt%p_decay) if (size (p_decay) > 0) & allocate (prt%p_decay (size (p_decay)), source = p_decay) end if if (present (a_decay)) then if (allocated (prt%a_decay)) deallocate (prt%a_decay) if (size (a_decay) > 0) & allocate (prt%a_decay (size (a_decay)), source = a_decay) end if end subroutine field_data_set @ %def field_data_set @ Calculate the multiplicity given spin type and mass. <>= procedure, private :: & set_multiplicity => field_data_set_multiplicity +<>= + module subroutine field_data_set_multiplicity (prt) + class(field_data_t), intent(inout) :: prt + end subroutine field_data_set_multiplicity <>= - subroutine field_data_set_multiplicity (prt) + module subroutine field_data_set_multiplicity (prt) class(field_data_t), intent(inout) :: prt if (prt%spin_type /= SCALAR) then if (associated (prt%mass_data)) then prt%multiplicity = prt%spin_type else if (prt%left_handed .or. prt%right_handed) then prt%multiplicity = 1 else prt%multiplicity = 2 end if end if end subroutine field_data_set_multiplicity @ %def field_data_set_multiplicity @ Set the mass/width value (not the pointer). The mass/width pointer must be allocated. <>= procedure, private :: set_mass => field_data_set_mass procedure, private :: set_width => field_data_set_width +<>= + module subroutine field_data_set_mass (prt, mass) + class(field_data_t), intent(inout) :: prt + real(default), intent(in) :: mass + end subroutine field_data_set_mass + module subroutine field_data_set_width (prt, width) + class(field_data_t), intent(inout) :: prt + real(default), intent(in) :: width + end subroutine field_data_set_width <>= - subroutine field_data_set_mass (prt, mass) + module subroutine field_data_set_mass (prt, mass) class(field_data_t), intent(inout) :: prt real(default), intent(in) :: mass if (associated (prt%mass_val)) prt%mass_val = mass end subroutine field_data_set_mass - subroutine field_data_set_width (prt, width) + module subroutine field_data_set_width (prt, width) class(field_data_t), intent(inout) :: prt real(default), intent(in) :: width if (associated (prt%width_val)) prt%width_val = width end subroutine field_data_set_width @ %def field_data_set_mass field_data_set_width @ Loose ends: name arrays should be allocated. <>= procedure :: freeze => field_data_freeze +<>= + elemental module subroutine field_data_freeze (prt) + class(field_data_t), intent(inout) :: prt + end subroutine field_data_freeze <>= - elemental subroutine field_data_freeze (prt) + elemental module subroutine field_data_freeze (prt) class(field_data_t), intent(inout) :: prt if (.not. allocated (prt%name)) allocate (prt%name (0)) if (.not. allocated (prt%anti)) allocate (prt%anti (0)) end subroutine field_data_freeze @ %def field_data_freeze @ Output <>= procedure :: write => field_data_write +<>= + module subroutine field_data_write (prt, unit) + class(field_data_t), intent(in) :: prt + integer, intent(in), optional :: unit + end subroutine field_data_write <>= - subroutine field_data_write (prt, unit) + module subroutine field_data_write (prt, unit) class(field_data_t), intent(in) :: prt integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(3x,A,1x,A)", advance="no") "particle", char (prt%longname) write (u, "(1x,I0)", advance="no") prt%pdg if (.not. prt%visible) write (u, "(2x,A)", advance="no") "invisible" if (prt%parton) write (u, "(2x,A)", advance="no") "parton" if (prt%gauge) write (u, "(2x,A)", advance="no") "gauge" if (prt%left_handed) write (u, "(2x,A)", advance="no") "left" if (prt%right_handed) write (u, "(2x,A)", advance="no") "right" write (u, *) write (u, "(5x,A)", advance="no") "name" if (allocated (prt%name)) then do i = 1, size (prt%name) write (u, "(1x,A)", advance="no") '"' // char (prt%name(i)) // '"' end do write (u, *) if (prt%has_anti) then write (u, "(5x,A)", advance="no") "anti" do i = 1, size (prt%anti) write (u, "(1x,A)", advance="no") '"' // char (prt%anti(i)) // '"' end do write (u, *) end if if (prt%tex_name /= "") then write (u, "(5x,A)") & "tex_name " // '"' // char (prt%tex_name) // '"' end if if (prt%has_anti .and. prt%tex_anti /= "") then write (u, "(5x,A)") & "tex_anti " // '"' // char (prt%tex_anti) // '"' end if else write (u, "(A)") "???" end if write (u, "(5x,A)", advance="no") "spin " select case (mod (prt%spin_type - 1, 2)) case (0); write (u, "(I0)", advance="no") (prt%spin_type-1) / 2 case default; write (u, "(I0,A)", advance="no") prt%spin_type-1, "/2" end select ! write (u, "(2x,A,I1,A)") "! [multiplicity = ", prt%multiplicity, "]" if (abs (prt%isospin_type) /= 1) then write (u, "(2x,A)", advance="no") "isospin " select case (mod (abs (prt%isospin_type) - 1, 2)) case (0); write (u, "(I0)", advance="no") & sign (abs (prt%isospin_type) - 1, prt%isospin_type) / 2 case default; write (u, "(I0,A)", advance="no") & sign (abs (prt%isospin_type) - 1, prt%isospin_type), "/2" end select end if if (abs (prt%charge_type) /= 1) then write (u, "(2x,A)", advance="no") "charge " select case (mod (abs (prt%charge_type) - 1, 3)) case (0); write (u, "(I0)", advance="no") & sign (abs (prt%charge_type) - 1, prt%charge_type) / 3 case default; write (u, "(I0,A)", advance="no") & sign (abs (prt%charge_type) - 1, prt%charge_type), "/3" end select end if if (prt%color_type /= 1) then write (u, "(2x,A,I0)", advance="no") "color ", prt%color_type end if write (u, *) if (associated (prt%mass_data)) then write (u, "(5x,A)", advance="no") & "mass " // char (prt%mass_data%get_name ()) if (associated (prt%width_data)) then write (u, "(2x,A)") & "width " // char (prt%width_data%get_name ()) else write (u, *) end if end if call prt%write_decays (u) end subroutine field_data_write @ %def field_data_write @ Write decay and polarization data. <>= procedure :: write_decays => field_data_write_decays +<>= + module subroutine field_data_write_decays (prt, unit) + class(field_data_t), intent(in) :: prt + integer, intent(in), optional :: unit + end subroutine field_data_write_decays <>= - subroutine field_data_write_decays (prt, unit) + module subroutine field_data_write_decays (prt, unit) class(field_data_t), intent(in) :: prt integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) if (.not. prt%p_is_stable) then if (allocated (prt%p_decay)) then write (u, "(5x,A)", advance="no") "p_decay" do i = 1, size (prt%p_decay) write (u, "(1x,A)", advance="no") char (prt%p_decay(i)) end do if (prt%p_decays_isotropically) then write (u, "(1x,A)", advance="no") "isotropic" else if (prt%p_decays_diagonal) then write (u, "(1x,A)", advance="no") "diagonal" else if (prt%p_has_decay_helicity) then write (u, "(1x,A,I0)", advance="no") "helicity = ", & prt%p_decay_helicity end if write (u, *) end if else if (prt%p_polarized) then write (u, "(5x,A)") "p_polarized" end if if (.not. prt%a_is_stable) then if (allocated (prt%a_decay)) then write (u, "(5x,A)", advance="no") "a_decay" do i = 1, size (prt%a_decay) write (u, "(1x,A)", advance="no") char (prt%a_decay(i)) end do if (prt%a_decays_isotropically) then write (u, "(1x,A)", advance="no") "isotropic" else if (prt%a_decays_diagonal) then write (u, "(1x,A)", advance="no") "diagonal" else if (prt%a_has_decay_helicity) then write (u, "(1x,A,I0)", advance="no") "helicity = ", & prt%a_decay_helicity end if write (u, *) end if else if (prt%a_polarized) then write (u, "(5x,A)") "a_polarized" end if end subroutine field_data_write_decays @ %def field_data_write_decays @ Screen version of output. <>= procedure :: show => field_data_show +<>= + module subroutine field_data_show (prt, l, u) + class(field_data_t), intent(in) :: prt + integer, intent(in) :: l, u + end subroutine field_data_show <>= - subroutine field_data_show (prt, l, u) + module subroutine field_data_show (prt, l, u) class(field_data_t), intent(in) :: prt integer, intent(in) :: l, u character(len=l) :: buffer integer :: i type(string_t), dimension(:), allocatable :: decay buffer = prt%get_name (.false.) write (u, "(4x,A,1x,I8)", advance="no") buffer, & prt%get_pdg () if (prt%is_polarized ()) then write (u, "(3x,A)") "polarized" else if (.not. prt%is_stable ()) then write (u, "(3x,A)", advance="no") "decays:" call prt%get_decays (decay) do i = 1, size (decay) write (u, "(1x,A)", advance="no") char (decay(i)) end do write (u, *) else write (u, *) end if if (prt%has_antiparticle ()) then buffer = prt%get_name (.true.) write (u, "(4x,A,1x,I8)", advance="no") buffer, & prt%get_pdg_anti () if (prt%is_polarized (.true.)) then write (u, "(3x,A)") "polarized" else if (.not. prt%is_stable (.true.)) then write (u, "(3x,A)", advance="no") "decays:" call prt%get_decays (decay, .true.) do i = 1, size (decay) write (u, "(1x,A)", advance="no") char (decay(i)) end do write (u, *) else write (u, *) end if end if end subroutine field_data_show @ %def field_data_show @ Retrieve data: <>= procedure :: get_pdg => field_data_get_pdg procedure :: get_pdg_anti => field_data_get_pdg_anti +<>= + elemental module function field_data_get_pdg (prt) result (pdg) + integer :: pdg + class(field_data_t), intent(in) :: prt + end function field_data_get_pdg + elemental module function field_data_get_pdg_anti (prt) result (pdg) + integer :: pdg + class(field_data_t), intent(in) :: prt + end function field_data_get_pdg_anti <>= - elemental function field_data_get_pdg (prt) result (pdg) + elemental module function field_data_get_pdg (prt) result (pdg) integer :: pdg class(field_data_t), intent(in) :: prt pdg = prt%pdg end function field_data_get_pdg - elemental function field_data_get_pdg_anti (prt) result (pdg) + elemental module function field_data_get_pdg_anti (prt) result (pdg) integer :: pdg class(field_data_t), intent(in) :: prt if (prt%has_anti) then pdg = - prt%pdg else pdg = prt%pdg end if end function field_data_get_pdg_anti @ %def field_data_get_pdg field_data_get_pdg_anti @ Predicates: <>= procedure :: is_visible => field_data_is_visible procedure :: is_parton => field_data_is_parton procedure :: is_gauge => field_data_is_gauge procedure :: is_left_handed => field_data_is_left_handed procedure :: is_right_handed => field_data_is_right_handed procedure :: has_antiparticle => field_data_has_antiparticle procedure :: is_stable => field_data_is_stable procedure :: get_decays => field_data_get_decays procedure :: decays_isotropically => field_data_decays_isotropically procedure :: decays_diagonal => field_data_decays_diagonal procedure :: has_decay_helicity => field_data_has_decay_helicity procedure :: decay_helicity => field_data_decay_helicity procedure :: is_polarized => field_data_is_polarized +<>= + elemental module function field_data_is_visible (prt) result (flag) + logical :: flag + class(field_data_t), intent(in) :: prt + end function field_data_is_visible + elemental module function field_data_is_parton (prt) result (flag) + logical :: flag + class(field_data_t), intent(in) :: prt + end function field_data_is_parton + elemental module function field_data_is_gauge (prt) result (flag) + logical :: flag + class(field_data_t), intent(in) :: prt + end function field_data_is_gauge + elemental module function field_data_is_left_handed (prt) result (flag) + logical :: flag + class(field_data_t), intent(in) :: prt + end function field_data_is_left_handed + elemental module function field_data_is_right_handed (prt) result (flag) + logical :: flag + class(field_data_t), intent(in) :: prt + end function field_data_is_right_handed + elemental module function field_data_has_antiparticle (prt) result (flag) + logical :: flag + class(field_data_t), intent(in) :: prt + end function field_data_has_antiparticle + elemental module function field_data_is_stable (prt, anti) result (flag) + logical :: flag + class(field_data_t), intent(in) :: prt + logical, intent(in), optional :: anti + end function field_data_is_stable + module subroutine field_data_get_decays (prt, decay, anti) + class(field_data_t), intent(in) :: prt + type(string_t), dimension(:), intent(out), allocatable :: decay + logical, intent(in), optional :: anti + end subroutine field_data_get_decays + elemental module function field_data_decays_isotropically & + (prt, anti) result (flag) + logical :: flag + class(field_data_t), intent(in) :: prt + logical, intent(in), optional :: anti + end function field_data_decays_isotropically + elemental module function field_data_decays_diagonal & + (prt, anti) result (flag) + logical :: flag + class(field_data_t), intent(in) :: prt + logical, intent(in), optional :: anti + end function field_data_decays_diagonal + elemental module function field_data_has_decay_helicity & + (prt, anti) result (flag) + logical :: flag + class(field_data_t), intent(in) :: prt + logical, intent(in), optional :: anti + end function field_data_has_decay_helicity + elemental module function field_data_decay_helicity & + (prt, anti) result (hel) + integer :: hel + class(field_data_t), intent(in) :: prt + logical, intent(in), optional :: anti + end function field_data_decay_helicity + elemental module function field_data_is_polarized (prt, anti) result (flag) + logical :: flag + class(field_data_t), intent(in) :: prt + logical, intent(in), optional :: anti + end function field_data_is_polarized <>= - elemental function field_data_is_visible (prt) result (flag) + elemental module function field_data_is_visible (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%visible end function field_data_is_visible - elemental function field_data_is_parton (prt) result (flag) + elemental module function field_data_is_parton (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%parton end function field_data_is_parton - elemental function field_data_is_gauge (prt) result (flag) + elemental module function field_data_is_gauge (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%gauge end function field_data_is_gauge - elemental function field_data_is_left_handed (prt) result (flag) + elemental module function field_data_is_left_handed (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%left_handed end function field_data_is_left_handed - elemental function field_data_is_right_handed (prt) result (flag) + elemental module function field_data_is_right_handed (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%right_handed end function field_data_is_right_handed - elemental function field_data_has_antiparticle (prt) result (flag) + elemental module function field_data_has_antiparticle (prt) result (flag) logical :: flag class(field_data_t), intent(in) :: prt flag = prt%has_anti end function field_data_has_antiparticle - elemental function field_data_is_stable (prt, anti) result (flag) + elemental module function field_data_is_stable (prt, anti) result (flag) logical :: flag class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti if (present (anti)) then if (anti) then flag = prt%a_is_stable else flag = prt%p_is_stable end if else flag = prt%p_is_stable end if end function field_data_is_stable - subroutine field_data_get_decays (prt, decay, anti) + module subroutine field_data_get_decays (prt, decay, anti) class(field_data_t), intent(in) :: prt type(string_t), dimension(:), intent(out), allocatable :: decay logical, intent(in), optional :: anti if (present (anti)) then if (anti) then allocate (decay (size (prt%a_decay)), source = prt%a_decay) else allocate (decay (size (prt%p_decay)), source = prt%p_decay) end if else allocate (decay (size (prt%p_decay)), source = prt%p_decay) end if end subroutine field_data_get_decays - elemental function field_data_decays_isotropically & + elemental module function field_data_decays_isotropically & (prt, anti) result (flag) logical :: flag class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti if (present (anti)) then if (anti) then flag = prt%a_decays_isotropically else flag = prt%p_decays_isotropically end if else flag = prt%p_decays_isotropically end if end function field_data_decays_isotropically - elemental function field_data_decays_diagonal & + elemental module function field_data_decays_diagonal & (prt, anti) result (flag) logical :: flag class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti if (present (anti)) then if (anti) then flag = prt%a_decays_diagonal else flag = prt%p_decays_diagonal end if else flag = prt%p_decays_diagonal end if end function field_data_decays_diagonal - elemental function field_data_has_decay_helicity & + elemental module function field_data_has_decay_helicity & (prt, anti) result (flag) logical :: flag class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti if (present (anti)) then if (anti) then flag = prt%a_has_decay_helicity else flag = prt%p_has_decay_helicity end if else flag = prt%p_has_decay_helicity end if end function field_data_has_decay_helicity - elemental function field_data_decay_helicity & + elemental module function field_data_decay_helicity & (prt, anti) result (hel) integer :: hel class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti if (present (anti)) then if (anti) then hel = prt%a_decay_helicity else hel = prt%p_decay_helicity end if else hel = prt%p_decay_helicity end if end function field_data_decay_helicity - elemental function field_data_is_polarized (prt, anti) result (flag) + elemental module function field_data_is_polarized (prt, anti) result (flag) logical :: flag class(field_data_t), intent(in) :: prt logical, intent(in), optional :: anti logical :: a if (present (anti)) then a = anti else a = .false. end if if (a) then flag = prt%a_polarized else flag = prt%p_polarized end if end function field_data_is_polarized @ %def field_data_is_visible field_data_is_parton @ %def field_data_is_gauge @ %def field_data_is_left_handed field_data_is_right_handed @ %def field_data_has_antiparticle @ %def field_data_is_stable @ %def field_data_decays_isotropically @ %def field_data_decays_diagonal @ %def field_data_has_decay_helicity @ %def field_data_decay_helicity @ %def field_data_polarized @ Names. Return the first name in the list (or the first antiparticle name) <>= procedure :: get_longname => field_data_get_longname procedure :: get_name => field_data_get_name procedure :: get_name_array => field_data_get_name_array +<>= + pure module function field_data_get_longname (prt) result (name) + type(string_t) :: name + class(field_data_t), intent(in) :: prt + end function field_data_get_longname + pure module function field_data_get_name & + (prt, is_antiparticle) result (name) + type(string_t) :: name + class(field_data_t), intent(in) :: prt + logical, intent(in) :: is_antiparticle + end function field_data_get_name + module subroutine field_data_get_name_array (prt, is_antiparticle, name) + class(field_data_t), intent(in) :: prt + logical, intent(in) :: is_antiparticle + type(string_t), dimension(:), allocatable, intent(inout) :: name + end subroutine field_data_get_name_array <>= - pure function field_data_get_longname (prt) result (name) + pure module function field_data_get_longname (prt) result (name) type(string_t) :: name class(field_data_t), intent(in) :: prt name = prt%longname end function field_data_get_longname - pure function field_data_get_name (prt, is_antiparticle) result (name) + pure module function field_data_get_name (prt, is_antiparticle) result (name) type(string_t) :: name class(field_data_t), intent(in) :: prt logical, intent(in) :: is_antiparticle name = prt%longname if (is_antiparticle) then if (prt%has_anti) then if (allocated (prt%anti)) then if (size(prt%anti) > 0) name = prt%anti(1) end if else if (allocated (prt%name)) then if (size (prt%name) > 0) name = prt%name(1) end if end if else if (allocated (prt%name)) then if (size (prt%name) > 0) name = prt%name(1) end if end if end function field_data_get_name - subroutine field_data_get_name_array (prt, is_antiparticle, name) + module subroutine field_data_get_name_array (prt, is_antiparticle, name) class(field_data_t), intent(in) :: prt logical, intent(in) :: is_antiparticle type(string_t), dimension(:), allocatable, intent(inout) :: name if (allocated (name)) deallocate (name) if (is_antiparticle) then if (prt%has_anti) then allocate (name (size (prt%anti))) name = prt%anti else allocate (name (0)) end if else allocate (name (size (prt%name))) name = prt%name end if end subroutine field_data_get_name_array @ %def field_data_get_name @ Same for the \TeX\ name. <>= procedure :: get_tex_name => field_data_get_tex_name +<>= + elemental module function field_data_get_tex_name & + (prt, is_antiparticle) result (name) + type(string_t) :: name + class(field_data_t), intent(in) :: prt + logical, intent(in) :: is_antiparticle + end function field_data_get_tex_name <>= - elemental function field_data_get_tex_name & + elemental module function field_data_get_tex_name & (prt, is_antiparticle) result (name) type(string_t) :: name class(field_data_t), intent(in) :: prt logical, intent(in) :: is_antiparticle if (is_antiparticle) then if (prt%has_anti) then name = prt%tex_anti else name = prt%tex_name end if else name = prt%tex_name end if if (name == "") name = prt%get_name (is_antiparticle) end function field_data_get_tex_name @ %def field_data_get_tex_name @ Check if any of the field names matches the given string. <>= procedure, private :: matches_name => field_data_matches_name +<>= + module function field_data_matches_name & + (field, name, is_antiparticle) result (flag) + class(field_data_t), intent(in) :: field + type(string_t), intent(in) :: name + logical, intent(in) :: is_antiparticle + logical :: flag + end function field_data_matches_name <>= - function field_data_matches_name (field, name, is_antiparticle) result (flag) + module function field_data_matches_name & + (field, name, is_antiparticle) result (flag) class(field_data_t), intent(in) :: field type(string_t), intent(in) :: name logical, intent(in) :: is_antiparticle logical :: flag if (is_antiparticle) then if (field%has_anti) then flag = any (name == field%anti) else flag = .false. end if else flag = name == field%longname .or. any (name == field%name) end if end function field_data_matches_name @ %def field_data_matches_name @ Quantum numbers <>= procedure :: get_spin_type => field_data_get_spin_type procedure :: get_multiplicity => field_data_get_multiplicity procedure :: get_isospin_type => field_data_get_isospin_type procedure :: get_charge_type => field_data_get_charge_type procedure :: get_color_type => field_data_get_color_type +<>= + elemental module function field_data_get_spin_type (prt) result (type) + integer :: type + class(field_data_t), intent(in) :: prt + end function field_data_get_spin_type + elemental module function field_data_get_multiplicity (prt) result (type) + integer :: type + class(field_data_t), intent(in) :: prt + end function field_data_get_multiplicity + elemental module function field_data_get_isospin_type (prt) result (type) + integer :: type + class(field_data_t), intent(in) :: prt + end function field_data_get_isospin_type + elemental module function field_data_get_charge_type (prt) result (type) + integer :: type + class(field_data_t), intent(in) :: prt + end function field_data_get_charge_type + elemental module function field_data_get_color_type (prt) result (type) + integer :: type + class(field_data_t), intent(in) :: prt + end function field_data_get_color_type <>= - elemental function field_data_get_spin_type (prt) result (type) + elemental module function field_data_get_spin_type (prt) result (type) integer :: type class(field_data_t), intent(in) :: prt type = prt%spin_type end function field_data_get_spin_type - elemental function field_data_get_multiplicity (prt) result (type) + elemental module function field_data_get_multiplicity (prt) result (type) integer :: type class(field_data_t), intent(in) :: prt type = prt%multiplicity end function field_data_get_multiplicity - elemental function field_data_get_isospin_type (prt) result (type) + elemental module function field_data_get_isospin_type (prt) result (type) integer :: type class(field_data_t), intent(in) :: prt type = prt%isospin_type end function field_data_get_isospin_type - elemental function field_data_get_charge_type (prt) result (type) + elemental module function field_data_get_charge_type (prt) result (type) integer :: type class(field_data_t), intent(in) :: prt type = prt%charge_type end function field_data_get_charge_type - elemental function field_data_get_color_type (prt) result (type) + elemental module function field_data_get_color_type (prt) result (type) integer :: type class(field_data_t), intent(in) :: prt type = prt%color_type end function field_data_get_color_type @ %def field_data_get_spin_type @ %def field_data_get_multiplicity @ %def field_data_get_isospin_type @ %def field_data_get_charge_type @ %def field_data_get_color_type @ In the MSSM, neutralinos can have a negative mass. This is relevant for computing matrix elements. However, within the \whizard\ main program we are interested only in kinematics, therefore we return the absolute value of the particle mass. If desired, we can extract the sign separately. <>= procedure :: get_charge => field_data_get_charge procedure :: get_isospin => field_data_get_isospin procedure :: get_mass => field_data_get_mass procedure :: get_mass_sign => field_data_get_mass_sign procedure :: get_width => field_data_get_width +<>= + elemental module function field_data_get_charge (prt) result (charge) + real(default) :: charge + class(field_data_t), intent(in) :: prt + end function field_data_get_charge + elemental module function field_data_get_isospin (prt) result (isospin) + real(default) :: isospin + class(field_data_t), intent(in) :: prt + end function field_data_get_isospin + elemental module function field_data_get_mass (prt) result (mass) + real(default) :: mass + class(field_data_t), intent(in) :: prt + end function field_data_get_mass + elemental module function field_data_get_mass_sign (prt) result (sgn) + integer :: sgn + class(field_data_t), intent(in) :: prt + end function field_data_get_mass_sign + elemental module function field_data_get_width (prt) result (width) + real(default) :: width + class(field_data_t), intent(in) :: prt + end function field_data_get_width <>= - elemental function field_data_get_charge (prt) result (charge) + elemental module function field_data_get_charge (prt) result (charge) real(default) :: charge class(field_data_t), intent(in) :: prt if (prt%charge_type /= 0) then charge = real (sign ((abs(prt%charge_type) - 1), & prt%charge_type), default) / 3 else charge = 0 end if end function field_data_get_charge - elemental function field_data_get_isospin (prt) result (isospin) + elemental module function field_data_get_isospin (prt) result (isospin) real(default) :: isospin class(field_data_t), intent(in) :: prt if (prt%isospin_type /= 0) then isospin = real (sign (abs(prt%isospin_type) - 1, & prt%isospin_type), default) / 2 else isospin = 0 end if end function field_data_get_isospin - elemental function field_data_get_mass (prt) result (mass) + elemental module function field_data_get_mass (prt) result (mass) real(default) :: mass class(field_data_t), intent(in) :: prt if (associated (prt%mass_val)) then mass = abs (prt%mass_val) else mass = 0 end if end function field_data_get_mass - elemental function field_data_get_mass_sign (prt) result (sgn) + elemental module function field_data_get_mass_sign (prt) result (sgn) integer :: sgn class(field_data_t), intent(in) :: prt if (associated (prt%mass_val)) then sgn = sign (1._default, prt%mass_val) else sgn = 0 end if end function field_data_get_mass_sign - elemental function field_data_get_width (prt) result (width) + elemental module function field_data_get_width (prt) result (width) real(default) :: width class(field_data_t), intent(in) :: prt if (associated (prt%width_val)) then width = prt%width_val else width = 0 end if end function field_data_get_width @ %def field_data_get_charge field_data_get_isospin @ %def field_data_get_mass field_data_get_mass_sign @ %def field_data_get_width @ Find the [[model]] containing the [[PDG]] given two model files. <>= public :: find_model +<>= + module subroutine find_model (model, PDG, model_A, model_B) + class(model_data_t), pointer, intent(out) :: model + integer, intent(in) :: PDG + class(model_data_t), intent(in), target :: model_A, model_B + end subroutine find_model <>= - subroutine find_model (model, PDG, model_A, model_B) + module subroutine find_model (model, PDG, model_A, model_B) class(model_data_t), pointer, intent(out) :: model integer, intent(in) :: PDG class(model_data_t), intent(in), target :: model_A, model_B character(len=10) :: buffer if (model_A%test_field (PDG)) then model => model_A else if (model_B%test_field (PDG)) then model => model_B else call model_A%write () call model_B%write () write (buffer, "(I10)") PDG call msg_fatal ("Parton " // buffer // & " not found in the given model files") end if end subroutine find_model @ %def find_model @ \subsection{Vertex data} The vertex object contains an array of particle-data pointers, for which we need a separate type. (We could use the flavor type defined in another module.) The program does not (yet?) make use of vertex definitions, so they are not stored here. <>= type :: field_data_p type(field_data_t), pointer :: p => null () end type field_data_p @ %def field_data_p <>= type :: vertex_t private logical :: trilinear integer, dimension(:), allocatable :: pdg type(field_data_p), dimension(:), allocatable :: prt contains <> end type vertex_t @ %def vertex_t <>= procedure :: write => vertex_write +<>= + module subroutine vertex_write (vtx, unit) + class(vertex_t), intent(in) :: vtx + integer, intent(in), optional :: unit + end subroutine vertex_write <>= - subroutine vertex_write (vtx, unit) + module subroutine vertex_write (vtx, unit) class(vertex_t), intent(in) :: vtx integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(3x,A)", advance="no") "vertex" do i = 1, size (vtx%prt) if (associated (vtx%prt(i)%p)) then write (u, "(1x,A)", advance="no") & '"' // char (vtx%prt(i)%p%get_name (vtx%pdg(i) < 0)) & // '"' else write (u, "(1x,I7)", advance="no") vtx%pdg(i) end if end do write (u, *) end subroutine vertex_write @ %def vertex_write @ Initialize using PDG codes. The model is used for finding particle data pointers associated with the pdg codes. <>= procedure :: init => vertex_init +<>= + module subroutine vertex_init (vtx, pdg, model) + class(vertex_t), intent(out) :: vtx + integer, dimension(:), intent(in) :: pdg + type(model_data_t), intent(in), target, optional :: model + end subroutine vertex_init <>= - subroutine vertex_init (vtx, pdg, model) + module subroutine vertex_init (vtx, pdg, model) class(vertex_t), intent(out) :: vtx integer, dimension(:), intent(in) :: pdg type(model_data_t), intent(in), target, optional :: model integer :: i allocate (vtx%pdg (size (pdg))) allocate (vtx%prt (size (pdg))) vtx%trilinear = size (pdg) == 3 vtx%pdg = pdg if (present (model)) then do i = 1, size (pdg) vtx%prt(i)%p => model%get_field_ptr (pdg(i)) end do end if end subroutine vertex_init @ %def vertex_init @ Copy vertex: we must reassign the field-data pointer to a new model. <>= procedure :: copy_from => vertex_copy_from +<>= + module subroutine vertex_copy_from (vtx, old_vtx, new_model) + class(vertex_t), intent(out) :: vtx + class(vertex_t), intent(in) :: old_vtx + type(model_data_t), intent(in), target, optional :: new_model + end subroutine vertex_copy_from <>= - subroutine vertex_copy_from (vtx, old_vtx, new_model) + module subroutine vertex_copy_from (vtx, old_vtx, new_model) class(vertex_t), intent(out) :: vtx class(vertex_t), intent(in) :: old_vtx type(model_data_t), intent(in), target, optional :: new_model call vtx%init (old_vtx%pdg, new_model) end subroutine vertex_copy_from @ %def vertex_copy_from @ Single-particle lookup: Given a particle code, we return matching codes if present, otherwise zero. Actually, we return the antiparticles of the matching codes, as appropriate for computing splittings. <>= procedure :: get_match => vertex_get_match +<>= + module subroutine vertex_get_match (vtx, pdg1, pdg2) + class(vertex_t), intent(in) :: vtx + integer, intent(in) :: pdg1 + integer, dimension(:), allocatable, intent(out) :: pdg2 + end subroutine vertex_get_match <>= - subroutine vertex_get_match (vtx, pdg1, pdg2) + module subroutine vertex_get_match (vtx, pdg1, pdg2) class(vertex_t), intent(in) :: vtx integer, intent(in) :: pdg1 integer, dimension(:), allocatable, intent(out) :: pdg2 integer :: i, j do i = 1, size (vtx%pdg) if (vtx%pdg(i) == pdg1) then allocate (pdg2 (size (vtx%pdg) - 1)) do j = 1, i-1 pdg2(j) = anti (j) end do do j = i, size (pdg2) pdg2(j) = anti (j+1) end do exit end if end do contains function anti (i) result (pdg) integer, intent(in) :: i integer :: pdg if (vtx%prt(i)%p%has_antiparticle ()) then pdg = - vtx%pdg(i) else pdg = vtx%pdg(i) end if end function anti end subroutine vertex_get_match @ %def vertex_get_match @ To access this from the outside, we create an iterator. The iterator has the sole purpose of returning the matching particles for a given array of PDG codes. <>= public :: vertex_iterator_t <>= type :: vertex_iterator_t private class(model_data_t), pointer :: model => null () integer, dimension(:), allocatable :: pdg integer :: vertex_index = 0 integer :: pdg_index = 0 logical :: save_pdg_index contains procedure :: init => vertex_iterator_init procedure :: get_next_match => vertex_iterator_get_next_match end type vertex_iterator_t @ %def vertex_iterator_t @ We initialize the iterator for a particular model with the [[pdg]] index of the particle we are looking at. +<>= + module subroutine vertex_iterator_init (it, model, pdg, save_pdg_index) + class(vertex_iterator_t), intent(out) :: it + class(model_data_t), intent(in), target :: model + integer, dimension(:), intent(in) :: pdg + logical, intent(in) :: save_pdg_index + end subroutine vertex_iterator_init + module subroutine vertex_iterator_get_next_match (it, pdg_match) + class(vertex_iterator_t), intent(inout) :: it + integer, dimension(:), allocatable, intent(out) :: pdg_match + end subroutine vertex_iterator_get_next_match <>= - subroutine vertex_iterator_init (it, model, pdg, save_pdg_index) + module subroutine vertex_iterator_init (it, model, pdg, save_pdg_index) class(vertex_iterator_t), intent(out) :: it class(model_data_t), intent(in), target :: model integer, dimension(:), intent(in) :: pdg logical, intent(in) :: save_pdg_index it%model => model allocate (it%pdg (size (pdg)), source = pdg) it%save_pdg_index = save_pdg_index end subroutine vertex_iterator_init - subroutine vertex_iterator_get_next_match (it, pdg_match) + module subroutine vertex_iterator_get_next_match (it, pdg_match) class(vertex_iterator_t), intent(inout) :: it integer, dimension(:), allocatable, intent(out) :: pdg_match integer :: i, j do i = it%vertex_index + 1, size (it%model%vtx) do j = it%pdg_index + 1, size (it%pdg) call it%model%vtx(i)%get_match (it%pdg(j), pdg_match) if (it%save_pdg_index) then if (allocated (pdg_match) .and. j < size (it%pdg)) then it%pdg_index = j return else if (allocated (pdg_match) .and. j == size (it%pdg)) then it%vertex_index = i it%pdg_index = 0 return end if else if (allocated (pdg_match)) then it%vertex_index = i return end if end do end do it%vertex_index = 0 it%pdg_index = 0 end subroutine vertex_iterator_get_next_match @ %def vertex_iterator_get_next_match @ \subsection{Vertex lookup table} The vertex lookup table is a hash table: given two particle codes, we check which codes are allowed for the third one. The size of the hash table should be large enough that collisions are rare. We first select a size based on the number of vertices (multiplied by six because all permutations count), with some margin, and then choose the smallest integer power of two larger than this. <>= integer, parameter :: VERTEX_TABLE_SCALE_FACTOR = 60 @ %def VERTEX_TABLE_SCALE_FACTOR <>= function vertex_table_size (n_vtx) result (n) integer(i32) :: n integer, intent(in) :: n_vtx integer :: i, s s = VERTEX_TABLE_SCALE_FACTOR * n_vtx n = 1 do i = 1, 31 n = ishft (n, 1) s = ishft (s,-1) if (s == 0) exit end do end function vertex_table_size @ %def vertex_table_size @ The specific hash function takes two particle codes (arbitrary integers) and returns a 32-bit integer. It makes use of the universal function [[hash]] which operates on a byte array. <>= function hash2 (pdg1, pdg2) integer(i32) :: hash2 integer, intent(in) :: pdg1, pdg2 integer(i8), dimension(1) :: mold hash2 = hash (transfer ([pdg1, pdg2], mold)) end function hash2 @ %def hash2 @ Each entry in the vertex table stores the two particle codes and an array of possibilities for the third code. <>= type :: vertex_table_entry_t private integer :: pdg1 = 0, pdg2 = 0 integer :: n = 0 integer, dimension(:), allocatable :: pdg3 end type vertex_table_entry_t @ %def vertex_table_entry_t @ The vertex table: <>= type :: vertex_table_t type(vertex_table_entry_t), dimension(:), allocatable :: entry integer :: n_collisions = 0 integer(i32) :: mask contains <> end type vertex_table_t @ %def vertex_table_t @ Output. <>= procedure :: write => vertex_table_write +<>= + module subroutine vertex_table_write (vt, unit) + class(vertex_table_t), intent(in) :: vt + integer, intent(in), optional :: unit + end subroutine vertex_table_write <>= - subroutine vertex_table_write (vt, unit) + module subroutine vertex_table_write (vt, unit) class(vertex_table_t), intent(in) :: vt integer, intent(in), optional :: unit integer :: u, i character(9) :: size_pdg3 u = given_output_unit (unit) write (u, "(A)") "vertex hash table:" write (u, "(A,I7)") " size = ", size (vt%entry) write (u, "(A,I7)") " used = ", count (vt%entry%n /= 0) write (u, "(A,I7)") " coll = ", vt%n_collisions do i = lbound (vt%entry, 1), ubound (vt%entry, 1) if (vt%entry(i)%n /= 0) then write (size_pdg3, "(I7)") size (vt%entry(i)%pdg3) write (u, "(A,1x,I7,1x,A,2(1x,I7),A," // & size_pdg3 // "(1x,I7))") & " ", i, ":", vt%entry(i)%pdg1, & vt%entry(i)%pdg2, "->", vt%entry(i)%pdg3 end if end do end subroutine vertex_table_write @ %def vertex_table_write @ Initializing the vertex table: This is done in two passes. First, we scan all permutations for all vertices and count the number of entries in each bucket of the hashtable. Then, the buckets are allocated accordingly and filled. Collision resolution is done by just incrementing the hash value until an empty bucket is found. The vertex table size is fixed, since we know from the beginning the number of entries. <>= procedure :: init => vertex_table_init +<>= + module subroutine vertex_table_init (vt, prt, vtx) + class(vertex_table_t), intent(out) :: vt + type(field_data_t), dimension(:), intent(in) :: prt + type(vertex_t), dimension(:), intent(in) :: vtx + end subroutine vertex_table_init <>= - subroutine vertex_table_init (vt, prt, vtx) + module subroutine vertex_table_init (vt, prt, vtx) class(vertex_table_t), intent(out) :: vt type(field_data_t), dimension(:), intent(in) :: prt type(vertex_t), dimension(:), intent(in) :: vtx integer :: n_vtx, vt_size, i, p1, p2, p3 integer, dimension(3) :: p n_vtx = size (vtx) vt_size = vertex_table_size (count (vtx%trilinear)) vt%mask = vt_size - 1 allocate (vt%entry (0:vt_size-1)) do i = 1, n_vtx if (vtx(i)%trilinear) then p = vtx(i)%pdg p1 = p(1); p2 = p(2) call create (hash2 (p1, p2)) if (p(2) /= p(3)) then p2 = p(3) call create (hash2 (p1, p2)) end if if (p(1) /= p(2)) then p1 = p(2); p2 = p(1) call create (hash2 (p1, p2)) if (p(1) /= p(3)) then p2 = p(3) call create (hash2 (p1, p2)) end if end if if (p(1) /= p(3)) then p1 = p(3); p2 = p(1) call create (hash2 (p1, p2)) if (p(1) /= p(2)) then p2 = p(2) call create (hash2 (p1, p2)) end if end if end if end do do i = 0, vt_size - 1 allocate (vt%entry(i)%pdg3 (vt%entry(i)%n)) end do vt%entry%n = 0 do i = 1, n_vtx if (vtx(i)%trilinear) then p = vtx(i)%pdg p1 = p(1); p2 = p(2); p3 = p(3) call register (hash2 (p1, p2)) if (p(2) /= p(3)) then p2 = p(3); p3 = p(2) call register (hash2 (p1, p2)) end if if (p(1) /= p(2)) then p1 = p(2); p2 = p(1); p3 = p(3) call register (hash2 (p1, p2)) if (p(1) /= p(3)) then p2 = p(3); p3 = p(1) call register (hash2 (p1, p2)) end if end if if (p(1) /= p(3)) then p1 = p(3); p2 = p(1); p3 = p(2) call register (hash2 (p1, p2)) if (p(1) /= p(2)) then p2 = p(2); p3 = p(1) call register (hash2 (p1, p2)) end if end if end if end do contains recursive subroutine create (hashval) integer(i32), intent(in) :: hashval integer :: h h = iand (hashval, vt%mask) if (vt%entry(h)%n == 0) then vt%entry(h)%pdg1 = p1 vt%entry(h)%pdg2 = p2 vt%entry(h)%n = 1 else if (vt%entry(h)%pdg1 == p1 .and. vt%entry(h)%pdg2 == p2) then vt%entry(h)%n = vt%entry(h)%n + 1 else vt%n_collisions = vt%n_collisions + 1 call create (hashval + 1) end if end subroutine create recursive subroutine register (hashval) integer(i32), intent(in) :: hashval integer :: h h = iand (hashval, vt%mask) if (vt%entry(h)%pdg1 == p1 .and. vt%entry(h)%pdg2 == p2) then vt%entry(h)%n = vt%entry(h)%n + 1 vt%entry(h)%pdg3(vt%entry(h)%n) = p3 else call register (hashval + 1) end if end subroutine register end subroutine vertex_table_init @ %def vertex_table_init @ Return the array of particle codes that match the given pair. <>= procedure :: match => vertex_table_match +<>= + module subroutine vertex_table_match (vt, pdg1, pdg2, pdg3) + class(vertex_table_t), intent(in) :: vt + integer, intent(in) :: pdg1, pdg2 + integer, dimension(:), allocatable, intent(out) :: pdg3 + end subroutine vertex_table_match <>= - subroutine vertex_table_match (vt, pdg1, pdg2, pdg3) + module subroutine vertex_table_match (vt, pdg1, pdg2, pdg3) class(vertex_table_t), intent(in) :: vt integer, intent(in) :: pdg1, pdg2 integer, dimension(:), allocatable, intent(out) :: pdg3 call match (hash2 (pdg1, pdg2)) contains recursive subroutine match (hashval) integer(i32), intent(in) :: hashval integer :: h h = iand (hashval, vt%mask) if (vt%entry(h)%n == 0) then allocate (pdg3 (0)) else if (vt%entry(h)%pdg1 == pdg1 .and. vt%entry(h)%pdg2 == pdg2) then allocate (pdg3 (size (vt%entry(h)%pdg3))) pdg3 = vt%entry(h)%pdg3 else call match (hashval + 1) end if end subroutine match end subroutine vertex_table_match @ %def vertex_table_match @ Return true if the triplet is represented as a vertex. <>= procedure :: check => vertex_table_check +<>= + module function vertex_table_check (vt, pdg1, pdg2, pdg3) result (flag) + class(vertex_table_t), intent(in) :: vt + integer, intent(in) :: pdg1, pdg2, pdg3 + logical :: flag + end function vertex_table_check <>= - function vertex_table_check (vt, pdg1, pdg2, pdg3) result (flag) + module function vertex_table_check (vt, pdg1, pdg2, pdg3) result (flag) class(vertex_table_t), intent(in) :: vt integer, intent(in) :: pdg1, pdg2, pdg3 logical :: flag flag = check (hash2 (pdg1, pdg2)) contains recursive function check (hashval) result (flag) integer(i32), intent(in) :: hashval integer :: h logical :: flag h = iand (hashval, vt%mask) if (vt%entry(h)%n == 0) then flag = .false. else if (vt%entry(h)%pdg1 == pdg1 .and. vt%entry(h)%pdg2 == pdg2) then flag = any (vt%entry(h)%pdg3 == pdg3) else flag = check (hashval + 1) end if end function check end function vertex_table_check @ %def vertex_table_check @ \subsection{Model Data Record} This type collects the model data as defined above. We deliberately implement the parameter arrays as pointer arrays. We thus avoid keeping track of TARGET attributes. The [[scheme]] identifier provides meta information. It doesn't give the client code an extra parameter, but it tells something about the interpretation of the parameters. If the scheme ID is left as default (zero), it is ignored. <>= public :: model_data_t <>= type :: model_data_t private type(string_t) :: name integer :: scheme = 0 type(modelpar_real_t), dimension(:), pointer :: par_real => null () type(modelpar_complex_t), dimension(:), pointer :: par_complex => null () type(field_data_t), dimension(:), allocatable :: field type(vertex_t), dimension(:), allocatable :: vtx type(vertex_table_t) :: vt contains <> end type model_data_t @ %def model_data_t @ Finalizer, deallocate pointer arrays. <>= procedure :: final => model_data_final +<>= + module subroutine model_data_final (model) + class(model_data_t), intent(inout) :: model + end subroutine model_data_final <>= - subroutine model_data_final (model) + module subroutine model_data_final (model) class(model_data_t), intent(inout) :: model if (associated (model%par_real)) then deallocate (model%par_real) end if if (associated (model%par_complex)) then deallocate (model%par_complex) end if end subroutine model_data_final @ %def model_data_final @ Output. The signature matches the signature of the high-level [[model_write]] procedure, so some of the options don't actually apply. <>= procedure :: write => model_data_write +<>= + module subroutine model_data_write (model, unit, verbose, & + show_md5sum, show_variables, show_parameters, & + show_particles, show_vertices, show_scheme) + class(model_data_t), intent(in) :: model + integer, intent(in), optional :: unit + logical, intent(in), optional :: verbose + logical, intent(in), optional :: show_md5sum + logical, intent(in), optional :: show_variables + logical, intent(in), optional :: show_parameters + logical, intent(in), optional :: show_particles + logical, intent(in), optional :: show_vertices + logical, intent(in), optional :: show_scheme + end subroutine model_data_write <>= - subroutine model_data_write (model, unit, verbose, & + module subroutine model_data_write (model, unit, verbose, & show_md5sum, show_variables, show_parameters, & show_particles, show_vertices, show_scheme) class(model_data_t), intent(in) :: model integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical, intent(in), optional :: show_md5sum logical, intent(in), optional :: show_variables logical, intent(in), optional :: show_parameters logical, intent(in), optional :: show_particles logical, intent(in), optional :: show_vertices logical, intent(in), optional :: show_scheme logical :: show_sch, show_par, show_prt, show_vtx integer :: u, i u = given_output_unit (unit) show_sch = .false.; if (present (show_scheme)) & show_sch = show_scheme show_par = .true.; if (present (show_parameters)) & show_par = show_parameters show_prt = .true.; if (present (show_particles)) & show_prt = show_particles show_vtx = .true.; if (present (show_vertices)) & show_vtx = show_vertices if (show_sch) then write (u, "(3x,A,1X,I0)") "scheme =", model%scheme end if if (show_par) then do i = 1, size (model%par_real) call model%par_real(i)%write (u) write (u, "(A)") end do do i = 1, size (model%par_complex) call model%par_complex(i)%write (u) write (u, "(A)") end do end if if (show_prt) then write (u, "(A)") call model%write_fields (u) end if if (show_vtx) then write (u, "(A)") call model%write_vertices (u, verbose) end if end subroutine model_data_write @ %def model_data_write @ Initialize, allocating pointer arrays. The second version makes a deep copy. <>= generic :: init => model_data_init procedure, private :: model_data_init +<>= + module subroutine model_data_init (model, name, & + n_par_real, n_par_complex, n_field, n_vtx) + class(model_data_t), intent(out) :: model + type(string_t), intent(in) :: name + integer, intent(in) :: n_par_real, n_par_complex + integer, intent(in) :: n_field + integer, intent(in) :: n_vtx + end subroutine model_data_init <>= - subroutine model_data_init (model, name, & + module subroutine model_data_init (model, name, & n_par_real, n_par_complex, n_field, n_vtx) class(model_data_t), intent(out) :: model type(string_t), intent(in) :: name integer, intent(in) :: n_par_real, n_par_complex integer, intent(in) :: n_field integer, intent(in) :: n_vtx model%name = name allocate (model%par_real (n_par_real)) allocate (model%par_complex (n_par_complex)) allocate (model%field (n_field)) allocate (model%vtx (n_vtx)) end subroutine model_data_init @ %def model_data_init @ Set the scheme ID. <>= procedure :: set_scheme_num => model_data_set_scheme_num +<>= + module subroutine model_data_set_scheme_num (model, scheme) + class(model_data_t), intent(inout) :: model + integer, intent(in) :: scheme + end subroutine model_data_set_scheme_num <>= - subroutine model_data_set_scheme_num (model, scheme) + module subroutine model_data_set_scheme_num (model, scheme) class(model_data_t), intent(inout) :: model integer, intent(in) :: scheme model%scheme = scheme end subroutine model_data_set_scheme_num @ %def model_data_set_scheme_num @ Complete model data initialization. <>= procedure :: freeze_fields => model_data_freeze_fields +<>= + module subroutine model_data_freeze_fields (model) + class(model_data_t), intent(inout) :: model + end subroutine model_data_freeze_fields <>= - subroutine model_data_freeze_fields (model) + module subroutine model_data_freeze_fields (model) class(model_data_t), intent(inout) :: model call model%field%freeze () end subroutine model_data_freeze_fields @ %def model_data_freeze @ Deep copy. The new model should already be initialized, so we do not allocate memory. <>= procedure :: copy_from => model_data_copy +<>= + module subroutine model_data_copy (model, src) + class(model_data_t), intent(inout), target :: model + class(model_data_t), intent(in), target :: src + end subroutine model_data_copy <>= - subroutine model_data_copy (model, src) + module subroutine model_data_copy (model, src) class(model_data_t), intent(inout), target :: model class(model_data_t), intent(in), target :: src class(modelpar_data_t), pointer :: data, src_data integer :: i model%scheme = src%scheme model%par_real = src%par_real model%par_complex = src%par_complex do i = 1, size (src%field) associate (field => model%field(i), src_field => src%field(i)) call field%init (src_field%get_longname (), src_field%get_pdg ()) call field%copy_from (src_field) src_data => src_field%mass_data if (associated (src_data)) then data => model%get_par_data_ptr (src_data%get_name ()) call field%set (mass_data = data) end if src_data => src_field%width_data if (associated (src_data)) then data => model%get_par_data_ptr (src_data%get_name ()) call field%set (width_data = data) end if call field%set_multiplicity () end associate end do do i = 1, size (src%vtx) call model%vtx(i)%copy_from (src%vtx(i), model) end do call model%freeze_vertices () end subroutine model_data_copy @ %def model_data_copy @ Return the model name and numeric scheme. <>= procedure :: get_name => model_data_get_name procedure :: get_scheme_num => model_data_get_scheme_num +<>= + module function model_data_get_name (model) result (name) + class(model_data_t), intent(in) :: model + type(string_t) :: name + end function model_data_get_name + module function model_data_get_scheme_num (model) result (scheme) + class(model_data_t), intent(in) :: model + integer :: scheme + end function model_data_get_scheme_num <>= - function model_data_get_name (model) result (name) + module function model_data_get_name (model) result (name) class(model_data_t), intent(in) :: model type(string_t) :: name name = model%name end function model_data_get_name - function model_data_get_scheme_num (model) result (scheme) + module function model_data_get_scheme_num (model) result (scheme) class(model_data_t), intent(in) :: model integer :: scheme scheme = model%scheme end function model_data_get_scheme_num @ %def model_data_get_name @ %def model_data_get_scheme @ Retrieve a MD5 sum for the current model parameter values and decay/polarization settings. This is done by writing them to a temporary file, using a standard format. If the model scheme is nonzero, it is also written. <>= procedure :: get_parameters_md5sum => model_data_get_parameters_md5sum +<>= + module function model_data_get_parameters_md5sum (model) result (par_md5sum) + character(32) :: par_md5sum + class(model_data_t), intent(in) :: model + end function model_data_get_parameters_md5sum <>= - function model_data_get_parameters_md5sum (model) result (par_md5sum) + module function model_data_get_parameters_md5sum (model) result (par_md5sum) character(32) :: par_md5sum class(model_data_t), intent(in) :: model real(default), dimension(:), allocatable :: par type(field_data_t), pointer :: field integer :: unit, i allocate (par (model%get_n_real ())) call model%real_parameters_to_array (par) unit = free_unit () open (unit, status="scratch", action="readwrite") if (model%scheme /= 0) write (unit, "(I0)") model%scheme write (unit, "(" // FMT_19 // ")") par do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) if (.not. field%is_stable (.false.) .or. .not. field%is_stable (.true.) & .or. field%is_polarized (.false.) .or. field%is_polarized (.true.))& then write (unit, "(3x,A)") char (field%get_longname ()) call field%write_decays (unit) end if end do rewind (unit) par_md5sum = md5sum (unit) close (unit) end function model_data_get_parameters_md5sum @ %def model_get_parameters_md5sum @ Return the MD5 sum. This is a placeholder, to be overwritten for the complete model definition. <>= procedure :: get_md5sum => model_data_get_md5sum +<>= + module function model_data_get_md5sum (model) result (md5sum) + class(model_data_t), intent(in) :: model + character(32) :: md5sum + end function model_data_get_md5sum <>= - function model_data_get_md5sum (model) result (md5sum) + module function model_data_get_md5sum (model) result (md5sum) class(model_data_t), intent(in) :: model character(32) :: md5sum md5sum = model%get_parameters_md5sum () end function model_data_get_md5sum @ %def model_data_get_md5sum @ Initialize a real or complex parameter. <>= generic :: init_par => model_data_init_par_real, model_data_init_par_complex procedure, private :: model_data_init_par_real procedure, private :: model_data_init_par_complex +<>= + module subroutine model_data_init_par_real (model, i, name, value) + class(model_data_t), intent(inout) :: model + integer, intent(in) :: i + type(string_t), intent(in) :: name + real(default), intent(in) :: value + end subroutine model_data_init_par_real + module subroutine model_data_init_par_complex (model, i, name, value) + class(model_data_t), intent(inout) :: model + integer, intent(in) :: i + type(string_t), intent(in) :: name + complex(default), intent(in) :: value + end subroutine model_data_init_par_complex <>= - subroutine model_data_init_par_real (model, i, name, value) + module subroutine model_data_init_par_real (model, i, name, value) class(model_data_t), intent(inout) :: model integer, intent(in) :: i type(string_t), intent(in) :: name real(default), intent(in) :: value call model%par_real(i)%init (name, value) end subroutine model_data_init_par_real - subroutine model_data_init_par_complex (model, i, name, value) + module subroutine model_data_init_par_complex (model, i, name, value) class(model_data_t), intent(inout) :: model integer, intent(in) :: i type(string_t), intent(in) :: name complex(default), intent(in) :: value call model%par_complex(i)%init (name, value) end subroutine model_data_init_par_complex @ %def model_data_init_par_real model_data_init_par_complex @ After initialization, return size of parameter array. <>= procedure :: get_n_real => model_data_get_n_real procedure :: get_n_complex => model_data_get_n_complex +<>= + module function model_data_get_n_real (model) result (n) + class(model_data_t), intent(in) :: model + integer :: n + end function model_data_get_n_real + module function model_data_get_n_complex (model) result (n) + class(model_data_t), intent(in) :: model + integer :: n + end function model_data_get_n_complex <>= - function model_data_get_n_real (model) result (n) + module function model_data_get_n_real (model) result (n) class(model_data_t), intent(in) :: model integer :: n n = size (model%par_real) end function model_data_get_n_real - function model_data_get_n_complex (model) result (n) + module function model_data_get_n_complex (model) result (n) class(model_data_t), intent(in) :: model integer :: n n = size (model%par_complex) end function model_data_get_n_complex @ %def model_data_get_n_real @ %def model_data_get_n_complex @ After initialization, extract the whole parameter array. <>= procedure :: real_parameters_to_array & => model_data_real_par_to_array procedure :: complex_parameters_to_array & => model_data_complex_par_to_array +<>= + module subroutine model_data_real_par_to_array (model, array) + class(model_data_t), intent(in) :: model + real(default), dimension(:), intent(inout) :: array + end subroutine model_data_real_par_to_array + module subroutine model_data_complex_par_to_array (model, array) + class(model_data_t), intent(in) :: model + complex(default), dimension(:), intent(inout) :: array + end subroutine model_data_complex_par_to_array <>= - subroutine model_data_real_par_to_array (model, array) + module subroutine model_data_real_par_to_array (model, array) class(model_data_t), intent(in) :: model real(default), dimension(:), intent(inout) :: array array = model%par_real%get_real () end subroutine model_data_real_par_to_array - subroutine model_data_complex_par_to_array (model, array) + module subroutine model_data_complex_par_to_array (model, array) class(model_data_t), intent(in) :: model complex(default), dimension(:), intent(inout) :: array array = model%par_complex%get_complex () end subroutine model_data_complex_par_to_array @ %def model_data_real_par_to_array @ %def model_data_complex_par_to_array @ After initialization, set the whole parameter array. <>= procedure :: real_parameters_from_array & => model_data_real_par_from_array procedure :: complex_parameters_from_array & => model_data_complex_par_from_array +<>= + module subroutine model_data_real_par_from_array (model, array) + class(model_data_t), intent(inout) :: model + real(default), dimension(:), intent(in) :: array + end subroutine model_data_real_par_from_array + module subroutine model_data_complex_par_from_array (model, array) + class(model_data_t), intent(inout) :: model + complex(default), dimension(:), intent(in) :: array + end subroutine model_data_complex_par_from_array <>= - subroutine model_data_real_par_from_array (model, array) + module subroutine model_data_real_par_from_array (model, array) class(model_data_t), intent(inout) :: model real(default), dimension(:), intent(in) :: array model%par_real = array end subroutine model_data_real_par_from_array - subroutine model_data_complex_par_from_array (model, array) + module subroutine model_data_complex_par_from_array (model, array) class(model_data_t), intent(inout) :: model complex(default), dimension(:), intent(in) :: array model%par_complex = array end subroutine model_data_complex_par_from_array @ %def model_data_real_par_from_array @ %def model_data_complex_par_from_array @ Analogous, for a C parameter array. <>= procedure :: real_parameters_to_c_array & => model_data_real_par_to_c_array +<>= + module subroutine model_data_real_par_to_c_array (model, array) + class(model_data_t), intent(in) :: model + real(c_default_float), dimension(:), intent(inout) :: array + end subroutine model_data_real_par_to_c_array <>= - subroutine model_data_real_par_to_c_array (model, array) + module subroutine model_data_real_par_to_c_array (model, array) class(model_data_t), intent(in) :: model real(c_default_float), dimension(:), intent(inout) :: array array = model%par_real%get_real () end subroutine model_data_real_par_to_c_array @ %def model_data_real_par_to_c_array @ After initialization, set the whole parameter array. <>= procedure :: real_parameters_from_c_array & => model_data_real_par_from_c_array +<>= + module subroutine model_data_real_par_from_c_array (model, array) + class(model_data_t), intent(inout) :: model + real(c_default_float), dimension(:), intent(in) :: array + end subroutine model_data_real_par_from_c_array <>= - subroutine model_data_real_par_from_c_array (model, array) + module subroutine model_data_real_par_from_c_array (model, array) class(model_data_t), intent(inout) :: model real(c_default_float), dimension(:), intent(in) :: array model%par_real = real (array, default) end subroutine model_data_real_par_from_c_array @ %def model_data_real_par_from_c_array @ After initialization, get pointer to a real or complex parameter, directly by index. <>= procedure :: get_par_real_ptr => model_data_get_par_real_ptr_index procedure :: get_par_complex_ptr => model_data_get_par_complex_ptr_index +<>= + module function model_data_get_par_real_ptr_index (model, i) result (ptr) + class(model_data_t), intent(inout) :: model + integer, intent(in) :: i + class(modelpar_data_t), pointer :: ptr + end function model_data_get_par_real_ptr_index + module function model_data_get_par_complex_ptr_index (model, i) result (ptr) + class(model_data_t), intent(inout) :: model + integer, intent(in) :: i + class(modelpar_data_t), pointer :: ptr + end function model_data_get_par_complex_ptr_index <>= - function model_data_get_par_real_ptr_index (model, i) result (ptr) + module function model_data_get_par_real_ptr_index (model, i) result (ptr) class(model_data_t), intent(inout) :: model integer, intent(in) :: i class(modelpar_data_t), pointer :: ptr ptr => model%par_real(i) end function model_data_get_par_real_ptr_index - function model_data_get_par_complex_ptr_index (model, i) result (ptr) + module function model_data_get_par_complex_ptr_index (model, i) result (ptr) class(model_data_t), intent(inout) :: model integer, intent(in) :: i class(modelpar_data_t), pointer :: ptr ptr => model%par_complex(i) end function model_data_get_par_complex_ptr_index @ %def model_data_get_par_real_ptr model_data_get_par_complex_ptr @ After initialization, get pointer to a parameter by name. <>= procedure :: get_par_data_ptr => model_data_get_par_data_ptr_name +<>= + module function model_data_get_par_data_ptr_name (model, name) result (ptr) + class(model_data_t), intent(in) :: model + type(string_t), intent(in) :: name + class(modelpar_data_t), pointer :: ptr + end function model_data_get_par_data_ptr_name <>= - function model_data_get_par_data_ptr_name (model, name) result (ptr) + module function model_data_get_par_data_ptr_name (model, name) result (ptr) class(model_data_t), intent(in) :: model type(string_t), intent(in) :: name class(modelpar_data_t), pointer :: ptr integer :: i do i = 1, size (model%par_real) if (model%par_real(i)%name == name) then ptr => model%par_real(i) return end if end do do i = 1, size (model%par_complex) if (model%par_complex(i)%name == name) then ptr => model%par_complex(i) return end if end do ptr => null () end function model_data_get_par_data_ptr_name @ %def model_data_get_par_data_ptr @ Return the value by name. Again, type conversion is allowed. <>= procedure :: get_real => model_data_get_par_real_value procedure :: get_complex => model_data_get_par_complex_value +<>= + module function model_data_get_par_real_value (model, name) result (value) + class(model_data_t), intent(in) :: model + type(string_t), intent(in) :: name + real(default) :: value + end function model_data_get_par_real_value + module function model_data_get_par_complex_value & + (model, name) result (value) + class(model_data_t), intent(in) :: model + type(string_t), intent(in) :: name + complex(default) :: value + end function model_data_get_par_complex_value <>= - function model_data_get_par_real_value (model, name) result (value) + module function model_data_get_par_real_value (model, name) result (value) class(model_data_t), intent(in) :: model type(string_t), intent(in) :: name class(modelpar_data_t), pointer :: par real(default) :: value par => model%get_par_data_ptr (name) value = par%get_real () end function model_data_get_par_real_value - function model_data_get_par_complex_value (model, name) result (value) + module function model_data_get_par_complex_value (model, name) result (value) class(model_data_t), intent(in) :: model type(string_t), intent(in) :: name class(modelpar_data_t), pointer :: par complex(default) :: value par => model%get_par_data_ptr (name) value = par%get_complex () end function model_data_get_par_complex_value @ %def model_data_get_real @ %def model_data_get_complex @ Modify a real or complex parameter. <>= generic :: set_par => model_data_set_par_real, model_data_set_par_complex procedure, private :: model_data_set_par_real procedure, private :: model_data_set_par_complex +<>= + module subroutine model_data_set_par_real (model, name, value) + class(model_data_t), intent(inout) :: model + type(string_t), intent(in) :: name + real(default), intent(in) :: value + end subroutine model_data_set_par_real + module subroutine model_data_set_par_complex (model, name, value) + class(model_data_t), intent(inout) :: model + type(string_t), intent(in) :: name + complex(default), intent(in) :: value + end subroutine model_data_set_par_complex <>= - subroutine model_data_set_par_real (model, name, value) + module subroutine model_data_set_par_real (model, name, value) class(model_data_t), intent(inout) :: model type(string_t), intent(in) :: name real(default), intent(in) :: value class(modelpar_data_t), pointer :: par par => model%get_par_data_ptr (name) par = value end subroutine model_data_set_par_real - subroutine model_data_set_par_complex (model, name, value) + module subroutine model_data_set_par_complex (model, name, value) class(model_data_t), intent(inout) :: model type(string_t), intent(in) :: name complex(default), intent(in) :: value class(modelpar_data_t), pointer :: par par => model%get_par_data_ptr (name) par = value end subroutine model_data_set_par_complex @ %def model_data_set_par_real model_data_set_par_complex @ List all fields in the model. <>= procedure :: write_fields => model_data_write_fields +<>= + module subroutine model_data_write_fields (model, unit) + class(model_data_t), intent(in) :: model + integer, intent(in), optional :: unit + end subroutine model_data_write_fields <>= - subroutine model_data_write_fields (model, unit) + module subroutine model_data_write_fields (model, unit) class(model_data_t), intent(in) :: model integer, intent(in), optional :: unit integer :: i do i = 1, size (model%field) call model%field(i)%write (unit) end do end subroutine model_data_write_fields @ %def model_data_write_fields @ After initialization, return number of fields (particles): <>= procedure :: get_n_field => model_data_get_n_field +<>= + module function model_data_get_n_field (model) result (n) + class(model_data_t), intent(in) :: model + integer :: n + end function model_data_get_n_field <>= - function model_data_get_n_field (model) result (n) + module function model_data_get_n_field (model) result (n) class(model_data_t), intent(in) :: model integer :: n n = size (model%field) end function model_data_get_n_field @ %def model_data_get_n_field @ Return the PDG code of a field. The field is identified by name or by index. If the field is not found, return zero. <>= generic :: get_pdg => & model_data_get_field_pdg_index, & model_data_get_field_pdg_name procedure, private :: model_data_get_field_pdg_index procedure, private :: model_data_get_field_pdg_name +<>= + module function model_data_get_field_pdg_index (model, i) result (pdg) + class(model_data_t), intent(in) :: model + integer, intent(in) :: i + integer :: pdg + end function model_data_get_field_pdg_index + module function model_data_get_field_pdg_name & + (model, name, check) result (pdg) + class(model_data_t), intent(in) :: model + type(string_t), intent(in) :: name + logical, intent(in), optional :: check + integer :: pdg + end function model_data_get_field_pdg_name <>= - function model_data_get_field_pdg_index (model, i) result (pdg) + module function model_data_get_field_pdg_index (model, i) result (pdg) class(model_data_t), intent(in) :: model integer, intent(in) :: i integer :: pdg pdg = model%field(i)%get_pdg () end function model_data_get_field_pdg_index - function model_data_get_field_pdg_name (model, name, check) result (pdg) + module function model_data_get_field_pdg_name & + (model, name, check) result (pdg) class(model_data_t), intent(in) :: model type(string_t), intent(in) :: name logical, intent(in), optional :: check integer :: pdg integer :: i do i = 1, size (model%field) associate (field => model%field(i)) if (field%matches_name (name, .false.)) then pdg = field%get_pdg () return else if (field%matches_name (name, .true.)) then pdg = - field%get_pdg () return end if end associate end do pdg = 0 call model%field_error (check, name) end function model_data_get_field_pdg_name @ %def model_data_get_field_pdg @ Return an array of all PDG codes, including antiparticles. The antiparticle are sorted after all particles. <>= procedure :: get_all_pdg => model_data_get_all_pdg +<>= + module subroutine model_data_get_all_pdg (model, pdg) + class(model_data_t), intent(in) :: model + integer, dimension(:), allocatable, intent(inout) :: pdg + end subroutine model_data_get_all_pdg <>= - subroutine model_data_get_all_pdg (model, pdg) + module subroutine model_data_get_all_pdg (model, pdg) class(model_data_t), intent(in) :: model integer, dimension(:), allocatable, intent(inout) :: pdg integer :: n0, n1, i, k n0 = size (model%field) n1 = n0 + count (model%field%has_antiparticle ()) allocate (pdg (n1)) pdg(1:n0) = model%field%get_pdg () k = n0 do i = 1, size (model%field) associate (field => model%field(i)) if (field%has_antiparticle ()) then k = k + 1 pdg(k) = - field%get_pdg () end if end associate end do end subroutine model_data_get_all_pdg @ %def model_data_get_all_pdg @ Return pointer to the field array. <>= procedure :: get_field_array_ptr => model_data_get_field_array_ptr +<>= + module function model_data_get_field_array_ptr (model) result (ptr) + class(model_data_t), intent(in), target :: model + type(field_data_t), dimension(:), pointer :: ptr + end function model_data_get_field_array_ptr <>= - function model_data_get_field_array_ptr (model) result (ptr) + module function model_data_get_field_array_ptr (model) result (ptr) class(model_data_t), intent(in), target :: model type(field_data_t), dimension(:), pointer :: ptr ptr => model%field end function model_data_get_field_array_ptr @ %def model_data_get_field_array_ptr @ Return pointer to a field. The identifier should be the unique long name, the PDG code, or the index. We can issue an error message, if the [[check]] flag is set. We never return an error if the PDG code is zero, this yields just a null pointer. <>= generic :: get_field_ptr => & model_data_get_field_ptr_name, & model_data_get_field_ptr_pdg procedure, private :: model_data_get_field_ptr_name procedure, private :: model_data_get_field_ptr_pdg procedure :: get_field_ptr_by_index => model_data_get_field_ptr_index +<>= + module function model_data_get_field_ptr_name & + (model, name, check) result (ptr) + class(model_data_t), intent(in), target :: model + type(string_t), intent(in) :: name + logical, intent(in), optional :: check + type(field_data_t), pointer :: ptr + end function model_data_get_field_ptr_name + module function model_data_get_field_ptr_pdg & + (model, pdg, check) result (ptr) + class(model_data_t), intent(in), target :: model + integer, intent(in) :: pdg + logical, intent(in), optional :: check + type(field_data_t), pointer :: ptr + end function model_data_get_field_ptr_pdg + module function model_data_get_field_ptr_index (model, i) result (ptr) + class(model_data_t), intent(in), target :: model + integer, intent(in) :: i + type(field_data_t), pointer :: ptr + end function model_data_get_field_ptr_index <>= - function model_data_get_field_ptr_name (model, name, check) result (ptr) + module function model_data_get_field_ptr_name & + (model, name, check) result (ptr) class(model_data_t), intent(in), target :: model type(string_t), intent(in) :: name logical, intent(in), optional :: check type(field_data_t), pointer :: ptr integer :: i do i = 1, size (model%field) if (model%field(i)%matches_name (name, .false.)) then ptr => model%field(i) return else if (model%field(i)%matches_name (name, .true.)) then ptr => model%field(i) return end if end do ptr => null () call model%field_error (check, name) end function model_data_get_field_ptr_name - function model_data_get_field_ptr_pdg (model, pdg, check) result (ptr) + module function model_data_get_field_ptr_pdg (model, pdg, check) result (ptr) class(model_data_t), intent(in), target :: model integer, intent(in) :: pdg logical, intent(in), optional :: check type(field_data_t), pointer :: ptr integer :: i, pdg_abs if (pdg == 0) then ptr => null () return end if pdg_abs = abs (pdg) do i = 1, size (model%field) if (abs(model%field(i)%get_pdg ()) == pdg_abs) then ptr => model%field(i) return end if end do ptr => null () call model%field_error (check, pdg=pdg) end function model_data_get_field_ptr_pdg - function model_data_get_field_ptr_index (model, i) result (ptr) + module function model_data_get_field_ptr_index (model, i) result (ptr) class(model_data_t), intent(in), target :: model integer, intent(in) :: i type(field_data_t), pointer :: ptr ptr => model%field(i) end function model_data_get_field_ptr_index @ %def model_data_get_field_ptr -@ Don't assign a pointer, just check. +@ Do not assign a pointer, just check. <>= procedure :: test_field => model_data_test_field_pdg +<>= + module function model_data_test_field_pdg (model, pdg, check) result (exist) + class(model_data_t), intent(in), target :: model + integer, intent(in) :: pdg + logical, intent(in), optional :: check + logical :: exist + end function model_data_test_field_pdg <>= - function model_data_test_field_pdg (model, pdg, check) result (exist) + module function model_data_test_field_pdg (model, pdg, check) result (exist) class(model_data_t), intent(in), target :: model integer, intent(in) :: pdg logical, intent(in), optional :: check logical :: exist exist = associated (model%get_field_ptr (pdg, check)) end function model_data_test_field_pdg @ %def model_data_test_field_pdg @ Error message, if [[check]] is set. <>= procedure :: field_error => model_data_field_error +<>= + module subroutine model_data_field_error (model, check, name, pdg) + class(model_data_t), intent(in) :: model + logical, intent(in), optional :: check + type(string_t), intent(in), optional :: name + integer, intent(in), optional :: pdg + end subroutine model_data_field_error <>= - subroutine model_data_field_error (model, check, name, pdg) + module subroutine model_data_field_error (model, check, name, pdg) class(model_data_t), intent(in) :: model logical, intent(in), optional :: check type(string_t), intent(in), optional :: name integer, intent(in), optional :: pdg if (present (check)) then if (check) then if (present (name)) then write (msg_buffer, "(A,1x,A,1x,A,1x,A)") & "No particle with name", char (name), & "is contained in model", char (model%name) else if (present (pdg)) then write (msg_buffer, "(A,1x,I0,1x,A,1x,A)") & "No particle with PDG code", pdg, & "is contained in model", char (model%name) else write (msg_buffer, "(A,1x,A,1x,A)") & "Particle missing", & "in model", char (model%name) end if call msg_fatal () end if end if end subroutine model_data_field_error @ %def model_data_field_error @ Assign mass and width value, which are associated via pointer. Identify the particle via pdg. <>= procedure :: set_field_mass => model_data_set_field_mass_pdg procedure :: set_field_width => model_data_set_field_width_pdg +<>= + module subroutine model_data_set_field_mass_pdg (model, pdg, value) + class(model_data_t), intent(inout) :: model + integer, intent(in) :: pdg + real(default), intent(in) :: value + end subroutine model_data_set_field_mass_pdg + module subroutine model_data_set_field_width_pdg (model, pdg, value) + class(model_data_t), intent(inout) :: model + integer, intent(in) :: pdg + real(default), intent(in) :: value + end subroutine model_data_set_field_width_pdg <>= - subroutine model_data_set_field_mass_pdg (model, pdg, value) + module subroutine model_data_set_field_mass_pdg (model, pdg, value) class(model_data_t), intent(inout) :: model integer, intent(in) :: pdg real(default), intent(in) :: value type(field_data_t), pointer :: field field => model%get_field_ptr (pdg, check = .true.) call field%set_mass (value) end subroutine model_data_set_field_mass_pdg - subroutine model_data_set_field_width_pdg (model, pdg, value) + module subroutine model_data_set_field_width_pdg (model, pdg, value) class(model_data_t), intent(inout) :: model integer, intent(in) :: pdg real(default), intent(in) :: value type(field_data_t), pointer :: field field => model%get_field_ptr (pdg, check = .true.) call field%set_width (value) end subroutine model_data_set_field_width_pdg @ %def model_data_set_field_mass @ %def model_data_set_field_width @ Mark a particle as unstable and provide a list of names for its decay processes. In contrast with the previous subroutine which is for internal use, we address the particle by its PDG code. If the index is negative, we address the antiparticle. <>= procedure :: set_unstable => model_data_set_unstable procedure :: set_stable => model_data_set_stable +<>= + module subroutine model_data_set_unstable & + (model, pdg, decay, isotropic, diagonal, decay_helicity) + class(model_data_t), intent(inout), target :: model + integer, intent(in) :: pdg + type(string_t), dimension(:), intent(in) :: decay + logical, intent(in), optional :: isotropic, diagonal + integer, intent(in), optional :: decay_helicity + end subroutine model_data_set_unstable + module subroutine model_data_set_stable (model, pdg) + class(model_data_t), intent(inout), target :: model + integer, intent(in) :: pdg + end subroutine model_data_set_stable <>= - subroutine model_data_set_unstable & + module subroutine model_data_set_unstable & (model, pdg, decay, isotropic, diagonal, decay_helicity) class(model_data_t), intent(inout), target :: model integer, intent(in) :: pdg type(string_t), dimension(:), intent(in) :: decay logical, intent(in), optional :: isotropic, diagonal integer, intent(in), optional :: decay_helicity type(field_data_t), pointer :: field field => model%get_field_ptr (pdg) if (pdg > 0) then call field%set ( & p_is_stable = .false., p_decay = decay, & p_decays_isotropically = isotropic, & p_decays_diagonal = diagonal, & p_decay_helicity = decay_helicity) else call field%set ( & a_is_stable = .false., a_decay = decay, & a_decays_isotropically = isotropic, & a_decays_diagonal = diagonal, & a_decay_helicity = decay_helicity) end if end subroutine model_data_set_unstable - subroutine model_data_set_stable (model, pdg) + module subroutine model_data_set_stable (model, pdg) class(model_data_t), intent(inout), target :: model integer, intent(in) :: pdg type(field_data_t), pointer :: field field => model%get_field_ptr (pdg) if (pdg > 0) then call field%set (p_is_stable = .true.) else call field%set (a_is_stable = .true.) end if end subroutine model_data_set_stable @ %def model_data_set_unstable @ %def model_data_set_stable @ Mark a particle as polarized. <>= procedure :: set_polarized => model_data_set_polarized procedure :: set_unpolarized => model_data_set_unpolarized +<>= + module subroutine model_data_set_polarized (model, pdg) + class(model_data_t), intent(inout), target :: model + integer, intent(in) :: pdg + end subroutine model_data_set_polarized + module subroutine model_data_set_unpolarized (model, pdg) + class(model_data_t), intent(inout), target :: model + integer, intent(in) :: pdg + end subroutine model_data_set_unpolarized <>= - subroutine model_data_set_polarized (model, pdg) + module subroutine model_data_set_polarized (model, pdg) class(model_data_t), intent(inout), target :: model integer, intent(in) :: pdg type(field_data_t), pointer :: field field => model%get_field_ptr (pdg) if (pdg > 0) then call field%set (p_polarized = .true.) else call field%set (a_polarized = .true.) end if end subroutine model_data_set_polarized - subroutine model_data_set_unpolarized (model, pdg) + module subroutine model_data_set_unpolarized (model, pdg) class(model_data_t), intent(inout), target :: model integer, intent(in) :: pdg type(field_data_t), pointer :: field field => model%get_field_ptr (pdg) if (pdg > 0) then call field%set (p_polarized = .false.) else call field%set (a_polarized = .false.) end if end subroutine model_data_set_unpolarized @ %def model_data_set_polarized @ %def model_data_set_unpolarized @ Revert all polarized (unstable) particles to unpolarized (stable) status, respectively. <>= procedure :: clear_unstable => model_clear_unstable procedure :: clear_polarized => model_clear_polarized +<>= + module subroutine model_clear_unstable (model) + class(model_data_t), intent(inout), target :: model + end subroutine model_clear_unstable + module subroutine model_clear_polarized (model) + class(model_data_t), intent(inout), target :: model + end subroutine model_clear_polarized <>= - subroutine model_clear_unstable (model) + module subroutine model_clear_unstable (model) class(model_data_t), intent(inout), target :: model integer :: i type(field_data_t), pointer :: field do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) call field%set (p_is_stable = .true.) if (field%has_antiparticle ()) then call field%set (a_is_stable = .true.) end if end do end subroutine model_clear_unstable - subroutine model_clear_polarized (model) + module subroutine model_clear_polarized (model) class(model_data_t), intent(inout), target :: model integer :: i type(field_data_t), pointer :: field do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) call field%set (p_polarized = .false.) if (field%has_antiparticle ()) then call field%set (a_polarized = .false.) end if end do end subroutine model_clear_polarized @ %def model_clear_unstable @ %def model_clear_polarized @ List all vertices, optionally also the hash table. <>= procedure :: write_vertices => model_data_write_vertices +<>= + module subroutine model_data_write_vertices (model, unit, verbose) + class(model_data_t), intent(in) :: model + integer, intent(in), optional :: unit + logical, intent(in), optional :: verbose + end subroutine model_data_write_vertices <>= - subroutine model_data_write_vertices (model, unit, verbose) + module subroutine model_data_write_vertices (model, unit, verbose) class(model_data_t), intent(in) :: model integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: i, u u = given_output_unit (unit) do i = 1, size (model%vtx) call vertex_write (model%vtx(i), unit) end do if (present (verbose)) then if (verbose) then write (u, *) call vertex_table_write (model%vt, unit) end if end if end subroutine model_data_write_vertices @ %def model_data_write_vertices @ Vertex definition. <>= generic :: set_vertex => & model_data_set_vertex_pdg, model_data_set_vertex_names procedure, private :: model_data_set_vertex_pdg procedure, private :: model_data_set_vertex_names +<>= + module subroutine model_data_set_vertex_pdg (model, i, pdg) + class(model_data_t), intent(inout), target :: model + integer, intent(in) :: i + integer, dimension(:), intent(in) :: pdg + end subroutine model_data_set_vertex_pdg + module subroutine model_data_set_vertex_names (model, i, name) + class(model_data_t), intent(inout), target :: model + integer, intent(in) :: i + type(string_t), dimension(:), intent(in) :: name + end subroutine model_data_set_vertex_names <>= - subroutine model_data_set_vertex_pdg (model, i, pdg) + module subroutine model_data_set_vertex_pdg (model, i, pdg) class(model_data_t), intent(inout), target :: model integer, intent(in) :: i integer, dimension(:), intent(in) :: pdg call vertex_init (model%vtx(i), pdg, model) end subroutine model_data_set_vertex_pdg - subroutine model_data_set_vertex_names (model, i, name) + module subroutine model_data_set_vertex_names (model, i, name) class(model_data_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), dimension(:), intent(in) :: name integer, dimension(size(name)) :: pdg integer :: j do j = 1, size (name) pdg(j) = model%get_pdg (name(j)) end do call model%set_vertex (i, pdg) end subroutine model_data_set_vertex_names @ %def model_data_set_vertex @ Finalize vertex definition: set up the hash table. <>= procedure :: freeze_vertices => model_data_freeze_vertices +<>= + module subroutine model_data_freeze_vertices (model) + class(model_data_t), intent(inout) :: model + end subroutine model_data_freeze_vertices <>= - subroutine model_data_freeze_vertices (model) + module subroutine model_data_freeze_vertices (model) class(model_data_t), intent(inout) :: model call model%vt%init (model%field, model%vtx) end subroutine model_data_freeze_vertices @ %def model_data_freeze_vertices @ Number of vertices in model <>= procedure :: get_n_vtx => model_data_get_n_vtx +<>= + module function model_data_get_n_vtx (model) result (n) + class(model_data_t), intent(in) :: model + integer :: n + end function model_data_get_n_vtx <>= - function model_data_get_n_vtx (model) result (n) + module function model_data_get_n_vtx (model) result (n) class(model_data_t), intent(in) :: model integer :: n n = size (model%vtx) end function model_data_get_n_vtx @ %def model_data_get_n_vtx @ Lookup functions <>= procedure :: match_vertex => model_data_match_vertex +<>= + module subroutine model_data_match_vertex (model, pdg1, pdg2, pdg3) + class(model_data_t), intent(in) :: model + integer, intent(in) :: pdg1, pdg2 + integer, dimension(:), allocatable, intent(out) :: pdg3 + end subroutine model_data_match_vertex <>= - subroutine model_data_match_vertex (model, pdg1, pdg2, pdg3) + module subroutine model_data_match_vertex (model, pdg1, pdg2, pdg3) class(model_data_t), intent(in) :: model integer, intent(in) :: pdg1, pdg2 integer, dimension(:), allocatable, intent(out) :: pdg3 call model%vt%match (pdg1, pdg2, pdg3) end subroutine model_data_match_vertex @ %def model_data_match_vertex <>= procedure :: check_vertex => model_data_check_vertex +<>= + module function model_data_check_vertex & + (model, pdg1, pdg2, pdg3) result (flag) + logical :: flag + class(model_data_t), intent(in) :: model + integer, intent(in) :: pdg1, pdg2, pdg3 + end function model_data_check_vertex <>= - function model_data_check_vertex (model, pdg1, pdg2, pdg3) result (flag) + module function model_data_check_vertex & + (model, pdg1, pdg2, pdg3) result (flag) logical :: flag class(model_data_t), intent(in) :: model integer, intent(in) :: pdg1, pdg2, pdg3 flag = model%vt%check (pdg1, pdg2, pdg3) end function model_data_check_vertex @ %def model_data_check_vertex @ \subsection{Toy Models} This is a stripped-down version of the (already trivial) model 'Test'. <>= procedure :: init_test => model_data_init_test +<>= + module subroutine model_data_init_test (model) + class(model_data_t), intent(out) :: model + end subroutine model_data_init_test <>= - subroutine model_data_init_test (model) + module subroutine model_data_init_test (model) class(model_data_t), intent(out) :: model type(field_data_t), pointer :: field integer, parameter :: n_real = 4 integer, parameter :: n_field = 2 integer, parameter :: n_vertex = 2 integer :: i call model%init (var_str ("Test"), & n_real, 0, n_field, n_vertex) i = 0 i = i + 1 call model%init_par (i, var_str ("gy"), 1._default) i = i + 1 call model%init_par (i, var_str ("ms"), 125._default) i = i + 1 call model%init_par (i, var_str ("ff"), 1.5_default) i = i + 1 call model%init_par (i, var_str ("mf"), 1.5_default * 125._default) i = 0 i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("SCALAR"), 25) call field%set (spin_type=1) call field%set (mass_data=model%get_par_real_ptr (2)) call field%set (name = [var_str ("s")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("FERMION"), 6) call field%set (spin_type=2) call field%set (mass_data=model%get_par_real_ptr (4)) call field%set (name = [var_str ("f")], anti = [var_str ("fbar")]) call model%freeze_fields () i = 0 i = i + 1 call model%set_vertex (i, [var_str ("fbar"), var_str ("f"), var_str ("s")]) i = i + 1 call model%set_vertex (i, [var_str ("s"), var_str ("s"), var_str ("s")]) call model%freeze_vertices () end subroutine model_data_init_test @ %def model_data_init_test @ This procedure prepares a subset of QED for testing purposes. <>= procedure :: init_qed_test => model_data_init_qed_test +<>= + module subroutine model_data_init_qed_test (model) + class(model_data_t), intent(out) :: model + end subroutine model_data_init_qed_test <>= - subroutine model_data_init_qed_test (model) + module subroutine model_data_init_qed_test (model) class(model_data_t), intent(out) :: model type(field_data_t), pointer :: field integer, parameter :: n_real = 1 integer, parameter :: n_field = 2 integer :: i call model%init (var_str ("QED_test"), & n_real, 0, n_field, 0) i = 0 i = i + 1 call model%init_par (i, var_str ("me"), 0.000510997_default) i = 0 i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("E_LEPTON"), 11) call field%set (spin_type=2, charge_type=-4) call field%set (mass_data=model%get_par_real_ptr (1)) call field%set (name = [var_str ("e-")], anti = [var_str ("e+")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("PHOTON"), 22) call field%set (spin_type=3) call field%set (name = [var_str ("A")]) call model%freeze_fields () call model%freeze_vertices () end subroutine model_data_init_qed_test @ %def model_data_init_qed_test @ This procedure prepares a subset of the Standard Model for testing purposes. We can thus avoid dependencies on model I/O, which is not defined here. <>= procedure :: init_sm_test => model_data_init_sm_test +<>= + module subroutine model_data_init_sm_test (model) + class(model_data_t), intent(out) :: model + end subroutine model_data_init_sm_test <>= - subroutine model_data_init_sm_test (model) + module subroutine model_data_init_sm_test (model) class(model_data_t), intent(out) :: model type(field_data_t), pointer :: field integer, parameter :: n_real = 11 integer, parameter :: n_field = 19 integer, parameter :: n_vtx = 9 integer :: i call model%init (var_str ("SM_test"), & n_real, 0, n_field, n_vtx) i = 0 i = i + 1 call model%init_par (i, var_str ("mZ"), 91.1882_default) i = i + 1 call model%init_par (i, var_str ("mW"), 80.419_default) i = i + 1 call model%init_par (i, var_str ("me"), 0.000510997_default) i = i + 1 call model%init_par (i, var_str ("mmu"), 0.105658389_default) i = i + 1 call model%init_par (i, var_str ("mb"), 4.2_default) i = i + 1 call model%init_par (i, var_str ("mtop"), 173.1_default) i = i + 1 call model%init_par (i, var_str ("wZ"), 2.443_default) i = i + 1 call model%init_par (i, var_str ("wW"), 2.049_default) i = i + 1 call model%init_par (i, var_str ("ee"), 0.3079561542961_default) i = i + 1 call model%init_par (i, var_str ("cw"), 8.819013863636E-01_default) i = i + 1 call model%init_par (i, var_str ("sw"), 4.714339240339E-01_default) i = 0 i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("D_QUARK"), 1) call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) call field%set (name = [var_str ("d")], anti = [var_str ("dbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("U_QUARK"), 2) call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) call field%set (name = [var_str ("u")], anti = [var_str ("ubar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("S_QUARK"), 3) call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) call field%set (name = [var_str ("s")], anti = [var_str ("sbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("C_QUARK"), 4) call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) call field%set (name = [var_str ("c")], anti = [var_str ("cbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("B_QUARK"), 5) call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2) call field%set (mass_data=model%get_par_real_ptr (5)) call field%set (name = [var_str ("b")], anti = [var_str ("bbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("T_QUARK"), 6) call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2) call field%set (mass_data=model%get_par_real_ptr (6)) call field%set (name = [var_str ("t")], anti = [var_str ("tbar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("E_LEPTON"), 11) call field%set (spin_type=2) call field%set (mass_data=model%get_par_real_ptr (3)) call field%set (name = [var_str ("e-")], anti = [var_str ("e+")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("E_NEUTRINO"), 12) call field%set (spin_type=2, is_left_handed=.true.) call field%set (name = [var_str ("nue")], anti = [var_str ("nuebar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("MU_LEPTON"), 13) call field%set (spin_type=2) call field%set (mass_data=model%get_par_real_ptr (4)) call field%set (name = [var_str ("mu-")], anti = [var_str ("mu+")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("MU_NEUTRINO"), 14) call field%set (spin_type=2, is_left_handed=.true.) call field%set (name = [var_str ("numu")], anti = [var_str ("numubar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("GLUON"), 21) call field%set (spin_type=3, color_type=8) call field%set (name = [var_str ("gl")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("PHOTON"), 22) call field%set (spin_type=3) call field%set (name = [var_str ("A")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("Z_BOSON"), 23) call field%set (spin_type=3) call field%set (mass_data=model%get_par_real_ptr (1)) call field%set (width_data=model%get_par_real_ptr (7)) call field%set (name = [var_str ("Z")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("W_BOSON"), 24) call field%set (spin_type=3) call field%set (mass_data=model%get_par_real_ptr (2)) call field%set (width_data=model%get_par_real_ptr (8)) call field%set (name = [var_str ("W+")], anti = [var_str ("W-")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HIGGS"), 25) call field%set (spin_type=1) ! call field%set (mass_data=model%get_par_real_ptr (2)) ! call field%set (width_data=model%get_par_real_ptr (8)) call field%set (name = [var_str ("H")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("PROTON"), 2212) call field%set (spin_type=2) call field%set (name = [var_str ("p")], anti = [var_str ("pbar")]) ! call field%set (mass_data=model%get_par_real_ptr (12)) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HADRON_REMNANT_SINGLET"), 91) call field%set (color_type=1) call field%set (name = [var_str ("hr1")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HADRON_REMNANT_TRIPLET"), 92) call field%set (color_type=3) call field%set (name = [var_str ("hr3")], anti = [var_str ("hr3bar")]) i = i + 1 field => model%get_field_ptr_by_index (i) call field%init (var_str ("HADRON_REMNANT_OCTET"), 93) call field%set (color_type=8) call field%set (name = [var_str ("hr8")]) call model%freeze_fields () i = 0 i = i + 1 call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("A")]) i = i + 1 call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("A")]) i = i + 1 call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), var_str ("gl")]) i = i + 1 call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("gl")]) i = i + 1 call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("gl")]) i = i + 1 call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("Z")]) i = i + 1 call model%set_vertex (i, [var_str ("ubar"), var_str ("d"), var_str ("W+")]) i = i + 1 call model%set_vertex (i, [var_str ("dbar"), var_str ("u"), var_str ("W-")]) call model%freeze_vertices () end subroutine model_data_init_sm_test @ %def model_data_init_sm_test @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Model Testbed} The standard way of defining a model uses concrete variables and expressions to interpret the model file. Some of this is not available at the point of use. This is no problem for the \whizard\ program as a whole, but unit tests are kept local to their respective module and don't access all definitions. Instead, we introduce a separate module that provides hooks, one for initializing a model and one for finalizing a model. The main program can assign real routines to the hooks (procedure pointers of abstract type) before unit tests are called. The unit tests can call the abstract routines without knowing about their implementation. <<[[model_testbed.f90]]>>= <> module model_testbed <> use model_data use var_base <> <> <> <> end module model_testbed @ %def model_testbed @ \subsection{Abstract Model Handlers} Both routines take a polymorphic model (data) target, which is not allocated/deallocated inside the subroutine. The model constructor [[prepare_model]] requires the model name as input. It can, optionally, return a link to the variable list of the model. <>= public :: prepare_model public :: cleanup_model <>= procedure (prepare_model_proc), pointer :: prepare_model => null () procedure (cleanup_model_proc), pointer :: cleanup_model => null () <>= abstract interface subroutine prepare_model_proc (model, name, vars) import class(model_data_t), intent(inout), pointer :: model type(string_t), intent(in) :: name class(vars_t), pointer, intent(out), optional :: vars end subroutine prepare_model_proc end interface abstract interface subroutine cleanup_model_proc (model) import class(model_data_t), intent(inout), target :: model end subroutine cleanup_model_proc end interface @ %def prepare_model @ %def cleanup_model @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Helicities} This module defines types and tools for dealing with helicity information. <<[[helicities.f90]]>>= <> module helicities - use io_units - <> <> <> <> + interface +<> + end interface + +end module helicities +@ %def helicities +@ +<<[[helicities_sub.f90]]>>= +<> + +submodule (helicities) helicities_s + + use io_units + + implicit none + contains <> -end module helicities -@ %def helicities +end submodule helicities_s + +@ %def helicities_s @ \subsection{Helicity types} Helicities may be defined or undefined, corresponding to a polarized or unpolarized state. Each helicity is actually a pair of helicities, corresponding to an entry in the spin density matrix. Obviously, diagonal entries are distinguished. <>= public :: helicity_t <>= type :: helicity_t private logical :: defined = .false. integer :: h1, h2 contains <> end type helicity_t @ %def helicity_t @ Constructor functions, for convenience: <>= public :: helicity <>= interface helicity module procedure helicity0, helicity1, helicity2 end interface helicity +<>= + pure module function helicity0 () result (hel) + type(helicity_t) :: hel + end function helicity0 + elemental module function helicity1 (h) result (hel) + type(helicity_t) :: hel + integer, intent(in) :: h + end function helicity1 + elemental module function helicity2 (h2, h1) result (hel) + type(helicity_t) :: hel + integer, intent(in) :: h1, h2 + end function helicity2 <>= - pure function helicity0 () result (hel) + pure module function helicity0 () result (hel) type(helicity_t) :: hel end function helicity0 - elemental function helicity1 (h) result (hel) + elemental module function helicity1 (h) result (hel) type(helicity_t) :: hel integer, intent(in) :: h call hel%init (h) end function helicity1 - elemental function helicity2 (h2, h1) result (hel) + elemental module function helicity2 (h2, h1) result (hel) type(helicity_t) :: hel integer, intent(in) :: h1, h2 call hel%init (h2, h1) end function helicity2 @ %def helicity @ Initializers. Note: conceptually, the argument to initializers should be INTENT(OUT). However, Interp.\ F08/0033 prohibited this. The reason is that, in principle, the call could result in the execution of an impure finalizer for a type extension of [[hel]] (ugh). <>= generic :: init => helicity_init_empty, helicity_init_same, helicity_init_different procedure, private :: helicity_init_empty procedure, private :: helicity_init_same procedure, private :: helicity_init_different +<>= + elemental module subroutine helicity_init_empty (hel) + class(helicity_t), intent(inout) :: hel + end subroutine helicity_init_empty + elemental module subroutine helicity_init_same (hel, h) + class(helicity_t), intent(inout) :: hel + integer, intent(in) :: h + end subroutine helicity_init_same + elemental module subroutine helicity_init_different (hel, h2, h1) + class(helicity_t), intent(inout) :: hel + integer, intent(in) :: h1, h2 + end subroutine helicity_init_different <>= - elemental subroutine helicity_init_empty (hel) + elemental module subroutine helicity_init_empty (hel) class(helicity_t), intent(inout) :: hel hel%defined = .false. end subroutine helicity_init_empty - elemental subroutine helicity_init_same (hel, h) + elemental module subroutine helicity_init_same (hel, h) class(helicity_t), intent(inout) :: hel integer, intent(in) :: h hel%defined = .true. hel%h1 = h hel%h2 = h end subroutine helicity_init_same - elemental subroutine helicity_init_different (hel, h2, h1) + elemental module subroutine helicity_init_different (hel, h2, h1) class(helicity_t), intent(inout) :: hel integer, intent(in) :: h1, h2 hel%defined = .true. hel%h2 = h2 hel%h1 = h1 end subroutine helicity_init_different @ %def helicity_init @ Undefine: <>= procedure :: undefine => helicity_undefine +<>= + elemental module subroutine helicity_undefine (hel) + class(helicity_t), intent(inout) :: hel + end subroutine helicity_undefine <>= - elemental subroutine helicity_undefine (hel) + elemental module subroutine helicity_undefine (hel) class(helicity_t), intent(inout) :: hel hel%defined = .false. end subroutine helicity_undefine @ %def helicity_undefine @ Diagonalize by removing the second entry (use with care!) <>= procedure :: diagonalize => helicity_diagonalize +<>= + elemental module subroutine helicity_diagonalize (hel) + class(helicity_t), intent(inout) :: hel + end subroutine helicity_diagonalize <>= - elemental subroutine helicity_diagonalize (hel) + elemental module subroutine helicity_diagonalize (hel) class(helicity_t), intent(inout) :: hel hel%h2 = hel%h1 end subroutine helicity_diagonalize @ %def helicity_diagonalize @ Flip helicity indices by sign. <>= procedure :: flip => helicity_flip +<>= + elemental module subroutine helicity_flip (hel) + class(helicity_t), intent(inout) :: hel + end subroutine helicity_flip <>= - elemental subroutine helicity_flip (hel) + elemental module subroutine helicity_flip (hel) class(helicity_t), intent(inout) :: hel hel%h1 = - hel%h1 hel%h2 = - hel%h2 end subroutine helicity_flip @ %def helicity_flip @ <>= procedure :: get_indices => helicity_get_indices +<>= + module subroutine helicity_get_indices (hel, h1, h2) + class(helicity_t), intent(in) :: hel + integer, intent(out) :: h1, h2 + end subroutine helicity_get_indices <>= - subroutine helicity_get_indices (hel, h1, h2) + module subroutine helicity_get_indices (hel, h1, h2) class(helicity_t), intent(in) :: hel integer, intent(out) :: h1, h2 h1 = hel%h1; h2 = hel%h2 end subroutine helicity_get_indices @ %def helicity_get_indices @ Output (no linebreak). No output if undefined. <>= procedure :: write => helicity_write +<>= + module subroutine helicity_write (hel, unit) + class(helicity_t), intent(in) :: hel + integer, intent(in), optional :: unit + end subroutine helicity_write <>= - subroutine helicity_write (hel, unit) + module subroutine helicity_write (hel, unit) class(helicity_t), intent(in) :: hel integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return if (hel%defined) then write (u, "(A)", advance="no") "h(" write (u, "(I0)", advance="no") hel%h1 if (hel%h1 /= hel%h2) then write (u, "(A)", advance="no") "|" write (u, "(I0)", advance="no") hel%h2 end if write (u, "(A)", advance="no") ")" end if end subroutine helicity_write @ %def helicity_write @ Binary I/O. Write contents only if defined. <>= procedure :: write_raw => helicity_write_raw procedure :: read_raw => helicity_read_raw +<>= + module subroutine helicity_write_raw (hel, u) + class(helicity_t), intent(in) :: hel + integer, intent(in) :: u + end subroutine helicity_write_raw + module subroutine helicity_read_raw (hel, u, iostat) + class(helicity_t), intent(out) :: hel + integer, intent(in) :: u + integer, intent(out), optional :: iostat + end subroutine helicity_read_raw <>= - subroutine helicity_write_raw (hel, u) + module subroutine helicity_write_raw (hel, u) class(helicity_t), intent(in) :: hel integer, intent(in) :: u write (u) hel%defined if (hel%defined) then write (u) hel%h1, hel%h2 end if end subroutine helicity_write_raw - subroutine helicity_read_raw (hel, u, iostat) + module subroutine helicity_read_raw (hel, u, iostat) class(helicity_t), intent(out) :: hel integer, intent(in) :: u integer, intent(out), optional :: iostat read (u, iostat=iostat) hel%defined if (hel%defined) then read (u, iostat=iostat) hel%h1, hel%h2 end if end subroutine helicity_read_raw @ %def helicity_write_raw helicity_read_raw @ \subsection{Predicates} Check if the helicity is defined: <>= procedure :: is_defined => helicity_is_defined +<>= + elemental module function helicity_is_defined (hel) result (defined) + logical :: defined + class(helicity_t), intent(in) :: hel + end function helicity_is_defined <>= - elemental function helicity_is_defined (hel) result (defined) + elemental module function helicity_is_defined (hel) result (defined) logical :: defined class(helicity_t), intent(in) :: hel defined = hel%defined end function helicity_is_defined @ %def helicity_is_defined @ Return true if the two helicities are equal or the particle is unpolarized: <>= procedure :: is_diagonal => helicity_is_diagonal +<>= + elemental module function helicity_is_diagonal (hel) result (diagonal) + logical :: diagonal + class(helicity_t), intent(in) :: hel + end function helicity_is_diagonal <>= - elemental function helicity_is_diagonal (hel) result (diagonal) + elemental module function helicity_is_diagonal (hel) result (diagonal) logical :: diagonal class(helicity_t), intent(in) :: hel if (hel%defined) then diagonal = hel%h1 == hel%h2 else diagonal = .true. end if end function helicity_is_diagonal @ %def helicity_is_diagonal @ \subsection{Accessing contents} This returns a two-element array and thus cannot be elemental. The result is unpredictable if the helicity is undefined. <>= procedure :: to_pair => helicity_to_pair +<>= + pure module function helicity_to_pair (hel) result (h) + integer, dimension(2) :: h + class(helicity_t), intent(in) :: hel + end function helicity_to_pair <>= - pure function helicity_to_pair (hel) result (h) + pure module function helicity_to_pair (hel) result (h) integer, dimension(2) :: h class(helicity_t), intent(in) :: hel h(1) = hel%h2 h(2) = hel%h1 end function helicity_to_pair @ %def helicity_to_pair @ \subsection{Comparisons} When comparing helicities, if either one is undefined, they are considered to match. In other words, an unpolarized particle matches any polarization. In the [[dmatch]] variant, it matches only diagonal helicity. <>= generic :: operator(.match.) => helicity_match generic :: operator(.dmatch.) => helicity_match_diagonal generic :: operator(==) => helicity_eq generic :: operator(/=) => helicity_neq procedure, private :: helicity_match procedure, private :: helicity_match_diagonal procedure, private :: helicity_eq procedure, private :: helicity_neq @ %def .match. .dmatch. == /= +<>= + elemental module function helicity_match (hel1, hel2) result (eq) + logical :: eq + class(helicity_t), intent(in) :: hel1, hel2 + end function helicity_match + elemental module function helicity_match_diagonal (hel1, hel2) result (eq) + logical :: eq + class(helicity_t), intent(in) :: hel1, hel2 + end function helicity_match_diagonal <>= - elemental function helicity_match (hel1, hel2) result (eq) + elemental module function helicity_match (hel1, hel2) result (eq) logical :: eq class(helicity_t), intent(in) :: hel1, hel2 if (hel1%defined .and. hel2%defined) then eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2) else eq = .true. end if end function helicity_match - elemental function helicity_match_diagonal (hel1, hel2) result (eq) + elemental module function helicity_match_diagonal (hel1, hel2) result (eq) logical :: eq class(helicity_t), intent(in) :: hel1, hel2 if (hel1%defined .and. hel2%defined) then eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2) else if (hel1%defined) then eq = hel1%h1 == hel1%h2 else if (hel2%defined) then eq = hel2%h1 == hel2%h2 else eq = .true. end if end function helicity_match_diagonal @ %def helicity_match helicity_match_diagonal +<>= + elemental module function helicity_eq (hel1, hel2) result (eq) + logical :: eq + class(helicity_t), intent(in) :: hel1, hel2 + end function helicity_eq <>= - elemental function helicity_eq (hel1, hel2) result (eq) + elemental module function helicity_eq (hel1, hel2) result (eq) logical :: eq class(helicity_t), intent(in) :: hel1, hel2 if (hel1%defined .and. hel2%defined) then eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2) else if (.not. hel1%defined .and. .not. hel2%defined) then eq = .true. else eq = .false. end if end function helicity_eq @ %def helicity_eq +<>= + elemental module function helicity_neq (hel1, hel2) result (neq) + logical :: neq + class(helicity_t), intent(in) :: hel1, hel2 + end function helicity_neq <>= - elemental function helicity_neq (hel1, hel2) result (neq) + elemental module function helicity_neq (hel1, hel2) result (neq) logical :: neq class(helicity_t), intent(in) :: hel1, hel2 if (hel1%defined .and. hel2%defined) then neq = (hel1%h1 /= hel2%h1) .or. (hel1%h2 /= hel2%h2) else if (.not. hel1%defined .and. .not. hel2%defined) then neq = .false. else neq = .true. end if end function helicity_neq @ %def helicity_neq @ \subsection{Tools} Merge two helicity objects by taking the first entry from the first and the second entry from the second argument. Makes sense only if the input helicities were defined and diagonal. The handling of ghost flags is not well-defined; one should verify beforehand that they match. <>= generic :: operator(.merge.) => merge_helicities procedure, private :: merge_helicities @ %def .merge. +<>= + elemental module function merge_helicities (hel1, hel2) result (hel) + type(helicity_t) :: hel + class(helicity_t), intent(in) :: hel1, hel2 + end function merge_helicities <>= - elemental function merge_helicities (hel1, hel2) result (hel) + elemental module function merge_helicities (hel1, hel2) result (hel) type(helicity_t) :: hel class(helicity_t), intent(in) :: hel1, hel2 if (hel1%defined .and. hel2%defined) then call hel%init (hel2%h1, hel1%h1) else if (hel1%defined) then call hel%init (hel1%h2, hel1%h1) else if (hel2%defined) then call hel%init (hel2%h2, hel2%h1) end if end function merge_helicities @ %def merge_helicities @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Colors} This module defines a type and tools for dealing with color information. Each particle can have zero or more (in practice, usually not more than two) color indices. Color indices are positive; flow direction can be determined from the particle nature. While parton shower matrix elements are diagonal in color, some special applications (e.g., subtractions for NLO matrix elements) require non-diagonal color matrices. <<[[colors.f90]]>>= <> module colors <> <> - use io_units - use diagnostics <> <> <> <> + interface +<> + end interface + +end module colors +@ %def colors +@ +<<[[colors_sub.f90]]>>= +<> + +submodule (colors) colors_s + + use io_units + use diagnostics + + implicit none + contains <> -end module colors -@ %def colors +end submodule colors_s + +@ %def colors_s @ \subsection{The color type} A particle may have an arbitrary number of color indices (in practice, from zero to two, but more are possible). This object acts as a container. (The current implementation has a fixed array of length two.) The fact that color comes as an array prohibits elemental procedures in some places. (May add interfaces and multi versions where necessary.) The color may be undefined. NOTE: Due to a compiler bug in nagfor 5.2, we do not use allocatable but fixed-size arrays with dimension 2. Only nonzero entries count. This may be more efficient anyway, but gives up some flexibility. However, the squaring algorithm currently works only for singlets, (anti)triplets and octets anyway, so two components are enough. This type has to be generalized (abstract type and specific implementations) when trying to pursue generalized color flows or Monte Carlo over continuous color. <>= public :: color_t <>= type :: color_t private logical :: defined = .false. integer, dimension(2) :: c1 = 0, c2 = 0 logical :: ghost = .false. contains <> end type color_t @ %def color_t +<>= + type :: entry_t + integer, dimension(:), allocatable :: map + type(color_t), dimension(:), allocatable :: col + type(entry_t), pointer :: next => null () + logical :: nlo_event = .false. + end type entry_t + type :: list_t + integer :: n = 0 + type(entry_t), pointer :: first => null () + type(entry_t), pointer :: last => null () + end type list_t + +@ %def entry_t list_t @ Initializers: <>= generic :: init => & color_init_trivial, color_init_trivial_ghost, & color_init_array, color_init_array_ghost, & color_init_arrays, color_init_arrays_ghost procedure, private :: color_init_trivial procedure, private :: color_init_trivial_ghost procedure, private :: color_init_array procedure, private :: color_init_array_ghost procedure, private :: color_init_arrays procedure, private :: color_init_arrays_ghost @ Undefined color: array remains unallocated +<>= + pure module subroutine color_init_trivial (col) + class(color_t), intent(inout) :: col + end subroutine color_init_trivial + pure module subroutine color_init_trivial_ghost (col, ghost) + class(color_t), intent(inout) :: col + logical, intent(in) :: ghost + end subroutine color_init_trivial_ghost <>= - pure subroutine color_init_trivial (col) + pure module subroutine color_init_trivial (col) class(color_t), intent(inout) :: col col%defined = .true. col%c1 = 0 col%c2 = 0 col%ghost = .false. end subroutine color_init_trivial - pure subroutine color_init_trivial_ghost (col, ghost) + pure module subroutine color_init_trivial_ghost (col, ghost) class(color_t), intent(inout) :: col logical, intent(in) :: ghost col%defined = .true. col%c1 = 0 col%c2 = 0 col%ghost = ghost end subroutine color_init_trivial_ghost @ This defines color from an arbitrary length color array, suitable for any representation. We may have two color arrays (non-diagonal matrix elements). This cannot be elemental. The third version assigns an array of colors, using a two-dimensional array as input. +<>= + pure module subroutine color_init_array (col, c1) + class(color_t), intent(inout) :: col + integer, dimension(:), intent(in) :: c1 + end subroutine color_init_array + pure module subroutine color_init_array_ghost (col, c1, ghost) + class(color_t), intent(inout) :: col + integer, dimension(:), intent(in) :: c1 + logical, intent(in) :: ghost + end subroutine color_init_array_ghost + pure module subroutine color_init_arrays (col, c1, c2) + class(color_t), intent(inout) :: col + integer, dimension(:), intent(in) :: c1, c2 + end subroutine color_init_arrays + pure module subroutine color_init_arrays_ghost (col, c1, c2, ghost) + class(color_t), intent(inout) :: col + integer, dimension(:), intent(in) :: c1, c2 + logical, intent(in) :: ghost + end subroutine color_init_arrays_ghost <>= - pure subroutine color_init_array (col, c1) + pure module subroutine color_init_array (col, c1) class(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1 col%defined = .true. col%c1 = pack (c1, c1 /= 0, [0,0]) col%c2 = col%c1 col%ghost = .false. end subroutine color_init_array - pure subroutine color_init_array_ghost (col, c1, ghost) + pure module subroutine color_init_array_ghost (col, c1, ghost) class(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1 logical, intent(in) :: ghost call color_init_array (col, c1) col%ghost = ghost end subroutine color_init_array_ghost - pure subroutine color_init_arrays (col, c1, c2) + pure module subroutine color_init_arrays (col, c1, c2) class(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1, c2 col%defined = .true. if (size (c1) == size (c2)) then col%c1 = pack (c1, c1 /= 0, [0,0]) col%c2 = pack (c2, c2 /= 0, [0,0]) else if (size (c1) /= 0) then col%c1 = pack (c1, c1 /= 0, [0,0]) col%c2 = col%c1 else if (size (c2) /= 0) then col%c1 = pack (c2, c2 /= 0, [0,0]) col%c2 = col%c1 end if col%ghost = .false. end subroutine color_init_arrays - pure subroutine color_init_arrays_ghost (col, c1, c2, ghost) + pure module subroutine color_init_arrays_ghost (col, c1, c2, ghost) class(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1, c2 logical, intent(in) :: ghost call color_init_arrays (col, c1, c2) col%ghost = ghost end subroutine color_init_arrays_ghost @ %def color_init @ This version is restricted to singlets, triplets, antitriplets, and octets: The input contains the color and anticolor index, each of the may be zero. <>= procedure :: init_col_acl => color_init_col_acl +<>= + elemental module subroutine color_init_col_acl (col, col_in, acl_in) + class(color_t), intent(inout) :: col + integer, intent(in) :: col_in, acl_in + end subroutine color_init_col_acl <>= - elemental subroutine color_init_col_acl (col, col_in, acl_in) + elemental module subroutine color_init_col_acl (col, col_in, acl_in) class(color_t), intent(inout) :: col integer, intent(in) :: col_in, acl_in integer, dimension(0) :: null_array select case (col_in) case (0) select case (acl_in) case (0) call color_init_array (col, null_array) case default call color_init_array (col, [-acl_in]) end select case default select case (acl_in) case (0) call color_init_array (col, [col_in]) case default call color_init_array (col, [col_in, -acl_in]) end select end select end subroutine color_init_col_acl @ %def color_init_col_acl @ This version is used for the external interface. We convert a fixed-size array of colors (for each particle) to the internal form by packing only the nonzero entries. Some of these procedures produce an arry, so they can't be all type-bound. We implement them as ordinary procedures. <>= public :: color_init_from_array <>= interface color_init_from_array module procedure color_init_from_array1 module procedure color_init_from_array1g module procedure color_init_from_array2 module procedure color_init_from_array2g end interface color_init_from_array @ %def color_init_from_array +<>= + pure module subroutine color_init_from_array1 (col, c1) + type(color_t), intent(inout) :: col + integer, dimension(:), intent(in) :: c1 + end subroutine color_init_from_array1 + pure module subroutine color_init_from_array1g (col, c1, ghost) + type(color_t), intent(inout) :: col + integer, dimension(:), intent(in) :: c1 + logical, intent(in) :: ghost + end subroutine color_init_from_array1g + pure module subroutine color_init_from_array2 (col, c1) + integer, dimension(:,:), intent(in) :: c1 + type(color_t), dimension(:), intent(inout) :: col + end subroutine color_init_from_array2 + pure module subroutine color_init_from_array2g (col, c1, ghost) + integer, dimension(:,:), intent(in) :: c1 + type(color_t), dimension(:), intent(out) :: col + logical, intent(in), dimension(:) :: ghost + end subroutine color_init_from_array2g <>= - pure subroutine color_init_from_array1 (col, c1) + pure module subroutine color_init_from_array1 (col, c1) type(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1 logical, dimension(size(c1)) :: mask mask = c1 /= 0 col%defined = .true. col%c1 = pack (c1, mask, col%c1) col%c2 = col%c1 col%ghost = .false. end subroutine color_init_from_array1 - pure subroutine color_init_from_array1g (col, c1, ghost) + pure module subroutine color_init_from_array1g (col, c1, ghost) type(color_t), intent(inout) :: col integer, dimension(:), intent(in) :: c1 logical, intent(in) :: ghost call color_init_from_array1 (col, c1) col%ghost = ghost end subroutine color_init_from_array1g - pure subroutine color_init_from_array2 (col, c1) + pure module subroutine color_init_from_array2 (col, c1) integer, dimension(:,:), intent(in) :: c1 type(color_t), dimension(:), intent(inout) :: col integer :: i do i = 1, size (c1,2) call color_init_from_array1 (col(i), c1(:,i)) end do end subroutine color_init_from_array2 - pure subroutine color_init_from_array2g (col, c1, ghost) + pure module subroutine color_init_from_array2g (col, c1, ghost) integer, dimension(:,:), intent(in) :: c1 type(color_t), dimension(:), intent(out) :: col logical, intent(in), dimension(:) :: ghost call color_init_from_array2 (col, c1) col%ghost = ghost end subroutine color_init_from_array2g @ %def color_init_from_array @ Set the ghost property <>= procedure :: set_ghost => color_set_ghost +<>= + elemental module subroutine color_set_ghost (col, ghost) + class(color_t), intent(inout) :: col + logical, intent(in) :: ghost + end subroutine color_set_ghost <>= - elemental subroutine color_set_ghost (col, ghost) + elemental module subroutine color_set_ghost (col, ghost) class(color_t), intent(inout) :: col logical, intent(in) :: ghost col%ghost = ghost end subroutine color_set_ghost @ %def color_set_ghost @ Undefine the color state: <>= procedure :: undefine => color_undefine +<>= + elemental module subroutine color_undefine (col, undefine_ghost) + class(color_t), intent(inout) :: col + logical, intent(in), optional :: undefine_ghost + end subroutine color_undefine <>= - elemental subroutine color_undefine (col, undefine_ghost) + elemental module subroutine color_undefine (col, undefine_ghost) class(color_t), intent(inout) :: col logical, intent(in), optional :: undefine_ghost col%defined = .false. if (present (undefine_ghost)) then if (undefine_ghost) col%ghost = .false. else col%ghost = .false. end if end subroutine color_undefine @ %def color_undefine @ Output. As dense as possible, no linebreak. If color is undefined, no output. The separate version for a color array suggest two distinct interfaces. <>= public :: color_write <>= interface color_write module procedure color_write_single module procedure color_write_array end interface color_write <>= procedure :: write => color_write_single +<>= + module subroutine color_write_single (col, unit) + class(color_t), intent(in) :: col + integer, intent(in), optional :: unit + end subroutine color_write_single + module subroutine color_write_array (col, unit) + type(color_t), dimension(:), intent(in) :: col + integer, intent(in), optional :: unit + end subroutine color_write_array <>= - subroutine color_write_single (col, unit) + module subroutine color_write_single (col, unit) class(color_t), intent(in) :: col integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return if (col%ghost) then write (u, "(A)", advance="no") "c*" else if (col%defined) then write (u, "(A)", advance="no") "c(" if (col%c1(1) /= 0) write (u, "(I0)", advance="no") col%c1(1) if (any (col%c1 /= 0)) write (u, "(1x)", advance="no") if (col%c1(2) /= 0) write (u, "(I0)", advance="no") col%c1(2) if (.not. col%is_diagonal ()) then write (u, "(A)", advance="no") "|" if (col%c2(1) /= 0) write (u, "(I0)", advance="no") col%c2(1) if (any (col%c2 /= 0)) write (u, "(1x)", advance="no") if (col%c2(2) /= 0) write (u, "(I0)", advance="no") col%c2(2) end if write (u, "(A)", advance="no") ")" end if end subroutine color_write_single - subroutine color_write_array (col, unit) + module subroutine color_write_array (col, unit) type(color_t), dimension(:), intent(in) :: col integer, intent(in), optional :: unit integer :: u integer :: i u = given_output_unit (unit); if (u < 0) return write (u, "(A)", advance="no") "[" do i = 1, size (col) if (i > 1) write (u, "(1x)", advance="no") call color_write_single (col(i), u) end do write (u, "(A)", advance="no") "]" end subroutine color_write_array @ %def color_write @ Binary I/O. For allocatable colors, this would have to be modified. <>= procedure :: write_raw => color_write_raw procedure :: read_raw => color_read_raw +<>= + module subroutine color_write_raw (col, u) + class(color_t), intent(in) :: col + integer, intent(in) :: u + end subroutine color_write_raw + module subroutine color_read_raw (col, u, iostat) + class(color_t), intent(inout) :: col + integer, intent(in) :: u + integer, intent(out), optional :: iostat + end subroutine color_read_raw <>= - subroutine color_write_raw (col, u) + module subroutine color_write_raw (col, u) class(color_t), intent(in) :: col integer, intent(in) :: u logical :: defined defined = col%is_defined () .or. col%is_ghost () write (u) defined if (defined) then write (u) col%c1, col%c2 write (u) col%ghost end if end subroutine color_write_raw - subroutine color_read_raw (col, u, iostat) + module subroutine color_read_raw (col, u, iostat) class(color_t), intent(inout) :: col integer, intent(in) :: u integer, intent(out), optional :: iostat logical :: defined read (u, iostat=iostat) col%defined if (col%defined) then read (u, iostat=iostat) col%c1, col%c2 read (u, iostat=iostat) col%ghost end if end subroutine color_read_raw @ %def color_write_raw color_read_raw @ \subsection{Predicates} Return the definition status. A color state may be defined but trivial. <>= procedure :: is_defined => color_is_defined procedure :: is_nonzero => color_is_nonzero +<>= + elemental module function color_is_defined (col) result (defined) + logical :: defined + class(color_t), intent(in) :: col + end function color_is_defined + elemental module function color_is_nonzero (col) result (flag) + logical :: flag + class(color_t), intent(in) :: col + end function color_is_nonzero <>= - elemental function color_is_defined (col) result (defined) + elemental module function color_is_defined (col) result (defined) logical :: defined class(color_t), intent(in) :: col defined = col%defined end function color_is_defined - elemental function color_is_nonzero (col) result (flag) + elemental module function color_is_nonzero (col) result (flag) logical :: flag class(color_t), intent(in) :: col flag = col%defined & .and. .not. col%ghost & .and. any (col%c1 /= 0 .or. col%c2 /= 0) end function color_is_nonzero @ %def color_is_defined @ %def color_is_nonzero @ Diagonal color objects have only one array allocated: <>= procedure :: is_diagonal => color_is_diagonal +<>= + elemental module function color_is_diagonal (col) result (diagonal) + logical :: diagonal + class(color_t), intent(in) :: col + end function color_is_diagonal <>= - elemental function color_is_diagonal (col) result (diagonal) + elemental module function color_is_diagonal (col) result (diagonal) logical :: diagonal class(color_t), intent(in) :: col if (col%defined) then diagonal = all (col%c1 == col%c2) else diagonal = .true. end if end function color_is_diagonal @ %def color_is_diagonal @ Return the ghost flag <>= procedure :: is_ghost => color_is_ghost +<>= + elemental module function color_is_ghost (col) result (ghost) + logical :: ghost + class(color_t), intent(in) :: col + end function color_is_ghost <>= - elemental function color_is_ghost (col) result (ghost) + elemental module function color_is_ghost (col) result (ghost) logical :: ghost class(color_t), intent(in) :: col ghost = col%ghost end function color_is_ghost @ %def color_is_ghost @ The ghost parity: true if the color-ghost flag is set. Again, no TBP since this is an array. <>= pure function color_ghost_parity (col) result (parity) type(color_t), dimension(:), intent(in) :: col logical :: parity parity = mod (count (col%ghost), 2) == 1 end function color_ghost_parity @ %def color_ghost_parity @ Determine the color representation, given a color object. We allow only singlet ($1$), (anti)triplet ($\pm 3$), and octet states ($8$). A color ghost must not have color assigned, but the color type is $8$. For non-diagonal color, representations must match. If the color type is undefined, return $0$. If it is invalid or unsupported, return $-1$. Assumption: nonzero entries precede nonzero ones. <>= procedure :: get_type => color_get_type +<>= + elemental module function color_get_type (col) result (ctype) + class(color_t), intent(in) :: col + integer :: ctype + end function color_get_type <>= - elemental function color_get_type (col) result (ctype) + elemental module function color_get_type (col) result (ctype) class(color_t), intent(in) :: col integer :: ctype if (col%defined) then ctype = -1 if (col%ghost) then if (all (col%c1 == 0 .and. col%c2 == 0)) then ctype = 8 end if else if (all ((col%c1 == 0 .and. col%c2 == 0) & & .or. (col%c1 > 0 .and. col%c2 > 0) & & .or. (col%c1 < 0 .and. col%c2 < 0))) then if (all (col%c1 == 0)) then ctype = 1 else if ((col%c1(1) > 0 .and. col%c1(2) == 0)) then ctype = 3 else if ((col%c1(1) < 0 .and. col%c1(2) == 0)) then ctype = -3 else if ((col%c1(1) > 0 .and. col%c1(2) < 0) & .or.(col%c1(1) < 0 .and. col%c1(2) > 0)) then ctype = 8 end if end if end if else ctype = 0 end if end function color_get_type @ %def color_get_type @ \subsection{Accessing contents} Return the number of color indices. We assume that it is identical for both arrays. <>= procedure, private :: get_number_of_indices => color_get_number_of_indices +<>= + elemental module function color_get_number_of_indices (col) result (n) + integer :: n + class(color_t), intent(in) :: col + end function color_get_number_of_indices <>= - elemental function color_get_number_of_indices (col) result (n) + elemental module function color_get_number_of_indices (col) result (n) integer :: n class(color_t), intent(in) :: col if (col%defined .and. .not. col%ghost) then n = count (col%c1 /= 0) else n = 0 end if end function color_get_number_of_indices @ %def color_get_number_of_indices @ Return the (first) color/anticolor entry (assuming that color is diagonal). The result is a positive color index. <>= procedure :: get_col => color_get_col procedure :: get_acl => color_get_acl +<>= + elemental module function color_get_col (col) result (c) + integer :: c + class(color_t), intent(in) :: col + end function color_get_col + elemental module function color_get_acl (col) result (c) + integer :: c + class(color_t), intent(in) :: col + end function color_get_acl <>= - elemental function color_get_col (col) result (c) + elemental module function color_get_col (col) result (c) integer :: c class(color_t), intent(in) :: col integer :: i if (col%defined .and. .not. col%ghost) then do i = 1, size (col%c1) if (col%c1(i) > 0) then c = col%c1(i) return end if end do end if c = 0 end function color_get_col - elemental function color_get_acl (col) result (c) + elemental module function color_get_acl (col) result (c) integer :: c class(color_t), intent(in) :: col integer :: i if (col%defined .and. .not. col%ghost) then do i = 1, size (col%c1) if (col%c1(i) < 0) then c = - col%c1(i) return end if end do end if c = 0 end function color_get_acl @ %def color_get_col color_get_acl @ Return the color index with highest absolute value <>= public :: color_get_max_value <>= interface color_get_max_value module procedure color_get_max_value0 module procedure color_get_max_value1 module procedure color_get_max_value2 end interface color_get_max_value +<>= + elemental module function color_get_max_value0 (col) result (cmax) + integer :: cmax + type(color_t), intent(in) :: col + end function color_get_max_value0 + pure module function color_get_max_value1 (col) result (cmax) + integer :: cmax + type(color_t), dimension(:), intent(in) :: col + end function color_get_max_value1 + pure module function color_get_max_value2 (col) result (cmax) + integer :: cmax + type(color_t), dimension(:,:), intent(in) :: col + end function color_get_max_value2 <>= - elemental function color_get_max_value0 (col) result (cmax) + elemental module function color_get_max_value0 (col) result (cmax) integer :: cmax type(color_t), intent(in) :: col if (col%defined .and. .not. col%ghost) then cmax = maxval (abs (col%c1)) else cmax = 0 end if end function color_get_max_value0 - pure function color_get_max_value1 (col) result (cmax) + pure module function color_get_max_value1 (col) result (cmax) integer :: cmax type(color_t), dimension(:), intent(in) :: col cmax = maxval (color_get_max_value0 (col)) end function color_get_max_value1 - pure function color_get_max_value2 (col) result (cmax) + pure module function color_get_max_value2 (col) result (cmax) integer :: cmax type(color_t), dimension(:,:), intent(in) :: col integer, dimension(size(col, 2)) :: cm integer :: i forall (i = 1:size(col, 2)) cm(i) = color_get_max_value1 (col(:,i)) end forall cmax = maxval (cm) end function color_get_max_value2 @ %def color_get_max_value @ \subsection{Comparisons} Similar to helicities, colors match if they are equal, or if either one is undefined. <>= generic :: operator(.match.) => color_match generic :: operator(==) => color_eq generic :: operator(/=) => color_neq procedure, private :: color_match procedure, private :: color_eq procedure, private :: color_neq @ %def .match. == /= +<>= + elemental module function color_match (col1, col2) result (eq) + logical :: eq + class(color_t), intent(in) :: col1, col2 + end function color_match + elemental module function color_eq (col1, col2) result (eq) + logical :: eq + class(color_t), intent(in) :: col1, col2 + end function color_eq <>= - elemental function color_match (col1, col2) result (eq) + elemental module function color_match (col1, col2) result (eq) logical :: eq class(color_t), intent(in) :: col1, col2 if (col1%defined .and. col2%defined) then if (col1%ghost .and. col2%ghost) then eq = .true. else if (.not. col1%ghost .and. .not. col2%ghost) then eq = all (col1%c1 == col2%c1) .and. all (col1%c2 == col2%c2) else eq = .false. end if else eq = .true. end if end function color_match - elemental function color_eq (col1, col2) result (eq) + elemental module function color_eq (col1, col2) result (eq) logical :: eq class(color_t), intent(in) :: col1, col2 if (col1%defined .and. col2%defined) then if (col1%ghost .and. col2%ghost) then eq = .true. else if (.not. col1%ghost .and. .not. col2%ghost) then eq = all (col1%c1 == col2%c1) .and. all (col1%c2 == col2%c2) else eq = .false. end if else if (.not. col1%defined & .and. .not. col2%defined) then eq = col1%ghost .eqv. col2%ghost else eq = .false. end if end function color_eq @ %def color_eq +<>= + elemental module function color_neq (col1, col2) result (neq) + logical :: neq + class(color_t), intent(in) :: col1, col2 + end function color_neq <>= - elemental function color_neq (col1, col2) result (neq) + elemental module function color_neq (col1, col2) result (neq) logical :: neq class(color_t), intent(in) :: col1, col2 if (col1%defined .and. col2%defined) then if (col1%ghost .and. col2%ghost) then neq = .false. else if (.not. col1%ghost .and. .not. col2%ghost) then neq = any (col1%c1 /= col2%c1) .or. any (col1%c2 /= col2%c2) else neq = .true. end if else if (.not. col1%defined & .and. .not. col2%defined) then neq = col1%ghost .neqv. col2%ghost else neq = .true. end if end function color_neq @ %def color_neq @ \subsection{Tools} Shift color indices by a common offset. <>= procedure :: add_offset => color_add_offset +<>= + elemental module subroutine color_add_offset (col, offset) + class(color_t), intent(inout) :: col + integer, intent(in) :: offset + end subroutine color_add_offset <>= - elemental subroutine color_add_offset (col, offset) + elemental module subroutine color_add_offset (col, offset) class(color_t), intent(inout) :: col integer, intent(in) :: offset if (col%defined .and. .not. col%ghost) then where (col%c1 /= 0) col%c1 = col%c1 + sign (offset, col%c1) where (col%c2 /= 0) col%c2 = col%c2 + sign (offset, col%c2) end if end subroutine color_add_offset @ %def color_add_offset @ Reassign color indices for an array of colored particle in canonical order. The allocated size of the color map is such that two colors per particle can be accomodated. The algorithm works directly on the contents of the color objects, it <>= public :: color_canonicalize +<>= + module subroutine color_canonicalize (col) + type(color_t), dimension(:), intent(inout) :: col + end subroutine color_canonicalize <>= - subroutine color_canonicalize (col) + module subroutine color_canonicalize (col) type(color_t), dimension(:), intent(inout) :: col integer, dimension(2*size(col)) :: map integer :: n_col, i, j, k n_col = 0 do i = 1, size (col) if (col(i)%defined .and. .not. col(i)%ghost) then do j = 1, size (col(i)%c1) if (col(i)%c1(j) /= 0) then k = find (abs (col(i)%c1(j)), map(:n_col)) if (k == 0) then n_col = n_col + 1 map(n_col) = abs (col(i)%c1(j)) k = n_col end if col(i)%c1(j) = sign (k, col(i)%c1(j)) end if if (col(i)%c2(j) /= 0) then k = find (abs (col(i)%c2(j)), map(:n_col)) if (k == 0) then n_col = n_col + 1 map(n_col) = abs (col(i)%c2(j)) k = n_col end if col(i)%c2(j) = sign (k, col(i)%c2(j)) end if end do end if end do contains function find (c, array) result (k) integer :: k integer, intent(in) :: c integer, dimension(:), intent(in) :: array integer :: i k = 0 do i = 1, size (array) if (c == array (i)) then k = i return end if end do end function find end subroutine color_canonicalize @ %def color_canonicalize @ Return an array of different color indices from an array of colors. The last argument is a pseudo-color array, where the color entries correspond to the position of the corresponding index entry in the index array. The colors are assumed to be diagonal. The algorithm works directly on the contents of the color objects. <>= subroutine extract_color_line_indices (col, c_index, col_pos) type(color_t), dimension(:), intent(in) :: col integer, dimension(:), intent(out), allocatable :: c_index type(color_t), dimension(size(col)), intent(out) :: col_pos integer, dimension(:), allocatable :: c_tmp integer :: i, j, k, n, c allocate (c_tmp (sum (col%get_number_of_indices ())), source=0) n = 0 SCAN1: do i = 1, size (col) if (col(i)%defined .and. .not. col(i)%ghost) then SCAN2: do j = 1, 2 c = abs (col(i)%c1(j)) if (c /= 0) then do k = 1, n if (c_tmp(k) == c) then col_pos(i)%c1(j) = k cycle SCAN2 end if end do n = n + 1 c_tmp(n) = c col_pos(i)%c1(j) = n end if end do SCAN2 end if end do SCAN1 allocate (c_index (n)) c_index = c_tmp(1:n) end subroutine extract_color_line_indices @ %def extract_color_line_indices @ Given a color array, pairwise contract the color lines in all possible ways and return the resulting array of arrays. The input color array must be diagonal, and each color should occur exactly twice, once as color and once as anticolor. Gluon entries with equal color and anticolor are explicitly excluded. This algorithm is generic, but for long arrays it is neither efficient, nor does it avoid duplicates. It is intended for small arrays, in particular for the state matrix of a structure-function pair. The algorithm works directly on the contents of the color objects, it thus depends on the implementation. <>= public :: color_array_make_contractions +<>= + module subroutine color_array_make_contractions (col_in, col_out) + type(color_t), dimension(:), intent(in) :: col_in + type(color_t), dimension(:,:), intent(out), allocatable :: col_out + end subroutine color_array_make_contractions <>= - subroutine color_array_make_contractions (col_in, col_out) + module subroutine color_array_make_contractions (col_in, col_out) type(color_t), dimension(:), intent(in) :: col_in type(color_t), dimension(:,:), intent(out), allocatable :: col_out - type :: entry_t - integer, dimension(:), allocatable :: map - type(color_t), dimension(:), allocatable :: col - type(entry_t), pointer :: next => null () - logical :: nlo_event = .false. - end type entry_t - type :: list_t - integer :: n = 0 - type(entry_t), pointer :: first => null () - type(entry_t), pointer :: last => null () - end type list_t type(list_t) :: list type(entry_t), pointer :: entry integer, dimension(:), allocatable :: c_index type(color_t), dimension(size(col_in)) :: col_pos integer :: n_prt, n_c_index integer, dimension(:), allocatable :: map integer :: i, j, c n_prt = size (col_in) call extract_color_line_indices (col_in, c_index, col_pos) n_c_index = size (c_index) allocate (map (n_c_index)) map = 0 call list_append_if_valid (list, map) entry => list%first do while (associated (entry)) do i = 1, n_c_index if (entry%map(i) == 0) then c = c_index(i) do j = i + 1, n_c_index if (entry%map(j) == 0) then map = entry%map map(i) = c map(j) = c call list_append_if_valid (list, map) end if end do end if end do entry => entry%next end do call list_to_array (list, col_out) contains subroutine list_append_if_valid (list, map) type(list_t), intent(inout) :: list integer, dimension(:), intent(in) :: map type(entry_t), pointer :: entry integer :: i, j, c, p entry => list%first do while (associated (entry)) if (all (map == entry%map)) return entry => entry%next end do allocate (entry) allocate (entry%map (n_c_index)) entry%map = map allocate (entry%col (n_prt)) do i = 1, n_prt do j = 1, 2 c = col_in(i)%c1(j) if (c /= 0) then p = col_pos(i)%c1(j) entry%col(i)%defined = .true. if (map(p) /= 0) then entry%col(i)%c1(j) = sign (map(p), c) else entry%col(i)%c1(j) = c endif entry%col(i)%c2(j) = entry%col(i)%c1(j) end if end do if (any (entry%col(i)%c1 /= 0) .and. & entry%col(i)%c1(1) == - entry%col(i)%c1(2)) return end do if (associated (list%last)) then list%last%next => entry else list%first => entry end if list%last => entry list%n = list%n + 1 end subroutine list_append_if_valid subroutine list_to_array (list, col) type(list_t), intent(inout) :: list type(color_t), dimension(:,:), intent(out), allocatable :: col type(entry_t), pointer :: entry integer :: i allocate (col (n_prt, list%n - 1)) do i = 0, list%n - 1 entry => list%first list%first => list%first%next if (i /= 0) col(:,i) = entry%col deallocate (entry) end do list%last => null () end subroutine list_to_array end subroutine color_array_make_contractions @ %def color_array_make_contractions @ Invert the color index, switching from particle to antiparticle. For gluons, we have to swap the order of color entries. <>= procedure :: invert => color_invert +<>= + elemental module subroutine color_invert (col) + class(color_t), intent(inout) :: col + end subroutine color_invert <>= - elemental subroutine color_invert (col) + elemental module subroutine color_invert (col) class(color_t), intent(inout) :: col if (col%defined .and. .not. col%ghost) then col%c1 = - col%c1 col%c2 = - col%c2 if (col%c1(1) < 0 .and. col%c1(2) > 0) then col%c1 = col%c1(2:1:-1) col%c2 = col%c2(2:1:-1) end if end if end subroutine color_invert @ %def color_invert @ Make a color map for two matching color arrays. The result is an array of integer pairs. <>= public :: make_color_map <>= interface make_color_map module procedure color_make_color_map end interface make_color_map +<>= + module subroutine color_make_color_map (map, col1, col2) + integer, dimension(:,:), intent(out), allocatable :: map + type(color_t), dimension(:), intent(in) :: col1, col2 + end subroutine color_make_color_map <>= - subroutine color_make_color_map (map, col1, col2) + module subroutine color_make_color_map (map, col1, col2) integer, dimension(:,:), intent(out), allocatable :: map type(color_t), dimension(:), intent(in) :: col1, col2 integer, dimension(:,:), allocatable :: map1 integer :: i, j, k allocate (map1 (2, 2 * sum (col1%get_number_of_indices ()))) k = 0 do i = 1, size (col1) if (col1(i)%defined .and. .not. col1(i)%ghost) then do j = 1, size (col1(i)%c1) if (col1(i)%c1(j) /= 0 & .and. all (map1(1,:k) /= abs (col1(i)%c1(j)))) then k = k + 1 map1(1,k) = abs (col1(i)%c1(j)) map1(2,k) = abs (col2(i)%c1(j)) end if if (col1(i)%c2(j) /= 0 & .and. all (map1(1,:k) /= abs (col1(i)%c2(j)))) then k = k + 1 map1(1,k) = abs (col1(i)%c2(j)) map1(2,k) = abs (col2(i)%c2(j)) end if end do end if end do allocate (map (2, k)) map(:,:) = map1(:,:k) end subroutine color_make_color_map @ %def make_color_map @ Translate colors which have a match in the translation table (an array of integer pairs). Color that do not match an entry are simply transferred; this is done by first transferring all components, then modifiying entries where appropriate. <>= public :: color_translate <>= interface color_translate module procedure color_translate0 module procedure color_translate0_offset module procedure color_translate1 end interface color_translate +<>= + module subroutine color_translate0 (col, map) + type(color_t), intent(inout) :: col + integer, dimension(:,:), intent(in) :: map + end subroutine color_translate0 + module subroutine color_translate0_offset (col, map, offset) + type(color_t), intent(inout) :: col + integer, dimension(:,:), intent(in) :: map + integer, intent(in) :: offset + end subroutine color_translate0_offset + module subroutine color_translate1 (col, map, offset) + type(color_t), dimension(:), intent(inout) :: col + integer, dimension(:,:), intent(in) :: map + integer, intent(in), optional :: offset + end subroutine color_translate1 <>= - subroutine color_translate0 (col, map) + module subroutine color_translate0 (col, map) type(color_t), intent(inout) :: col integer, dimension(:,:), intent(in) :: map type(color_t) :: col_tmp integer :: i if (col%defined .and. .not. col%ghost) then col_tmp = col do i = 1, size (map,2) where (abs (col%c1) == map(1,i)) col_tmp%c1 = sign (map(2,i), col%c1) end where where (abs (col%c2) == map(1,i)) col_tmp%c2 = sign (map(2,i), col%c2) end where end do col = col_tmp end if end subroutine color_translate0 - subroutine color_translate0_offset (col, map, offset) + module subroutine color_translate0_offset (col, map, offset) type(color_t), intent(inout) :: col integer, dimension(:,:), intent(in) :: map integer, intent(in) :: offset logical, dimension(size(col%c1)) :: mask1, mask2 type(color_t) :: col_tmp integer :: i if (col%defined .and. .not. col%ghost) then col_tmp = col mask1 = col%c1 /= 0 mask2 = col%c2 /= 0 do i = 1, size (map,2) where (abs (col%c1) == map(1,i)) col_tmp%c1 = sign (map(2,i), col%c1) mask1 = .false. end where where (abs (col%c2) == map(1,i)) col_tmp%c2 = sign (map(2,i), col%c2) mask2 = .false. end where end do col = col_tmp where (mask1) col%c1 = sign (abs (col%c1) + offset, col%c1) where (mask2) col%c2 = sign (abs (col%c2) + offset, col%c2) end if end subroutine color_translate0_offset - subroutine color_translate1 (col, map, offset) + module subroutine color_translate1 (col, map, offset) type(color_t), dimension(:), intent(inout) :: col integer, dimension(:,:), intent(in) :: map integer, intent(in), optional :: offset integer :: i if (present (offset)) then do i = 1, size (col) call color_translate0_offset (col(i), map, offset) end do else do i = 1, size (col) call color_translate0 (col(i), map) end do end if end subroutine color_translate1 @ %def color_translate @ Merge two color objects by taking the first entry from the first and the first entry from the second argument. Makes sense only if the input colors are defined (and diagonal). If either one is undefined, transfer the defined one. <>= generic :: operator(.merge.) => merge_colors procedure, private :: merge_colors @ %def .merge. +<>= + elemental module function merge_colors (col1, col2) result (col) + type(color_t) :: col + class(color_t), intent(in) :: col1, col2 + end function merge_colors <>= - elemental function merge_colors (col1, col2) result (col) + elemental module function merge_colors (col1, col2) result (col) type(color_t) :: col class(color_t), intent(in) :: col1, col2 if (color_is_defined (col1) .and. color_is_defined (col2)) then if (color_is_ghost (col1) .and. color_is_ghost (col2)) then call color_init_trivial_ghost (col, .true.) else call color_init_arrays (col, col1%c1, col2%c1) end if else if (color_is_defined (col1)) then call color_init_array (col, col1%c1) else if (color_is_defined (col2)) then call color_init_array (col, col2%c1) end if end function merge_colors @ %def merge_colors @ Merge up to two (diagonal!) color objects. The result inherits the unmatched color lines of the input colors. If one of the input colors is undefined, the output is undefined as well. It must be in a supported color representation. A color-ghost object should not actually occur in real-particle events, but for completeness we define its behavior. For simplicity, it is identified as a color-octet with zero color/anticolor. It can only couple to a triplet or antitriplet. A fusion of triplet with matching antitriplet will yield a singlet, not a ghost, however. If the fusion fails, the result is undefined. <>= generic :: operator (.fuse.) => color_fusion procedure, private :: color_fusion +<>= + module function color_fusion (col1, col2) result (col) + class(color_t), intent(in) :: col1, col2 + type(color_t) :: col + end function color_fusion <>= - function color_fusion (col1, col2) result (col) + module function color_fusion (col1, col2) result (col) class(color_t), intent(in) :: col1, col2 type(color_t) :: col integer, dimension(2) :: ctype if (col1%is_defined () .and. col2%is_defined ()) then if (col1%is_diagonal () .and. col2%is_diagonal ()) then ctype = [col1%get_type (), col2%get_type ()] select case (ctype(1)) case (1) select case (ctype(2)) case (1,3,-3,8) col = col2 end select case (3) select case (ctype(2)) case (1) col = col1 case (-3) call t_a (col1%get_col (), col2%get_acl ()) case (8) call t_o (col1%get_col (), col2%get_acl (), & & col2%get_col ()) end select case (-3) select case (ctype(2)) case (1) col = col1 case (3) call t_a (col2%get_col (), col1%get_acl ()) case (8) call a_o (col1%get_acl (), col2%get_col (), & & col2%get_acl ()) end select case (8) select case (ctype(2)) case (1) col = col1 case (3) call t_o (col2%get_col (), col1%get_acl (), & & col1%get_col ()) case (-3) call a_o (col2%get_acl (), col1%get_col (), & & col1%get_acl ()) case (8) call o_o (col1%get_col (), col1%get_acl (), & & col2%get_col (), col2%get_acl ()) end select end select end if end if contains subroutine t_a (c1, c2) integer, intent(in) :: c1, c2 if (c1 == c2) then call col%init_col_acl (0, 0) else call col%init_col_acl (c1, c2) end if end subroutine t_a subroutine t_o (c1, c2, c3) integer, intent(in) :: c1, c2, c3 if (c1 == c2) then call col%init_col_acl (c3, 0) else if (c2 == 0 .and. c3 == 0) then call col%init_col_acl (c1, 0) end if end subroutine t_o subroutine a_o (c1, c2, c3) integer, intent(in) :: c1, c2, c3 if (c1 == c2) then call col%init_col_acl (0, c3) else if (c2 == 0 .and. c3 == 0) then call col%init_col_acl (0, c1) end if end subroutine a_o subroutine o_o (c1, c2, c3, c4) integer, intent(in) :: c1, c2, c3, c4 if (all ([c1,c2,c3,c4] /= 0)) then if (c2 == c3 .and. c4 == c1) then call col%init_col_acl (0, 0) else if (c2 == c3) then call col%init_col_acl (c1, c4) else if (c4 == c1) then call col%init_col_acl (c3, c2) end if end if end subroutine o_o end function color_fusion @ %def color_fusion @ Compute the color factor, given two interfering color arrays. <>= public :: compute_color_factor +<>= + module function compute_color_factor (col1, col2, nc) result (factor) + real(default) :: factor + type(color_t), dimension(:), intent(in) :: col1, col2 + integer, intent(in), optional :: nc + end function compute_color_factor <>= - function compute_color_factor (col1, col2, nc) result (factor) + module function compute_color_factor (col1, col2, nc) result (factor) real(default) :: factor type(color_t), dimension(:), intent(in) :: col1, col2 integer, intent(in), optional :: nc type(color_t), dimension(size(col1)) :: col integer :: ncol, nloops, nghost ncol = 3; if (present (nc)) ncol = nc col = col1 .merge. col2 nloops = count_color_loops (col) nghost = count (col%is_ghost ()) factor = real (ncol, default) ** (nloops - nghost) if (color_ghost_parity (col)) factor = - factor end function compute_color_factor @ %def compute_color_factor @ We have a pair of color index arrays which corresponds to a squared matrix element. We want to determine the number of color loops in this square matrix element. So we first copy the colors (stored in a single color array with a pair of color lists in each entry) to a temporary where the color indices are shifted by some offset. We then recursively follow each loop, starting at the first color that has the offset, resetting the first color index to the loop index and each further index to zero as we go. We check that (a) each color index occurs twice within the left (right) color array, (b) the loops are closed, so we always come back to a line which has the loop index. In order for the algorithm to work we have to conjugate the colors of initial state particles (one for decays, two for scatterings) into their corresponding anticolors of outgoing particles. <>= public :: count_color_loops +<>= + module function count_color_loops (col) result (count) + integer :: count + type(color_t), dimension(:), intent(in) :: col + end function count_color_loops <>= - function count_color_loops (col) result (count) + module function count_color_loops (col) result (count) integer :: count type(color_t), dimension(:), intent(in) :: col type(color_t), dimension(size(col)) :: cc integer :: i, n, offset cc = col n = size (cc) offset = n call color_add_offset (cc, offset) count = 0 SCAN_LOOPS: do do i = 1, n if (color_is_nonzero (cc(i))) then if (any (cc(i)%c1 > offset)) then count = count + 1 call follow_line1 (pick_new_line (cc(i)%c1, count, 1)) cycle SCAN_LOOPS end if end if end do exit SCAN_LOOPS end do SCAN_LOOPS contains function pick_new_line (c, reset_val, sgn) result (line) integer :: line integer, dimension(:), intent(inout) :: c integer, intent(in) :: reset_val integer, intent(in) :: sgn integer :: i if (any (c == count)) then line = count else do i = 1, size (c) if (sign (1, c(i)) == sgn .and. abs (c(i)) > offset) then line = c(i) c(i) = reset_val return end if end do call color_mismatch end if end function pick_new_line subroutine reset_line (c, line) integer, dimension(:), intent(inout) :: c integer, intent(in) :: line integer :: i do i = 1, size (c) if (c(i) == line) then c(i) = 0 return end if end do end subroutine reset_line recursive subroutine follow_line1 (line) integer, intent(in) :: line integer :: i if (line == count) return do i = 1, n if (any (cc(i)%c1 == -line)) then call reset_line (cc(i)%c1, -line) call follow_line2 (pick_new_line (cc(i)%c2, 0, sign (1, -line))) return end if end do call color_mismatch () end subroutine follow_line1 recursive subroutine follow_line2 (line) integer, intent(in) :: line integer :: i do i = 1, n if (any (cc(i)%c2 == -line)) then call reset_line (cc(i)%c2, -line) call follow_line1 (pick_new_line (cc(i)%c1, 0, sign (1, -line))) return end if end do call color_mismatch () end subroutine follow_line2 subroutine color_mismatch () call color_write (col) print * call msg_fatal ("Color flow mismatch: Non-closed color lines appear during ", & [var_str ("the evaluation of color correlations. This can happen if there "), & var_str ("are different color structures in the initial or final state of "), & var_str ("the process definition. If so, please use separate processes for "), & var_str ("the different initial / final states. In a future WHIZARD version "), & var_str ("this will be fixed.")]) end subroutine color_mismatch end function count_color_loops @ %def count_color_loops @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[colors_ut.f90]]>>= <> module colors_ut use unit_tests use colors_uti <> <> contains <> end module colors_ut @ %def colors_ut @ <<[[colors_uti.f90]]>>= <> module colors_uti use colors <> <> contains <> end module colors_uti @ %def colors_ut @ API: driver for the unit tests below. <>= public :: color_test <>= subroutine color_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine color_test @ %def color_test @ This is a color counting test. <>= call test (color_1, "color_1", & "check color counting", & u, results) <>= public :: color_1 <>= subroutine color_1 (u) integer, intent(in) :: u type(color_t), dimension(4) :: col1, col2, col type(color_t), dimension(:), allocatable :: col3 type(color_t), dimension(:,:), allocatable :: col_array integer :: count, i call col1%init_col_acl ([1, 0, 2, 3], [0, 1, 3, 2]) col2 = col1 call color_write (col1, u) write (u, "(A)") call color_write (col2, u) write (u, "(A)") col = col1 .merge. col2 call color_write (col, u) write (u, "(A)") count = count_color_loops (col) write (u, "(A,I1)") "Number of color loops (3): ", count call col2%init_col_acl ([1, 0, 2, 3], [0, 2, 3, 1]) call color_write (col1, u) write (u, "(A)") call color_write (col2, u) write (u, "(A)") col = col1 .merge. col2 call color_write (col, u) write (u, "(A)") count = count_color_loops (col) write (u, "(A,I1)") "Number of color loops (2): ", count write (u, "(A)") allocate (col3 (4)) call color_init_from_array (col3, & reshape ([1, 0, 0, -1, 2, -3, 3, -2], & [2, 4])) call color_write (col3, u) write (u, "(A)") call color_array_make_contractions (col3, col_array) write (u, "(A)") "Contractions:" do i = 1, size (col_array, 2) call color_write (col_array(:,i), u) write (u, "(A)") end do deallocate (col3) write (u, "(A)") allocate (col3 (6)) call color_init_from_array (col3, & reshape ([1, -2, 3, 0, 0, -1, 2, -4, -3, 0, 4, 0], & [2, 6])) call color_write (col3, u) write (u, "(A)") call color_array_make_contractions (col3, col_array) write (u, "(A)") "Contractions:" do i = 1, size (col_array, 2) call color_write (col_array(:,i), u) write (u, "(A)") end do end subroutine color_1 @ %def color_1 @ A color fusion test. <>= call test (color_2, "color_2", & "color fusion", & u, results) <>= public :: color_2 <>= subroutine color_2 (u) integer, intent(in) :: u type(color_t) :: s1, t1, t2, a1, a2, o1, o2, o3, o4, g1 write (u, "(A)") "* Test output: color_2" write (u, "(A)") "* Purpose: test all combinations for color-object fusion" write (u, "(A)") call s1%init_col_acl (0,0) call t1%init_col_acl (1,0) call t2%init_col_acl (2,0) call a1%init_col_acl (0,1) call a2%init_col_acl (0,2) call o1%init_col_acl (1,2) call o2%init_col_acl (1,3) call o3%init_col_acl (2,3) call o4%init_col_acl (2,1) call g1%init (ghost=.true.) call wrt ("s1", s1) call wrt ("t1", t1) call wrt ("t2", t2) call wrt ("a1", a1) call wrt ("a2", a2) call wrt ("o1", o1) call wrt ("o2", o2) call wrt ("o3", o3) call wrt ("o4", o4) call wrt ("g1", g1) write (u, *) call wrt ("s1 * s1", s1 .fuse. s1) write (u, *) call wrt ("s1 * t1", s1 .fuse. t1) call wrt ("s1 * a1", s1 .fuse. a1) call wrt ("s1 * o1", s1 .fuse. o1) write (u, *) call wrt ("t1 * s1", t1 .fuse. s1) call wrt ("a1 * s1", a1 .fuse. s1) call wrt ("o1 * s1", o1 .fuse. s1) write (u, *) call wrt ("t1 * t1", t1 .fuse. t1) write (u, *) call wrt ("t1 * t2", t1 .fuse. t2) call wrt ("t1 * a1", t1 .fuse. a1) call wrt ("t1 * a2", t1 .fuse. a2) call wrt ("t1 * o1", t1 .fuse. o1) call wrt ("t2 * o1", t2 .fuse. o1) write (u, *) call wrt ("t2 * t1", t2 .fuse. t1) call wrt ("a1 * t1", a1 .fuse. t1) call wrt ("a2 * t1", a2 .fuse. t1) call wrt ("o1 * t1", o1 .fuse. t1) call wrt ("o1 * t2", o1 .fuse. t2) write (u, *) call wrt ("a1 * a1", a1 .fuse. a1) write (u, *) call wrt ("a1 * a2", a1 .fuse. a2) call wrt ("a1 * o1", a1 .fuse. o1) call wrt ("a2 * o2", a2 .fuse. o2) write (u, *) call wrt ("a2 * a1", a2 .fuse. a1) call wrt ("o1 * a1", o1 .fuse. a1) call wrt ("o2 * a2", o2 .fuse. a2) write (u, *) call wrt ("o1 * o1", o1 .fuse. o1) write (u, *) call wrt ("o1 * o2", o1 .fuse. o2) call wrt ("o1 * o3", o1 .fuse. o3) call wrt ("o1 * o4", o1 .fuse. o4) write (u, *) call wrt ("o2 * o1", o2 .fuse. o1) call wrt ("o3 * o1", o3 .fuse. o1) call wrt ("o4 * o1", o4 .fuse. o1) write (u, *) call wrt ("g1 * g1", g1 .fuse. g1) write (u, *) call wrt ("g1 * s1", g1 .fuse. s1) call wrt ("g1 * t1", g1 .fuse. t1) call wrt ("g1 * a1", g1 .fuse. a1) call wrt ("g1 * o1", g1 .fuse. o1) write (u, *) call wrt ("s1 * g1", s1 .fuse. g1) call wrt ("t1 * g1", t1 .fuse. g1) call wrt ("a1 * g1", a1 .fuse. g1) call wrt ("o1 * g1", o1 .fuse. g1) write (u, "(A)") write (u, "(A)") "* Test output end: color_2" contains subroutine wrt (s, col) character(*), intent(in) :: s class(color_t), intent(in) :: col write (u, "(A,1x,'=',1x)", advance="no") s call col%write (u) write (u, *) end subroutine wrt end subroutine color_2 @ %def color_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{The Madgraph color model} This section describes the method for matrix element and color flow calculation within Madgraph. For each Feynman diagram, the colorless amplitude for a specified helicity and momentum configuration (in- and out- combined) is computed: \begin{equation} A_d(p,h) \end{equation} Inserting color, the squared matrix element for definite helicity and momentum is \begin{equation} M^2(p,h) = \sum_{dd'} A_{d}(p,h)\,C_{dd'} A_{d'}^*(p,h) \end{equation} where $C_{dd'}$ describes the color interference of the two diagrams $A_d$ and $A_d'$, which is independent of momentum and helicity and can be calculated for each Feynman diagram pair by reducing it to the corresponding color graph. Obviously, one could combine all diagrams with identical color structure, such that the index $d$ runs only over different color graphs. For colorless diagrams all elements of $C_{dd'}$ are equal to unity. The hermitian matrix $C_{dd'}$ is diagonalized once and for all, such that it can be written in the form \begin{equation} C_{dd'} = \sum_\lambda c_d^\lambda \lambda\, c_d^\lambda{}^*, \end{equation} where the eigenvectors $c_d$ are normalized, \begin{equation} \sum_d |c_d^\lambda|^2 = 1, \end{equation} and the $\lambda$ values are the corresponding eigenvalues. In the colorless case, this means $c_d = 1/\sqrt{N_d}$ for all diagrams ($N_d=$ number of diagrams), and $\lambda=N_d$ is the only nonzero eigenvalue. Consequently, the squared matrix element for definite helicity and momentum can also be written as \begin{equation} M^2(p,h) = \sum_\lambda A_\lambda(p,h)\, \lambda\, A_\lambda(p,h)^* \end{equation} with \begin{equation} A_\lambda(p,h) = \sum_d c_d^\lambda A_d(p,h). \end{equation} For generic spin density matrices, this is easily generalized to \begin{equation} M^2(p,h,h') = \sum_\lambda A_\lambda(p,h)\, \lambda\, A_\lambda(p,h')^* \end{equation} To determine the color flow probabilities of a given momentum-helicity configuration, the color flow amplitudes are calculated as \begin{equation} a_f(p,h) = \sum_d \beta^f_d A_d(p,h), \end{equation} where the coefficients $\beta^f_d$ describe the amplitude for a given Feynman diagram (or color graph) $d$ to correspond to a definite color flow~$f$. They are computed from $C_{dd'}$ by transforming this matrix into the color flow basis and neglecting all off-diagonal elements. Again, these coefficients do not depend on momentum or helicity and can therefore be calculated in advance. This gives the color flow transition matrix \begin{equation} F^f(p,h,h') = a_f(p,h)\, a^*_f(p,h') \end{equation} which is assumed diagonal in color flow space and is separate from the color-summed transition matrix $M^2$. They are, however, equivalent (up to a factor) to leading order in $1/N_c$, and using the color flow transition matrix is appropriate for matching to hadronization. Note that the color flow transition matrix is not normalized at this stage. To make use of it, we have to fold it with the in-state density matrix to get a pseudo density matrix \begin{equation} \hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out}) = \sum_{h_{\rm in} h'_{\rm in}} F^f(p,h,h')\, \rho_{\rm in}(p,h_{\rm in},h'_{\rm in}) \end{equation} which gets a meaning only after contracted with projections on the outgoing helicity states $k_{\rm out}$, given as linear combinations of helicity states with the unitary coefficient matrix $c(k_{\rm out}, h_{\rm out})$. Then the probability of finding color flow $f$ when the helicity state $k_{\rm out}$ is measured is given by \begin{equation} P^f(p, k_{\rm out}) = Q^f(p, k_{\rm out}) / \sum_f Q^f(p, k_{\rm out}) \end{equation} where \begin{equation} Q^f(p, k_{\rm out}) = \sum_{h_{\rm out} h'_{\rm out}} c(k_{\rm out}, h_{\rm out})\, \hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out})\, c^*(k_{\rm out}, h'_{\rm out}) \end{equation} However, if we can assume that the out-state helicity basis is the canonical one, we can throw away the off diagonal elements in the color flow density matrix and normalize the ones on the diagonal to obtain \begin{equation} P^f(p, h_{\rm out}) = \hat\rho_{\rm out}^f(p,h_{\rm out},h_{\rm out}) / \sum_f \hat\rho_{\rm out}^f(p,h_{\rm out},h_{\rm out}) \end{equation} Finally, the color-summed out-state density matrix is computed by the scattering formula \begin{align} {\rho_{\rm out}(p,h_{\rm out},h'_{\rm out})} &= \sum_{h_{\rm in} h'_{\rm in}} M^2(p,h,h')\, \rho_{\rm in}(p,h_{\rm in},h'_{\rm in}) \\ &= \sum_{h_{\rm in} h'_{\rm in} \lambda} A_\lambda(p,h)\, \lambda\, A_\lambda(p,h')^* \rho_{\rm in}(p,h_{\rm in},h'_{\rm in}), \end{align} The trace of $\rho_{\rm out}$ is the squared matrix element, summed over all internal degrees of freedom. To get the squared matrix element for a definite helicity $k_{\rm out}$ and color flow $f$, one has to project the density matrix onto the given helicity state and multiply with $P^f(p, k_{\rm out})$. For diagonal helicities the out-state density reduces to \begin{equation} \rho_{\rm out}(p,h_{\rm out}) = \sum_{h_{\rm in}\lambda} \lambda|A_\lambda(p,h)|^2 \rho_{\rm in}(p,h_{\rm in}). \end{equation} Since no basis transformation is involved, we can use the normalized color flow probability $P^f(p, h_{\rm out})$ and express the result as \begin{align} \rho_{\rm out}^f(p,h_{\rm out}) &= \rho_{\rm out}(p,h_{\rm out})\,P^f(p, h_{\rm out}) \\ &= \sum_{h_{\rm in}\lambda} \frac{|a^f(p,h)|^2}{\sum_f|a^f(p,h)|^2} \lambda|A_\lambda(p,h)|^2 \rho_{\rm in}(p,h_{\rm in}). \end{align} From these considerations, the following calculation strategy can be derived: \begin{itemize} \item Before the first event is generated, the color interference matrix $C_{dd'}$ is computed and diagonalized, so the eigenvectors $c^\lambda_d$, eigenvalues $\lambda$ and color flow coefficients $\beta^f_d$ are obtained. In practice, these calculations are done when the matrix element code is generated, and the results are hardcoded in the matrix element subroutine as [[DATA]] statements. \item For each event, one loops over helicities once and stores the matrices $A_\lambda(p,h)$ and $a^f(p,h)$. The allowed color flows, helicity combinations and eigenvalues are each labeled by integer indices, so one has to store complex matrices of dimension $N_\lambda\times N_h$ and $N_f\times N_h$, respectively. \item The further strategy depends on the requested information. \begin{enumerate} \item If colorless diagonal helicity amplitudes are required, the eigenvalues $A_\lambda(p,h)$ are squared, summed with weight $\lambda$, and the result contracted with the in-state probability vector $\rho_{\rm in}(p, h_{\rm in})$. The result is a probability vector $\rho_{\rm out}(p, h_{\rm out})$. \item For colored diagonal helicity amplitudes, the color coefficients $a^f(p,h)$ are also squared and used as weights to obtain the color-flow probability vector $\rho_{\rm out}^f(p, h_{\rm out})$. \item For colorless non-diagonal helicity amplitudes, we contract the tensor product of $A_\lambda(p,h)$ with $A_\lambda(p,h')$, weighted with $\lambda$, with the correlated in-state density matrix, to obtain a correlated out-state density matrix. \item In the general (colored, non-diagonal) case, we do the same as in the colorless case, but return the un-normalized color flow density matrix $\hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out})$ in addition. When the relevant helicity basis is known, the latter can be used by the caller program to determine flow probabilities. (In reality, we assume the canonical basis and reduce the correlated out-state density to its diagonal immediately.) \end{enumerate} \end{itemize} @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Flavors: Particle properties} This module contains a type for holding the flavor code, and all functions that depend on the model, i.e., that determine particle properties. The PDG code is packed in a special [[flavor]] type. (This prohibits meaningless operations, and it allows for a different implementation, e.g., some non-PDG scheme internally, if appropiate at some point.) There are lots of further particle properties that depend on the model. Implementing a flyweight pattern, the associated field data object is to be stored in a central area, the [[flavor]] object just receives a pointer to this, so all queries can be delegated. <<[[flavors.f90]]>>= <> module flavors <> <> - use io_units - use diagnostics use physics_defs, only: UNDEFINED - use physics_defs, only: INVALID - use physics_defs, only: HADRON_REMNANT - use physics_defs, only: HADRON_REMNANT_SINGLET - use physics_defs, only: HADRON_REMNANT_TRIPLET - use physics_defs, only: HADRON_REMNANT_OCTET use model_data use colors, only: color_t <> <> <> <> + interface +<> + end interface + +end module flavors +@ %def flavors +@ +<<[[flavors_sub.f90]]>>= +<> + +submodule (flavors) flavors_s + + use io_units + use diagnostics + use physics_defs, only: INVALID + use physics_defs, only: HADRON_REMNANT + use physics_defs, only: HADRON_REMNANT_SINGLET + use physics_defs, only: HADRON_REMNANT_TRIPLET + use physics_defs, only: HADRON_REMNANT_OCTET + + implicit none + contains <> -end module flavors -@ %def flavors +end submodule flavors_s + +@ %def flavors_s @ \subsection{The flavor type} The flavor type is an integer representing the PDG code, or undefined (zero). Negative codes represent antiflavors. They should be used only for particles which do have a distinct antiparticle. The [[hard_process]] flag can be set for particles that are participating in the hard interaction. The [[radiated]] flag can be set for particles that are the result of a beam-structure interaction (hadron beam remnant, ISR photon, etc.), not of the hard interaction itself. Further properties of the given flavor can be retrieved via the particle-data pointer, if it is associated. <>= public :: flavor_t <>= type :: flavor_t private integer :: f = UNDEFINED logical :: hard_process = .false. logical :: radiated = .false. type(field_data_t), pointer :: field_data => null () contains <> end type flavor_t @ %def flavor_t @ Initializer form. If the model is assigned, the procedure is impure, therefore we have to define a separate array version. Note: The pure elemental subroutines can't have an intent(out) CLASS argument (because of the potential for an impure finalizer in a type extension), so we stick to intent(inout) and (re)set all components explicitly. <>= generic :: init => & flavor_init_empty, & flavor_init, & flavor_init_field_data, & flavor_init_model, & flavor_init_model_alt, & flavor_init_name_model procedure, private :: flavor_init_empty procedure, private :: flavor_init procedure, private :: flavor_init_field_data procedure, private :: flavor_init_model procedure, private :: flavor_init_model_alt procedure, private :: flavor_init_name_model +<>= + elemental module subroutine flavor_init_empty (flv) + class(flavor_t), intent(inout) :: flv + end subroutine flavor_init_empty + elemental module subroutine flavor_init (flv, f) + class(flavor_t), intent(inout) :: flv + integer, intent(in) :: f + end subroutine flavor_init + impure elemental module subroutine flavor_init_field_data (flv, field_data) + class(flavor_t), intent(inout) :: flv + type(field_data_t), intent(in), target :: field_data + end subroutine flavor_init_field_data + impure elemental module subroutine flavor_init_model (flv, f, model) + class(flavor_t), intent(inout) :: flv + integer, intent(in) :: f + class(model_data_t), intent(in), target :: model + end subroutine flavor_init_model + impure elemental module subroutine flavor_init_model_alt (flv, f, model, alt_model) + class(flavor_t), intent(inout) :: flv + integer, intent(in) :: f + class(model_data_t), intent(in), target :: model, alt_model + end subroutine flavor_init_model_alt + impure elemental module subroutine flavor_init_name_model (flv, name, model) + class(flavor_t), intent(inout) :: flv + type(string_t), intent(in) :: name + class(model_data_t), intent(in), target :: model + end subroutine flavor_init_name_model <>= - elemental subroutine flavor_init_empty (flv) + elemental module subroutine flavor_init_empty (flv) class(flavor_t), intent(inout) :: flv flv%f = UNDEFINED flv%hard_process = .false. flv%radiated = .false. flv%field_data => null () end subroutine flavor_init_empty - elemental subroutine flavor_init (flv, f) + elemental module subroutine flavor_init (flv, f) class(flavor_t), intent(inout) :: flv integer, intent(in) :: f flv%f = f flv%hard_process = .false. flv%radiated = .false. flv%field_data => null () end subroutine flavor_init - impure elemental subroutine flavor_init_field_data (flv, field_data) + impure elemental module subroutine flavor_init_field_data (flv, field_data) class(flavor_t), intent(inout) :: flv type(field_data_t), intent(in), target :: field_data flv%f = field_data%get_pdg () flv%hard_process = .false. flv%radiated = .false. flv%field_data => field_data end subroutine flavor_init_field_data - impure elemental subroutine flavor_init_model (flv, f, model) + impure elemental module subroutine flavor_init_model (flv, f, model) class(flavor_t), intent(inout) :: flv integer, intent(in) :: f class(model_data_t), intent(in), target :: model flv%f = f flv%hard_process = .false. flv%radiated = .false. flv%field_data => model%get_field_ptr (f, check=.true.) end subroutine flavor_init_model - impure elemental subroutine flavor_init_model_alt (flv, f, model, alt_model) + impure elemental module subroutine flavor_init_model_alt (flv, f, model, alt_model) class(flavor_t), intent(inout) :: flv integer, intent(in) :: f class(model_data_t), intent(in), target :: model, alt_model flv%f = f flv%hard_process = .false. flv%radiated = .false. flv%field_data => model%get_field_ptr (f, check=.false.) if (.not. associated (flv%field_data)) then flv%field_data => alt_model%get_field_ptr (f, check=.false.) if (.not. associated (flv%field_data)) then write (msg_buffer, "(A,1x,I0,1x,A,1x,A,1x,A,1x,A)") & "Particle with code", f, & "found neither in model", char (model%get_name ()), & "nor in model", char (alt_model%get_name ()) call msg_fatal () end if end if end subroutine flavor_init_model_alt - impure elemental subroutine flavor_init_name_model (flv, name, model) + impure elemental module subroutine flavor_init_name_model (flv, name, model) class(flavor_t), intent(inout) :: flv type(string_t), intent(in) :: name class(model_data_t), intent(in), target :: model flv%f = model%get_pdg (name) flv%hard_process = .false. flv%radiated = .false. flv%field_data => model%get_field_ptr (name, check=.true.) end subroutine flavor_init_name_model @ %def flavor_init @ Set the [[radiated]] flag. <>= procedure :: tag_radiated => flavor_tag_radiated +<>= + elemental module subroutine flavor_tag_radiated (flv) + class(flavor_t), intent(inout) :: flv + end subroutine flavor_tag_radiated <>= - elemental subroutine flavor_tag_radiated (flv) + elemental module subroutine flavor_tag_radiated (flv) class(flavor_t), intent(inout) :: flv flv%radiated = .true. end subroutine flavor_tag_radiated @ %def flavor_tag_radiated @ Set the [[hard_process]] flag. <>= procedure :: tag_hard_process => flavor_tag_hard_process +<>= + elemental module subroutine flavor_tag_hard_process (flv, hard) + class(flavor_t), intent(inout) :: flv + logical, intent(in), optional :: hard + end subroutine flavor_tag_hard_process <>= - elemental subroutine flavor_tag_hard_process (flv, hard) + elemental module subroutine flavor_tag_hard_process (flv, hard) class(flavor_t), intent(inout) :: flv logical, intent(in), optional :: hard if (present (hard)) then flv%hard_process = hard else flv%hard_process = .true. end if end subroutine flavor_tag_hard_process @ %def flavor_tag_hard_process @ Undefine the flavor state: <>= procedure :: undefine => flavor_undefine +<>= + elemental module subroutine flavor_undefine (flv) + class(flavor_t), intent(inout) :: flv + end subroutine flavor_undefine <>= - elemental subroutine flavor_undefine (flv) + elemental module subroutine flavor_undefine (flv) class(flavor_t), intent(inout) :: flv flv%f = UNDEFINED flv%field_data => null () end subroutine flavor_undefine @ %def flavor_undefine @ Output: dense, no linebreak A hard-process tag is only shown if debugging is on. <>= procedure :: write => flavor_write +<>= + module subroutine flavor_write (flv, unit) + class(flavor_t), intent(in) :: flv + integer, intent(in), optional :: unit + end subroutine flavor_write <>= - subroutine flavor_write (flv, unit) + module subroutine flavor_write (flv, unit) class(flavor_t), intent(in) :: flv integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return if (associated (flv%field_data)) then write (u, "(A)", advance="no") "f(" else write (u, "(A)", advance="no") "p(" end if write (u, "(I0)", advance="no") flv%f if (flv%radiated) then write (u, "('*')", advance="no") end if if (msg_level (D_FLAVOR) >= DEBUG) then if (flv%hard_process) then write (u, "('#')", advance="no") end if end if write (u, "(A)", advance="no") ")" end subroutine flavor_write @ %def flavor_write @ <>= public :: flavor_write_array +<>= + module subroutine flavor_write_array (flv, unit) + type(flavor_t), intent(in), dimension(:) :: flv + integer, intent(in), optional :: unit + end subroutine flavor_write_array <>= - subroutine flavor_write_array (flv, unit) + module subroutine flavor_write_array (flv, unit) type(flavor_t), intent(in), dimension(:) :: flv integer, intent(in), optional :: unit integer :: u, i_flv u = given_output_unit (unit); if (u < 0) return do i_flv = 1, size (flv) call flv(i_flv)%write (u) if (i_flv /= size (flv)) write (u,"(A)", advance = "no") " / " end do write (u,"(A)") end subroutine flavor_write_array @ %def flavor_write_array @ Binary I/O. Currently, the model information is not written/read, so after reading the particle-data pointer is empty. <>= procedure :: write_raw => flavor_write_raw procedure :: read_raw => flavor_read_raw +<>= + module subroutine flavor_write_raw (flv, u) + class(flavor_t), intent(in) :: flv + integer, intent(in) :: u + end subroutine flavor_write_raw + module subroutine flavor_read_raw (flv, u, iostat) + class(flavor_t), intent(out) :: flv + integer, intent(in) :: u + integer, intent(out), optional :: iostat + end subroutine flavor_read_raw <>= - subroutine flavor_write_raw (flv, u) + module subroutine flavor_write_raw (flv, u) class(flavor_t), intent(in) :: flv integer, intent(in) :: u write (u) flv%f write (u) flv%radiated write (u) flv%hard_process end subroutine flavor_write_raw - subroutine flavor_read_raw (flv, u, iostat) + module subroutine flavor_read_raw (flv, u, iostat) class(flavor_t), intent(out) :: flv integer, intent(in) :: u integer, intent(out), optional :: iostat read (u, iostat=iostat) flv%f if (present (iostat)) then if (iostat /= 0) return end if read (u, iostat=iostat) flv%radiated read (u, iostat=iostat) flv%hard_process end subroutine flavor_read_raw @ %def flavor_write_raw flavor_read_raw @ \subsubsection{Assignment} Default assignment of flavor objects is possible, but cannot be used in pure procedures, because a pointer assignment is involved. Assign the particle pointer separately. This cannot be elemental, so we define a scalar and an array version explicitly. We refer to an array of flavors, not an array of models. <>= procedure :: set_model => flavor_set_model_single +<>= + impure elemental module subroutine flavor_set_model_single (flv, model) + class(flavor_t), intent(inout) :: flv + class(model_data_t), intent(in), target :: model + end subroutine flavor_set_model_single <>= - impure elemental subroutine flavor_set_model_single (flv, model) + impure elemental module subroutine flavor_set_model_single (flv, model) class(flavor_t), intent(inout) :: flv class(model_data_t), intent(in), target :: model if (flv%f /= UNDEFINED) & flv%field_data => model%get_field_ptr (flv%f) end subroutine flavor_set_model_single @ %def flavor_set_model @ \subsubsection{Predicates} Return the definition status. By definition, the flavor object is defined if the flavor PDG code is nonzero. <>= procedure :: is_defined => flavor_is_defined +<>= + elemental module function flavor_is_defined (flv) result (defined) + class(flavor_t), intent(in) :: flv + logical :: defined + end function flavor_is_defined <>= - elemental function flavor_is_defined (flv) result (defined) + elemental module function flavor_is_defined (flv) result (defined) class(flavor_t), intent(in) :: flv logical :: defined defined = flv%f /= UNDEFINED end function flavor_is_defined @ %def flavor_is_defined @ Check for valid flavor (including undefined). This is distinct from the [[is_defined]] status. Invalid flavor is actually a specific PDG code. <>= procedure :: is_valid => flavor_is_valid +<>= + elemental module function flavor_is_valid (flv) result (valid) + class(flavor_t), intent(in) :: flv + logical :: valid + end function flavor_is_valid <>= - elemental function flavor_is_valid (flv) result (valid) + elemental module function flavor_is_valid (flv) result (valid) class(flavor_t), intent(in) :: flv logical :: valid valid = flv%f /= INVALID end function flavor_is_valid @ %def flavor_is_valid @ Return true if the particle-data pointer is associated. (Debugging aid) <>= procedure :: is_associated => flavor_is_associated +<>= + elemental module function flavor_is_associated (flv) result (flag) + class(flavor_t), intent(in) :: flv + logical :: flag + end function flavor_is_associated <>= - elemental function flavor_is_associated (flv) result (flag) + elemental module function flavor_is_associated (flv) result (flag) class(flavor_t), intent(in) :: flv logical :: flag flag = associated (flv%field_data) end function flavor_is_associated @ %def flavor_is_associated @ Check the [[radiated]] flag. A radiated particle has a definite PDG flavor status, but it is actually a pseudoparticle (a beam remnant) which may be subject to fragmentation. <>= procedure :: is_radiated => flavor_is_radiated +<>= + elemental module function flavor_is_radiated (flv) result (flag) + class(flavor_t), intent(in) :: flv + logical :: flag + end function flavor_is_radiated <>= - elemental function flavor_is_radiated (flv) result (flag) + elemental module function flavor_is_radiated (flv) result (flag) class(flavor_t), intent(in) :: flv logical :: flag flag = flv%radiated end function flavor_is_radiated @ %def flavor_is_radiated @ Check the [[hard_process]] flag. A particle is tagged with this flag if it participates in the hard interaction and is not a beam remnant. <>= procedure :: is_hard_process => flavor_is_hard_process +<>= + elemental module function flavor_is_hard_process (flv) result (flag) + class(flavor_t), intent(in) :: flv + logical :: flag + end function flavor_is_hard_process <>= - elemental function flavor_is_hard_process (flv) result (flag) + elemental module function flavor_is_hard_process (flv) result (flag) class(flavor_t), intent(in) :: flv logical :: flag flag = flv%hard_process end function flavor_is_hard_process @ %def flavor_is_hard_process @ \subsubsection{Accessing contents} With the exception of the PDG code, all particle property enquiries are delegated to the [[field_data]] pointer. If this is unassigned, some access function will crash. Return the flavor as an integer <>= procedure :: get_pdg => flavor_get_pdg +<>= + elemental module function flavor_get_pdg (flv) result (f) + integer :: f + class(flavor_t), intent(in) :: flv + end function flavor_get_pdg <>= - elemental function flavor_get_pdg (flv) result (f) + elemental module function flavor_get_pdg (flv) result (f) integer :: f class(flavor_t), intent(in) :: flv f = flv%f end function flavor_get_pdg @ %def flavor_get_pdg @ Return the flavor of the antiparticle <>= procedure :: get_pdg_anti => flavor_get_pdg_anti +<>= + elemental module function flavor_get_pdg_anti (flv) result (f) + integer :: f + class(flavor_t), intent(in) :: flv + end function flavor_get_pdg_anti <>= - elemental function flavor_get_pdg_anti (flv) result (f) + elemental module function flavor_get_pdg_anti (flv) result (f) integer :: f class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then if (flv%field_data%has_antiparticle ()) then f = -flv%f else f = flv%f end if else f = 0 end if end function flavor_get_pdg_anti @ %def flavor_get_pdg_anti @ Absolute value: <>= procedure :: get_pdg_abs => flavor_get_pdg_abs +<>= + elemental module function flavor_get_pdg_abs (flv) result (f) + integer :: f + class(flavor_t), intent(in) :: flv + end function flavor_get_pdg_abs <>= - elemental function flavor_get_pdg_abs (flv) result (f) + elemental module function flavor_get_pdg_abs (flv) result (f) integer :: f class(flavor_t), intent(in) :: flv f = abs (flv%f) end function flavor_get_pdg_abs @ %def flavor_get_pdg_abs @ Generic properties <>= procedure :: is_visible => flavor_is_visible procedure :: is_parton => flavor_is_parton procedure :: is_beam_remnant => flavor_is_beam_remnant procedure :: is_gauge => flavor_is_gauge procedure :: is_left_handed => flavor_is_left_handed procedure :: is_right_handed => flavor_is_right_handed procedure :: is_antiparticle => flavor_is_antiparticle procedure :: has_antiparticle => flavor_has_antiparticle procedure :: is_stable => flavor_is_stable procedure :: get_decays => flavor_get_decays procedure :: decays_isotropically => flavor_decays_isotropically procedure :: decays_diagonal => flavor_decays_diagonal procedure :: has_decay_helicity => flavor_has_decay_helicity procedure :: get_decay_helicity => flavor_get_decay_helicity procedure :: is_polarized => flavor_is_polarized +<>= + elemental module function flavor_is_visible (flv) result (flag) + logical :: flag + class(flavor_t), intent(in) :: flv + end function flavor_is_visible + elemental module function flavor_is_parton (flv) result (flag) + logical :: flag + class(flavor_t), intent(in) :: flv + end function flavor_is_parton + elemental module function flavor_is_beam_remnant (flv) result (flag) + logical :: flag + class(flavor_t), intent(in) :: flv + end function flavor_is_beam_remnant + elemental module function flavor_is_gauge (flv) result (flag) + logical :: flag + class(flavor_t), intent(in) :: flv + end function flavor_is_gauge + elemental module function flavor_is_left_handed (flv) result (flag) + logical :: flag + class(flavor_t), intent(in) :: flv + end function flavor_is_left_handed + elemental module function flavor_is_right_handed (flv) result (flag) + logical :: flag + class(flavor_t), intent(in) :: flv + end function flavor_is_right_handed + elemental module function flavor_is_antiparticle (flv) result (flag) + logical :: flag + class(flavor_t), intent(in) :: flv + end function flavor_is_antiparticle + elemental module function flavor_has_antiparticle (flv) result (flag) + logical :: flag + class(flavor_t), intent(in) :: flv + end function flavor_has_antiparticle + elemental module function flavor_is_stable (flv) result (flag) + logical :: flag + class(flavor_t), intent(in) :: flv + end function flavor_is_stable + module subroutine flavor_get_decays (flv, decay) + class(flavor_t), intent(in) :: flv + type(string_t), dimension(:), intent(out), allocatable :: decay + logical :: anti + end subroutine flavor_get_decays + elemental module function flavor_decays_isotropically (flv) result (flag) + logical :: flag + class(flavor_t), intent(in) :: flv + end function flavor_decays_isotropically + elemental module function flavor_decays_diagonal (flv) result (flag) + logical :: flag + class(flavor_t), intent(in) :: flv + end function flavor_decays_diagonal + elemental module function flavor_has_decay_helicity (flv) result (flag) + logical :: flag + class(flavor_t), intent(in) :: flv + end function flavor_has_decay_helicity + elemental module function flavor_get_decay_helicity (flv) result (hel) + integer :: hel + class(flavor_t), intent(in) :: flv + end function flavor_get_decay_helicity + elemental module function flavor_is_polarized (flv) result (flag) + logical :: flag + class(flavor_t), intent(in) :: flv + end function flavor_is_polarized <>= - elemental function flavor_is_visible (flv) result (flag) + elemental module function flavor_is_visible (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%is_visible () else flag = .false. end if end function flavor_is_visible - elemental function flavor_is_parton (flv) result (flag) + elemental module function flavor_is_parton (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%is_parton () else flag = .false. end if end function flavor_is_parton - elemental function flavor_is_beam_remnant (flv) result (flag) + elemental module function flavor_is_beam_remnant (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv select case (abs (flv%f)) case (HADRON_REMNANT, & HADRON_REMNANT_SINGLET, HADRON_REMNANT_TRIPLET, HADRON_REMNANT_OCTET) flag = .true. case default flag = .false. end select end function flavor_is_beam_remnant - elemental function flavor_is_gauge (flv) result (flag) + elemental module function flavor_is_gauge (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%is_gauge () else flag = .false. end if end function flavor_is_gauge - elemental function flavor_is_left_handed (flv) result (flag) + elemental module function flavor_is_left_handed (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then if (flv%f > 0) then flag = flv%field_data%is_left_handed () else flag = flv%field_data%is_right_handed () end if else flag = .false. end if end function flavor_is_left_handed - elemental function flavor_is_right_handed (flv) result (flag) + elemental module function flavor_is_right_handed (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then if (flv%f > 0) then flag = flv%field_data%is_right_handed () else flag = flv%field_data%is_left_handed () end if else flag = .false. end if end function flavor_is_right_handed - elemental function flavor_is_antiparticle (flv) result (flag) + elemental module function flavor_is_antiparticle (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv flag = flv%f < 0 end function flavor_is_antiparticle - elemental function flavor_has_antiparticle (flv) result (flag) + elemental module function flavor_has_antiparticle (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%has_antiparticle () else flag = .false. end if end function flavor_has_antiparticle - elemental function flavor_is_stable (flv) result (flag) + elemental module function flavor_is_stable (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%is_stable (anti = flv%f < 0) else flag = .true. end if end function flavor_is_stable - subroutine flavor_get_decays (flv, decay) + module subroutine flavor_get_decays (flv, decay) class(flavor_t), intent(in) :: flv type(string_t), dimension(:), intent(out), allocatable :: decay logical :: anti anti = flv%f < 0 if (.not. flv%field_data%is_stable (anti)) then call flv%field_data%get_decays (decay, anti) end if end subroutine flavor_get_decays - elemental function flavor_decays_isotropically (flv) result (flag) + elemental module function flavor_decays_isotropically (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%decays_isotropically (anti = flv%f < 0) else flag = .true. end if end function flavor_decays_isotropically - elemental function flavor_decays_diagonal (flv) result (flag) + elemental module function flavor_decays_diagonal (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%decays_diagonal (anti = flv%f < 0) else flag = .true. end if end function flavor_decays_diagonal - elemental function flavor_has_decay_helicity (flv) result (flag) + elemental module function flavor_has_decay_helicity (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%has_decay_helicity (anti = flv%f < 0) else flag = .false. end if end function flavor_has_decay_helicity - elemental function flavor_get_decay_helicity (flv) result (hel) + elemental module function flavor_get_decay_helicity (flv) result (hel) integer :: hel class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then hel = flv%field_data%decay_helicity (anti = flv%f < 0) else hel = 0 end if end function flavor_get_decay_helicity - elemental function flavor_is_polarized (flv) result (flag) + elemental module function flavor_is_polarized (flv) result (flag) logical :: flag class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then flag = flv%field_data%is_polarized (anti = flv%f < 0) else flag = .false. end if end function flavor_is_polarized @ %def flavor_is_visible @ %def flavor_is_parton @ %def flavor_is_beam_remnant @ %def flavor_is_gauge @ %def flavor_is_left_handed @ %def flavor_is_right_handed @ %def flavor_is_antiparticle @ %def flavor_has_antiparticle @ %def flavor_is_stable @ %def flavor_get_decays @ %def flavor_decays_isotropically @ %def flavor_decays_diagonal @ %def flavor_has_decays_helicity @ %def flavor_get_decay_helicity @ %def flavor_is_polarized @ Names: <>= procedure :: get_name => flavor_get_name procedure :: get_tex_name => flavor_get_tex_name +<>= + elemental module function flavor_get_name (flv) result (name) + type(string_t) :: name + class(flavor_t), intent(in) :: flv + end function flavor_get_name + elemental module function flavor_get_tex_name (flv) result (name) + type(string_t) :: name + class(flavor_t), intent(in) :: flv + end function flavor_get_tex_name <>= - elemental function flavor_get_name (flv) result (name) + elemental module function flavor_get_name (flv) result (name) type(string_t) :: name class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then name = flv%field_data%get_name (flv%f < 0) else name = "?" end if end function flavor_get_name - elemental function flavor_get_tex_name (flv) result (name) + elemental module function flavor_get_tex_name (flv) result (name) type(string_t) :: name class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then name = flv%field_data%get_tex_name (flv%f < 0) else name = "?" end if end function flavor_get_tex_name @ %def flavor_get_name flavor_get_tex_name <>= procedure :: get_spin_type => flavor_get_spin_type procedure :: get_multiplicity => flavor_get_multiplicity procedure :: get_isospin_type => flavor_get_isospin_type procedure :: get_charge_type => flavor_get_charge_type procedure :: get_color_type => flavor_get_color_type +<>= + elemental module function flavor_get_spin_type (flv) result (type) + integer :: type + class(flavor_t), intent(in) :: flv + end function flavor_get_spin_type + elemental module function flavor_get_multiplicity (flv) result (type) + integer :: type + class(flavor_t), intent(in) :: flv + end function flavor_get_multiplicity + elemental module function flavor_get_isospin_type (flv) result (type) + integer :: type + class(flavor_t), intent(in) :: flv + end function flavor_get_isospin_type + elemental module function flavor_get_charge_type (flv) result (type) + integer :: type + class(flavor_t), intent(in) :: flv + end function flavor_get_charge_type + elemental module function flavor_get_color_type (flv) result (type) + integer :: type + class(flavor_t), intent(in) :: flv + end function flavor_get_color_type <>= - elemental function flavor_get_spin_type (flv) result (type) + elemental module function flavor_get_spin_type (flv) result (type) integer :: type class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then type = flv%field_data%get_spin_type () else type = 1 end if end function flavor_get_spin_type - elemental function flavor_get_multiplicity (flv) result (type) + elemental module function flavor_get_multiplicity (flv) result (type) integer :: type class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then type = flv%field_data%get_multiplicity () else type = 1 end if end function flavor_get_multiplicity - elemental function flavor_get_isospin_type (flv) result (type) + elemental module function flavor_get_isospin_type (flv) result (type) integer :: type class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then type = flv%field_data%get_isospin_type () else type = 1 end if end function flavor_get_isospin_type - elemental function flavor_get_charge_type (flv) result (type) + elemental module function flavor_get_charge_type (flv) result (type) integer :: type class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then type = flv%field_data%get_charge_type () else type = 1 end if end function flavor_get_charge_type - elemental function flavor_get_color_type (flv) result (type) + elemental module function flavor_get_color_type (flv) result (type) integer :: type class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then if (flavor_is_antiparticle (flv)) then type = - flv%field_data%get_color_type () else type = flv%field_data%get_color_type () end if select case (type) case (-1,-8); type = abs (type) end select else type = 1 end if end function flavor_get_color_type @ %def flavor_get_spin_type @ %def flavor_get_multiplicity @ %def flavor_get_isospin_type @ %def flavor_get_charge_type @ %def flavor_get_color_type @ These functions return real values: <>= procedure :: get_charge => flavor_get_charge procedure :: get_mass => flavor_get_mass procedure :: get_width => flavor_get_width procedure :: get_isospin => flavor_get_isospin +<>= + elemental module function flavor_get_charge (flv) result (charge) + real(default) :: charge + class(flavor_t), intent(in) :: flv + end function flavor_get_charge + elemental module function flavor_get_mass (flv) result (mass) + real(default) :: mass + class(flavor_t), intent(in) :: flv + end function flavor_get_mass + elemental module function flavor_get_width (flv) result (width) + real(default) :: width + class(flavor_t), intent(in) :: flv + end function flavor_get_width + elemental module function flavor_get_isospin (flv) result (isospin) + real(default) :: isospin + class(flavor_t), intent(in) :: flv + end function flavor_get_isospin <>= - elemental function flavor_get_charge (flv) result (charge) + elemental module function flavor_get_charge (flv) result (charge) real(default) :: charge class(flavor_t), intent(in) :: flv integer :: charge_type if (associated (flv%field_data)) then charge_type = flv%get_charge_type () if (charge_type == 0 .or. charge_type == 1) then charge = 0 else if (flavor_is_antiparticle (flv)) then charge = - flv%field_data%get_charge () else charge = flv%field_data%get_charge () end if end if else charge = 0 end if end function flavor_get_charge - elemental function flavor_get_mass (flv) result (mass) + elemental module function flavor_get_mass (flv) result (mass) real(default) :: mass class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then mass = flv%field_data%get_mass () else mass = 0 end if end function flavor_get_mass - elemental function flavor_get_width (flv) result (width) + elemental module function flavor_get_width (flv) result (width) real(default) :: width class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then width = flv%field_data%get_width () else width = 0 end if end function flavor_get_width - elemental function flavor_get_isospin (flv) result (isospin) + elemental module function flavor_get_isospin (flv) result (isospin) real(default) :: isospin class(flavor_t), intent(in) :: flv if (associated (flv%field_data)) then if (flavor_is_antiparticle (flv)) then isospin = - flv%field_data%get_isospin () else isospin = flv%field_data%get_isospin () end if else isospin = 0 end if end function flavor_get_isospin @ %def flavor_get_charge flavor_get_mass flavor_get_width @ %def flavor_get_isospin @ \subsubsection{Comparisons} If one of the flavors is undefined, the other defined, they match. <>= generic :: operator(.match.) => flavor_match generic :: operator(==) => flavor_eq generic :: operator(/=) => flavor_neq procedure, private :: flavor_match procedure, private :: flavor_eq procedure, private :: flavor_neq -@ %def .match. == /= +@ %def .match. == /= +<>= + elemental module function flavor_match (flv1, flv2) result (eq) + logical :: eq + class(flavor_t), intent(in) :: flv1, flv2 + end function flavor_match + elemental module function flavor_eq (flv1, flv2) result (eq) + logical :: eq + class(flavor_t), intent(in) :: flv1, flv2 + end function flavor_eq <>= - elemental function flavor_match (flv1, flv2) result (eq) + elemental module function flavor_match (flv1, flv2) result (eq) logical :: eq class(flavor_t), intent(in) :: flv1, flv2 if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then eq = flv1%f == flv2%f else eq = .true. end if end function flavor_match - elemental function flavor_eq (flv1, flv2) result (eq) + elemental module function flavor_eq (flv1, flv2) result (eq) logical :: eq class(flavor_t), intent(in) :: flv1, flv2 if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then eq = flv1%f == flv2%f else if (flv1%f == UNDEFINED .and. flv2%f == UNDEFINED) then eq = .true. else eq = .false. end if end function flavor_eq @ %def flavor_match flavor_eq +<>= + elemental module function flavor_neq (flv1, flv2) result (neq) + logical :: neq + class(flavor_t), intent(in) :: flv1, flv2 + end function flavor_neq <>= - elemental function flavor_neq (flv1, flv2) result (neq) + elemental module function flavor_neq (flv1, flv2) result (neq) logical :: neq class(flavor_t), intent(in) :: flv1, flv2 if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then neq = flv1%f /= flv2%f else if (flv1%f == UNDEFINED .and. flv2%f == UNDEFINED) then neq = .false. else neq = .true. end if end function flavor_neq @ %def flavor_neq @ \subsubsection{Tools} Merge two flavor indices. This works only if both are equal or either one is undefined, because we have no off-diagonal flavor entries. Otherwise, generate an invalid flavor. We cannot use elemental procedures because of the pointer component. <>= public :: operator(.merge.) <>= interface operator(.merge.) module procedure merge_flavors0 module procedure merge_flavors1 end interface @ %def .merge. +<>= + module function merge_flavors0 (flv1, flv2) result (flv) + type(flavor_t) :: flv + type(flavor_t), intent(in) :: flv1, flv2 + end function merge_flavors0 + module function merge_flavors1 (flv1, flv2) result (flv) + type(flavor_t), dimension(:), intent(in) :: flv1, flv2 + type(flavor_t), dimension(size(flv1)) :: flv + end function merge_flavors1 <>= - function merge_flavors0 (flv1, flv2) result (flv) + module function merge_flavors0 (flv1, flv2) result (flv) type(flavor_t) :: flv type(flavor_t), intent(in) :: flv1, flv2 if (flavor_is_defined (flv1) .and. flavor_is_defined (flv2)) then if (flv1 == flv2) then flv = flv1 else flv%f = INVALID end if else if (flavor_is_defined (flv1)) then flv = flv1 else if (flavor_is_defined (flv2)) then flv = flv2 end if end function merge_flavors0 - function merge_flavors1 (flv1, flv2) result (flv) + module function merge_flavors1 (flv1, flv2) result (flv) type(flavor_t), dimension(:), intent(in) :: flv1, flv2 type(flavor_t), dimension(size(flv1)) :: flv integer :: i do i = 1, size (flv1) flv(i) = flv1(i) .merge. flv2(i) end do end function merge_flavors1 @ %def merge_flavors @ Generate consecutive color indices for a given flavor. The indices are counted starting with the stored value of c, so new indices are created each time this (impure) function is called. The counter can be reset by the optional argument [[c_seed]] if desired. The optional flag [[reverse]] is used only for octets. If set, the color and anticolor entries of the octet particle are exchanged. <>= public :: color_from_flavor <>= interface color_from_flavor module procedure color_from_flavor0 module procedure color_from_flavor1 end interface +<>= + module function color_from_flavor0 (flv, c_seed, reverse) result (col) + type(color_t) :: col + type(flavor_t), intent(in) :: flv + integer, intent(in), optional :: c_seed + logical, intent(in), optional :: reverse + end function color_from_flavor0 + module function color_from_flavor1 (flv, c_seed, reverse) result (col) + type(flavor_t), dimension(:), intent(in) :: flv + integer, intent(in), optional :: c_seed + logical, intent(in), optional :: reverse + type(color_t), dimension(size(flv)) :: col + end function color_from_flavor1 <>= - function color_from_flavor0 (flv, c_seed, reverse) result (col) + module function color_from_flavor0 (flv, c_seed, reverse) result (col) type(color_t) :: col type(flavor_t), intent(in) :: flv integer, intent(in), optional :: c_seed logical, intent(in), optional :: reverse integer, save :: c = 1 logical :: rev if (present (c_seed)) c = c_seed rev = .false.; if (present (reverse)) rev = reverse select case (flavor_get_color_type (flv)) case (1) call col%init () case (3) call col%init ([c]); c = c + 1 case (-3) call col%init ([-c]); c = c + 1 case (8) if (rev) then call col%init ([c+1, -c]); c = c + 2 else call col%init ([c, -(c+1)]); c = c + 2 end if end select end function color_from_flavor0 - function color_from_flavor1 (flv, c_seed, reverse) result (col) + module function color_from_flavor1 (flv, c_seed, reverse) result (col) type(flavor_t), dimension(:), intent(in) :: flv integer, intent(in), optional :: c_seed logical, intent(in), optional :: reverse type(color_t), dimension(size(flv)) :: col integer :: i col(1) = color_from_flavor0 (flv(1), c_seed, reverse) do i = 2, size (flv) col(i) = color_from_flavor0 (flv(i), reverse=reverse) end do end function color_from_flavor1 @ %def color_from_flavor @ This procedure returns the flavor object for the antiparticle. The antiparticle code may either be the same code or its negative. <>= procedure :: anti => flavor_anti +<>= + module function flavor_anti (flv) result (aflv) + type(flavor_t) :: aflv + class(flavor_t), intent(in) :: flv + end function flavor_anti <>= - function flavor_anti (flv) result (aflv) + module function flavor_anti (flv) result (aflv) type(flavor_t) :: aflv class(flavor_t), intent(in) :: flv if (flavor_has_antiparticle (flv)) then aflv%f = - flv%f else aflv%f = flv%f end if aflv%field_data => flv%field_data end function flavor_anti @ %def flavor_anti @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Quantum numbers} This module collects helicity, color, and flavor in a single type and defines procedures <<[[quantum_numbers.f90]]>>= <> module quantum_numbers - use io_units use model_data use helicities use colors use flavors <> <> <> <> + interface +<> + end interface + +end module quantum_numbers +@ %def quantum_numbers +@ +<<[[quantum_numbers_sub.f90]]>>= +<> + +submodule (quantum_numbers) quantum_numbers_s + + use io_units + + implicit none + contains <> -end module quantum_numbers -@ %def quantum_numbers +end submodule quantum_numbers_s + +@ %def quantum_numbers_s @ \subsection{The quantum number type} <>= public :: quantum_numbers_t <>= type :: quantum_numbers_t private type(flavor_t) :: f type(color_t) :: c type(helicity_t) :: h integer :: sub = 0 contains <> end type quantum_numbers_t @ %def quantum_number_t @ Define quantum numbers: Initializer form. All arguments may be present or absent. Some elemental initializers are impure because they set the [[flv]] component. This implies transfer of a pointer behind the scenes. <>= generic :: init => & quantum_numbers_init_f, & quantum_numbers_init_c, & quantum_numbers_init_h, & quantum_numbers_init_fc, & quantum_numbers_init_fh, & quantum_numbers_init_ch, & quantum_numbers_init_fch, & quantum_numbers_init_fs, & quantum_numbers_init_fhs, & quantum_numbers_init_fcs, & quantum_numbers_init_fhcs procedure, private :: quantum_numbers_init_f procedure, private :: quantum_numbers_init_c procedure, private :: quantum_numbers_init_h procedure, private :: quantum_numbers_init_fc procedure, private :: quantum_numbers_init_fh procedure, private :: quantum_numbers_init_ch procedure, private :: quantum_numbers_init_fch procedure, private :: quantum_numbers_init_fs procedure, private :: quantum_numbers_init_fhs procedure, private :: quantum_numbers_init_fcs procedure, private :: quantum_numbers_init_fhcs +<>= + impure elemental module subroutine quantum_numbers_init_f (qn, flv) + class(quantum_numbers_t), intent(out) :: qn + type(flavor_t), intent(in) :: flv + end subroutine quantum_numbers_init_f + impure elemental module subroutine quantum_numbers_init_c (qn, col) + class(quantum_numbers_t), intent(out) :: qn + type(color_t), intent(in) :: col + end subroutine quantum_numbers_init_c + impure elemental module subroutine quantum_numbers_init_h (qn, hel) + class(quantum_numbers_t), intent(out) :: qn + type(helicity_t), intent(in) :: hel + end subroutine quantum_numbers_init_h + impure elemental module subroutine quantum_numbers_init_fc (qn, flv, col) + class(quantum_numbers_t), intent(out) :: qn + type(flavor_t), intent(in) :: flv + type(color_t), intent(in) :: col + end subroutine quantum_numbers_init_fc + impure elemental module subroutine quantum_numbers_init_fh (qn, flv, hel) + class(quantum_numbers_t), intent(out) :: qn + type(flavor_t), intent(in) :: flv + type(helicity_t), intent(in) :: hel + end subroutine quantum_numbers_init_fh + impure elemental module subroutine quantum_numbers_init_ch (qn, col, hel) + class(quantum_numbers_t), intent(out) :: qn + type(color_t), intent(in) :: col + type(helicity_t), intent(in) :: hel + end subroutine quantum_numbers_init_ch + impure elemental module subroutine quantum_numbers_init_fch (qn, flv, col, hel) + class(quantum_numbers_t), intent(out) :: qn + type(flavor_t), intent(in) :: flv + type(color_t), intent(in) :: col + type(helicity_t), intent(in) :: hel + end subroutine quantum_numbers_init_fch + impure elemental module subroutine quantum_numbers_init_fs (qn, flv, sub) + class(quantum_numbers_t), intent(out) :: qn + type(flavor_t), intent(in) :: flv + integer, intent(in) :: sub + end subroutine quantum_numbers_init_fs + impure elemental module subroutine quantum_numbers_init_fhs (qn, flv, hel, sub) + class(quantum_numbers_t), intent(out) :: qn + type(flavor_t), intent(in) :: flv + type(helicity_t), intent(in) :: hel + integer, intent(in) :: sub + end subroutine quantum_numbers_init_fhs + impure elemental module subroutine quantum_numbers_init_fcs (qn, flv, col, sub) + class(quantum_numbers_t), intent(out) :: qn + type(flavor_t), intent(in) :: flv + type(color_t), intent(in) :: col + integer, intent(in) :: sub + end subroutine quantum_numbers_init_fcs + impure elemental module subroutine quantum_numbers_init_fhcs (qn, flv, hel, col, sub) + class(quantum_numbers_t), intent(out) :: qn + type(flavor_t), intent(in) :: flv + type(helicity_t), intent(in) :: hel + type(color_t), intent(in) :: col + integer, intent(in) :: sub + end subroutine quantum_numbers_init_fhcs <>= - impure elemental subroutine quantum_numbers_init_f (qn, flv) + impure elemental module subroutine quantum_numbers_init_f (qn, flv) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv qn%f = flv call qn%c%undefine () call qn%h%undefine () qn%sub = 0 end subroutine quantum_numbers_init_f - impure elemental subroutine quantum_numbers_init_c (qn, col) + impure elemental module subroutine quantum_numbers_init_c (qn, col) class(quantum_numbers_t), intent(out) :: qn type(color_t), intent(in) :: col call qn%f%undefine () qn%c = col call qn%h%undefine () qn%sub = 0 end subroutine quantum_numbers_init_c - impure elemental subroutine quantum_numbers_init_h (qn, hel) + impure elemental module subroutine quantum_numbers_init_h (qn, hel) class(quantum_numbers_t), intent(out) :: qn type(helicity_t), intent(in) :: hel call qn%f%undefine () call qn%c%undefine () qn%h = hel qn%sub = 0 end subroutine quantum_numbers_init_h - impure elemental subroutine quantum_numbers_init_fc (qn, flv, col) + impure elemental module subroutine quantum_numbers_init_fc (qn, flv, col) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(color_t), intent(in) :: col qn%f = flv qn%c = col call qn%h%undefine () qn%sub = 0 end subroutine quantum_numbers_init_fc - impure elemental subroutine quantum_numbers_init_fh (qn, flv, hel) + impure elemental module subroutine quantum_numbers_init_fh (qn, flv, hel) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(helicity_t), intent(in) :: hel qn%f = flv call qn%c%undefine () qn%h = hel qn%sub = 0 end subroutine quantum_numbers_init_fh - impure elemental subroutine quantum_numbers_init_ch (qn, col, hel) + impure elemental module subroutine quantum_numbers_init_ch (qn, col, hel) class(quantum_numbers_t), intent(out) :: qn type(color_t), intent(in) :: col type(helicity_t), intent(in) :: hel call qn%f%undefine () qn%c = col qn%h = hel qn%sub = 0 end subroutine quantum_numbers_init_ch - impure elemental subroutine quantum_numbers_init_fch (qn, flv, col, hel) + impure elemental module subroutine quantum_numbers_init_fch (qn, flv, col, hel) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(color_t), intent(in) :: col type(helicity_t), intent(in) :: hel qn%f = flv qn%c = col qn%h = hel qn%sub = 0 end subroutine quantum_numbers_init_fch - impure elemental subroutine quantum_numbers_init_fs (qn, flv, sub) + impure elemental module subroutine quantum_numbers_init_fs (qn, flv, sub) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv integer, intent(in) :: sub qn%f = flv; qn%sub = sub end subroutine quantum_numbers_init_fs - impure elemental subroutine quantum_numbers_init_fhs (qn, flv, hel, sub) + impure elemental module subroutine quantum_numbers_init_fhs (qn, flv, hel, sub) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(helicity_t), intent(in) :: hel integer, intent(in) :: sub qn%f = flv; qn%h = hel; qn%sub = sub end subroutine quantum_numbers_init_fhs - impure elemental subroutine quantum_numbers_init_fcs (qn, flv, col, sub) + impure elemental module subroutine quantum_numbers_init_fcs (qn, flv, col, sub) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(color_t), intent(in) :: col integer, intent(in) :: sub qn%f = flv; qn%c = col; qn%sub = sub end subroutine quantum_numbers_init_fcs - impure elemental subroutine quantum_numbers_init_fhcs (qn, flv, hel, col, sub) + impure elemental module subroutine quantum_numbers_init_fhcs (qn, flv, hel, col, sub) class(quantum_numbers_t), intent(out) :: qn type(flavor_t), intent(in) :: flv type(helicity_t), intent(in) :: hel type(color_t), intent(in) :: col integer, intent(in) :: sub qn%f = flv; qn%h = hel; qn%c = col; qn%sub = sub end subroutine quantum_numbers_init_fhcs @ %def quantum_numbers_init @ \subsection{I/O} Write the quantum numbers in condensed form, enclosed by square brackets. Color is written only if nontrivial. For convenience, introduce also an array version. If the [[col_verbose]] option is set, show the quantum number color also if it is zero, but defined. Otherwise, suppress zero color. <>= public :: quantum_numbers_write <>= procedure :: write => quantum_numbers_write_single <>= interface quantum_numbers_write module procedure quantum_numbers_write_single module procedure quantum_numbers_write_array end interface +<>= + module subroutine quantum_numbers_write_single (qn, unit, col_verbose) + class(quantum_numbers_t), intent(in) :: qn + integer, intent(in), optional :: unit + logical, intent(in), optional :: col_verbose + end subroutine quantum_numbers_write_single + module subroutine quantum_numbers_write_array (qn, unit, col_verbose) + type(quantum_numbers_t), dimension(:), intent(in) :: qn + integer, intent(in), optional :: unit + logical, intent(in), optional :: col_verbose + end subroutine quantum_numbers_write_array <>= - subroutine quantum_numbers_write_single (qn, unit, col_verbose) + module subroutine quantum_numbers_write_single (qn, unit, col_verbose) class(quantum_numbers_t), intent(in) :: qn integer, intent(in), optional :: unit logical, intent(in), optional :: col_verbose integer :: u logical :: col_verb u = given_output_unit (unit); if (u < 0) return col_verb = .false.; if (present (col_verbose)) col_verb = col_verbose write (u, "(A)", advance = "no") "[" if (qn%f%is_defined ()) then call qn%f%write (u) if (qn%c%is_nonzero () .or. qn%h%is_defined ()) & write (u, "(1x)", advance = "no") end if if (col_verb) then if (qn%c%is_defined () .or. qn%c%is_ghost ()) then call color_write (qn%c, u) if (qn%h%is_defined ()) write (u, "(1x)", advance = "no") end if else if (qn%c%is_nonzero () .or. qn%c%is_ghost ()) then call color_write (qn%c, u) if (qn%h%is_defined ()) write (u, "(1x)", advance = "no") end if end if if (qn%h%is_defined ()) then call qn%h%write (u) end if if (qn%sub > 0) & write (u, "(A,I0)", advance = "no") " SUB = ", qn%sub write (u, "(A)", advance="no") "]" end subroutine quantum_numbers_write_single - subroutine quantum_numbers_write_array (qn, unit, col_verbose) + module subroutine quantum_numbers_write_array (qn, unit, col_verbose) type(quantum_numbers_t), dimension(:), intent(in) :: qn integer, intent(in), optional :: unit logical, intent(in), optional :: col_verbose integer :: i integer :: u logical :: col_verb u = given_output_unit (unit); if (u < 0) return col_verb = .false.; if (present (col_verbose)) col_verb = col_verbose write (u, "(A)", advance="no") "[" do i = 1, size (qn) if (i > 1) write (u, "(A)", advance="no") " / " if (qn(i)%f%is_defined ()) then call qn(i)%f%write (u) if (qn(i)%c%is_nonzero () .or. qn(i)%h%is_defined ()) & write (u, "(1x)", advance="no") end if if (col_verb) then if (qn(i)%c%is_defined () .or. qn(i)%c%is_ghost ()) then call color_write (qn(i)%c, u) if (qn(i)%h%is_defined ()) write (u, "(1x)", advance="no") end if else if (qn(i)%c%is_nonzero () .or. qn(i)%c%is_ghost ()) then call color_write (qn(i)%c, u) if (qn(i)%h%is_defined ()) write (u, "(1x)", advance="no") end if end if if (qn(i)%h%is_defined ()) then call qn(i)%h%write (u) end if if (qn(i)%sub > 0) & write (u, "(A,I2)", advance = "no") " SUB = ", qn(i)%sub end do write (u, "(A)", advance = "no") "]" end subroutine quantum_numbers_write_array @ %def quantum_numbers_write @ Binary I/O. <>= procedure :: write_raw => quantum_numbers_write_raw procedure :: read_raw => quantum_numbers_read_raw +<>= + module subroutine quantum_numbers_write_raw (qn, u) + class(quantum_numbers_t), intent(in) :: qn + integer, intent(in) :: u + end subroutine quantum_numbers_write_raw + module subroutine quantum_numbers_read_raw (qn, u, iostat) + class(quantum_numbers_t), intent(out) :: qn + integer, intent(in) :: u + integer, intent(out), optional :: iostat + end subroutine quantum_numbers_read_raw <>= - subroutine quantum_numbers_write_raw (qn, u) + module subroutine quantum_numbers_write_raw (qn, u) class(quantum_numbers_t), intent(in) :: qn integer, intent(in) :: u call qn%f%write_raw (u) call qn%c%write_raw (u) call qn%h%write_raw (u) end subroutine quantum_numbers_write_raw - subroutine quantum_numbers_read_raw (qn, u, iostat) + module subroutine quantum_numbers_read_raw (qn, u, iostat) class(quantum_numbers_t), intent(out) :: qn integer, intent(in) :: u integer, intent(out), optional :: iostat call qn%f%read_raw (u, iostat=iostat) call qn%c%read_raw (u, iostat=iostat) call qn%h%read_raw (u, iostat=iostat) end subroutine quantum_numbers_read_raw @ %def quantum_numbers_write_raw quantum_numbers_read_raw @ \subsection{Accessing contents} Color and helicity can be done by elemental functions. Flavor needs impure elemental. We export also the functions directly, this allows us to avoid temporaries in some places. <>= public :: quantum_numbers_get_flavor public :: quantum_numbers_get_color public :: quantum_numbers_get_helicity <>= procedure :: get_flavor => quantum_numbers_get_flavor procedure :: get_color => quantum_numbers_get_color procedure :: get_helicity => quantum_numbers_get_helicity procedure :: get_sub => quantum_numbers_get_sub +<>= + impure elemental module function quantum_numbers_get_flavor (qn) result (flv) + type(flavor_t) :: flv + class(quantum_numbers_t), intent(in) :: qn + end function quantum_numbers_get_flavor + elemental module function quantum_numbers_get_color (qn) result (col) + type(color_t) :: col + class(quantum_numbers_t), intent(in) :: qn + end function quantum_numbers_get_color + elemental module function quantum_numbers_get_helicity (qn) result (hel) + type(helicity_t) :: hel + class(quantum_numbers_t), intent(in) :: qn + end function quantum_numbers_get_helicity + elemental module function quantum_numbers_get_sub (qn) result (sub) + integer :: sub + class(quantum_numbers_t), intent(in) :: qn + end function quantum_numbers_get_sub <>= - impure elemental function quantum_numbers_get_flavor (qn) result (flv) + impure elemental module function quantum_numbers_get_flavor (qn) result (flv) type(flavor_t) :: flv class(quantum_numbers_t), intent(in) :: qn flv = qn%f end function quantum_numbers_get_flavor - elemental function quantum_numbers_get_color (qn) result (col) + elemental module function quantum_numbers_get_color (qn) result (col) type(color_t) :: col class(quantum_numbers_t), intent(in) :: qn col = qn%c end function quantum_numbers_get_color - elemental function quantum_numbers_get_helicity (qn) result (hel) + elemental module function quantum_numbers_get_helicity (qn) result (hel) type(helicity_t) :: hel class(quantum_numbers_t), intent(in) :: qn hel = qn%h end function quantum_numbers_get_helicity - elemental function quantum_numbers_get_sub (qn) result (sub) + elemental module function quantum_numbers_get_sub (qn) result (sub) integer :: sub class(quantum_numbers_t), intent(in) :: qn sub = qn%sub end function quantum_numbers_get_sub @ %def quantum_numbers_get_flavor @ %def quantum_numbers_get_color @ %def quantum_numbers_get_helicity @ %def quantum_numbers_get_sub @ This just resets the ghost property of the color part: <>= procedure :: set_color_ghost => quantum_numbers_set_color_ghost +<>= + elemental module subroutine quantum_numbers_set_color_ghost (qn, ghost) + class(quantum_numbers_t), intent(inout) :: qn + logical, intent(in) :: ghost + end subroutine quantum_numbers_set_color_ghost <>= - elemental subroutine quantum_numbers_set_color_ghost (qn, ghost) + elemental module subroutine quantum_numbers_set_color_ghost (qn, ghost) class(quantum_numbers_t), intent(inout) :: qn logical, intent(in) :: ghost call qn%c%set_ghost (ghost) end subroutine quantum_numbers_set_color_ghost @ %def quantum_numbers_set_color_ghost @ Assign a model to the flavor part of quantum numbers. <>= procedure :: set_model => quantum_numbers_set_model +<>= + impure elemental module subroutine quantum_numbers_set_model (qn, model) + class(quantum_numbers_t), intent(inout) :: qn + class(model_data_t), intent(in), target :: model + end subroutine quantum_numbers_set_model <>= - impure elemental subroutine quantum_numbers_set_model (qn, model) + impure elemental module subroutine quantum_numbers_set_model (qn, model) class(quantum_numbers_t), intent(inout) :: qn class(model_data_t), intent(in), target :: model call qn%f%set_model (model) end subroutine quantum_numbers_set_model @ %def quantum_numbers_set_model @ Set the [[radiated]] flag for the flavor component. <>= procedure :: tag_radiated => quantum_numbers_tag_radiated +<>= + elemental module subroutine quantum_numbers_tag_radiated (qn) + class(quantum_numbers_t), intent(inout) :: qn + end subroutine quantum_numbers_tag_radiated <>= - elemental subroutine quantum_numbers_tag_radiated (qn) + elemental module subroutine quantum_numbers_tag_radiated (qn) class(quantum_numbers_t), intent(inout) :: qn call qn%f%tag_radiated () end subroutine quantum_numbers_tag_radiated @ %def quantum_numbers_tag_radiated @ Set the [[hard_process]] flag for the flavor component. <>= procedure :: tag_hard_process => quantum_numbers_tag_hard_process +<>= + elemental module subroutine quantum_numbers_tag_hard_process (qn, hard) + class(quantum_numbers_t), intent(inout) :: qn + logical, intent(in), optional :: hard + end subroutine quantum_numbers_tag_hard_process <>= - elemental subroutine quantum_numbers_tag_hard_process (qn, hard) + elemental module subroutine quantum_numbers_tag_hard_process (qn, hard) class(quantum_numbers_t), intent(inout) :: qn logical, intent(in), optional :: hard call qn%f%tag_hard_process (hard) end subroutine quantum_numbers_tag_hard_process @ %def quantum_numbers_tag_hard_process @ <>= - procedure :: set_subtraction_index => quantum_numbers_set_subtraction_index + procedure :: set_subtraction_index => & + quantum_numbers_set_subtraction_index +<>= + elemental module subroutine quantum_numbers_set_subtraction_index (qn, i) + class(quantum_numbers_t), intent(inout) :: qn + integer, intent(in) :: i + end subroutine quantum_numbers_set_subtraction_index <>= - elemental subroutine quantum_numbers_set_subtraction_index (qn, i) + elemental module subroutine quantum_numbers_set_subtraction_index (qn, i) class(quantum_numbers_t), intent(inout) :: qn integer, intent(in) :: i qn%sub = i end subroutine quantum_numbers_set_subtraction_index @ %def quantum_numbers_set_subtraction_index @ <>= - procedure :: get_subtraction_index => quantum_numbers_get_subtraction_index + procedure :: get_subtraction_index => & + quantum_numbers_get_subtraction_index +<>= + elemental module function quantum_numbers_get_subtraction_index & + (qn) result (sub) + integer :: sub + class(quantum_numbers_t), intent(in) :: qn + end function quantum_numbers_get_subtraction_index <>= - elemental function quantum_numbers_get_subtraction_index (qn) result (sub) + elemental module function quantum_numbers_get_subtraction_index & + (qn) result (sub) integer :: sub class(quantum_numbers_t), intent(in) :: qn sub = qn%sub end function quantum_numbers_get_subtraction_index @ %def quantum_numbers_get_subtraction_index @ This is a convenience function: return the color type for the flavor (array). <>= procedure :: get_color_type => quantum_numbers_get_color_type +<>= + elemental module function quantum_numbers_get_color_type (qn) result (color_type) + integer :: color_type + class(quantum_numbers_t), intent(in) :: qn + end function quantum_numbers_get_color_type <>= - elemental function quantum_numbers_get_color_type (qn) result (color_type) + elemental module function quantum_numbers_get_color_type (qn) result (color_type) integer :: color_type class(quantum_numbers_t), intent(in) :: qn color_type = qn%f%get_color_type () end function quantum_numbers_get_color_type @ %def quantum_numbers_get_color_type @ \subsection{Predicates} Check if the flavor index is valid (including UNDEFINED). <>= procedure :: are_valid => quantum_numbers_are_valid +<>= + elemental module function quantum_numbers_are_valid (qn) result (valid) + logical :: valid + class(quantum_numbers_t), intent(in) :: qn + end function quantum_numbers_are_valid <>= - elemental function quantum_numbers_are_valid (qn) result (valid) + elemental module function quantum_numbers_are_valid (qn) result (valid) logical :: valid class(quantum_numbers_t), intent(in) :: qn valid = qn%f%is_valid () end function quantum_numbers_are_valid @ %def quantum_numbers_are_valid @ Check if the flavor part has its particle-data pointer associated (debugging aid). <>= procedure :: are_associated => quantum_numbers_are_associated +<>= + elemental module function quantum_numbers_are_associated (qn) result (flag) + logical :: flag + class(quantum_numbers_t), intent(in) :: qn + end function quantum_numbers_are_associated <>= - elemental function quantum_numbers_are_associated (qn) result (flag) + elemental module function quantum_numbers_are_associated (qn) result (flag) logical :: flag class(quantum_numbers_t), intent(in) :: qn flag = qn%f%is_associated () end function quantum_numbers_are_associated @ %def quantum_numbers_are_associated @ Check if the helicity and color quantum numbers are diagonal. (Unpolarized/colorless also counts as diagonal.) Flavor is diagonal by definition. <>= procedure :: are_diagonal => quantum_numbers_are_diagonal +<>= + elemental module function quantum_numbers_are_diagonal (qn) result (diagonal) + logical :: diagonal + class(quantum_numbers_t), intent(in) :: qn + end function quantum_numbers_are_diagonal <>= - elemental function quantum_numbers_are_diagonal (qn) result (diagonal) + elemental module function quantum_numbers_are_diagonal (qn) result (diagonal) logical :: diagonal class(quantum_numbers_t), intent(in) :: qn diagonal = qn%h%is_diagonal () .and. qn%c%is_diagonal () end function quantum_numbers_are_diagonal @ %def quantum_numbers_are_diagonal @ Check if the color part has the ghost property. <>= procedure :: is_color_ghost => quantum_numbers_is_color_ghost +<>= + elemental module function quantum_numbers_is_color_ghost (qn) result (ghost) + logical :: ghost + class(quantum_numbers_t), intent(in) :: qn + end function quantum_numbers_is_color_ghost <>= - elemental function quantum_numbers_is_color_ghost (qn) result (ghost) + elemental module function quantum_numbers_is_color_ghost (qn) result (ghost) logical :: ghost class(quantum_numbers_t), intent(in) :: qn ghost = qn%c%is_ghost () end function quantum_numbers_is_color_ghost @ %def quantum_numbers_is_color_ghost @ Check if the flavor participates in the hard interaction. <>= procedure :: are_hard_process => quantum_numbers_are_hard_process +<>= + elemental module function quantum_numbers_are_hard_process & + (qn) result (hard_process) + logical :: hard_process + class(quantum_numbers_t), intent(in) :: qn + end function quantum_numbers_are_hard_process <>= - elemental function quantum_numbers_are_hard_process (qn) result (hard_process) + elemental module function quantum_numbers_are_hard_process & + (qn) result (hard_process) logical :: hard_process class(quantum_numbers_t), intent(in) :: qn hard_process = qn%f%is_hard_process () end function quantum_numbers_are_hard_process @ %def quantum_numbers_are_hard_process @ \subsection{Comparisons} Matching and equality is derived from the individual quantum numbers. The variant [[fhmatch]] matches only flavor and helicity. The variant [[dhmatch]] matches only diagonal helicity, if the matching helicity is undefined. <>= public :: quantum_numbers_eq_wo_sub <>= generic :: operator(.match.) => quantum_numbers_match generic :: operator(.fmatch.) => quantum_numbers_match_f generic :: operator(.hmatch.) => quantum_numbers_match_h generic :: operator(.fhmatch.) => quantum_numbers_match_fh generic :: operator(.dhmatch.) => quantum_numbers_match_hel_diag generic :: operator(==) => quantum_numbers_eq generic :: operator(/=) => quantum_numbers_neq procedure, private :: quantum_numbers_match procedure, private :: quantum_numbers_match_f procedure, private :: quantum_numbers_match_h procedure, private :: quantum_numbers_match_fh procedure, private :: quantum_numbers_match_hel_diag procedure, private :: quantum_numbers_eq procedure, private :: quantum_numbers_neq @ %def .match. == /= +<>= + elemental module function quantum_numbers_match (qn1, qn2) result (match) + logical :: match + class(quantum_numbers_t), intent(in) :: qn1, qn2 + end function quantum_numbers_match + elemental module function quantum_numbers_match_f (qn1, qn2) result (match) + logical :: match + class(quantum_numbers_t), intent(in) :: qn1, qn2 + end function quantum_numbers_match_f + elemental module function quantum_numbers_match_h (qn1, qn2) result (match) + logical :: match + class(quantum_numbers_t), intent(in) :: qn1, qn2 + end function quantum_numbers_match_h + elemental module function quantum_numbers_match_fh (qn1, qn2) result (match) + logical :: match + class(quantum_numbers_t), intent(in) :: qn1, qn2 + end function quantum_numbers_match_fh + elemental module function quantum_numbers_match_hel_diag (qn1, qn2) result (match) + logical :: match + class(quantum_numbers_t), intent(in) :: qn1, qn2 + end function quantum_numbers_match_hel_diag + elemental module function quantum_numbers_eq_wo_sub (qn1, qn2) result (eq) + logical :: eq + type(quantum_numbers_t), intent(in) :: qn1, qn2 + end function quantum_numbers_eq_wo_sub + elemental module function quantum_numbers_eq (qn1, qn2) result (eq) + logical :: eq + class(quantum_numbers_t), intent(in) :: qn1, qn2 + end function quantum_numbers_eq + elemental module function quantum_numbers_neq (qn1, qn2) result (neq) + logical :: neq + class(quantum_numbers_t), intent(in) :: qn1, qn2 + end function quantum_numbers_neq <>= - elemental function quantum_numbers_match (qn1, qn2) result (match) + elemental module function quantum_numbers_match (qn1, qn2) result (match) logical :: match class(quantum_numbers_t), intent(in) :: qn1, qn2 match = (qn1%f .match. qn2%f) .and. & (qn1%c .match. qn2%c) .and. & (qn1%h .match. qn2%h) end function quantum_numbers_match - elemental function quantum_numbers_match_f (qn1, qn2) result (match) + elemental module function quantum_numbers_match_f (qn1, qn2) result (match) logical :: match class(quantum_numbers_t), intent(in) :: qn1, qn2 match = (qn1%f .match. qn2%f) end function quantum_numbers_match_f - elemental function quantum_numbers_match_h (qn1, qn2) result (match) + elemental module function quantum_numbers_match_h (qn1, qn2) result (match) logical :: match class(quantum_numbers_t), intent(in) :: qn1, qn2 match = (qn1%h .match. qn2%h) end function quantum_numbers_match_h - elemental function quantum_numbers_match_fh (qn1, qn2) result (match) + elemental module function quantum_numbers_match_fh (qn1, qn2) result (match) logical :: match class(quantum_numbers_t), intent(in) :: qn1, qn2 match = (qn1%f .match. qn2%f) .and. & (qn1%h .match. qn2%h) end function quantum_numbers_match_fh - elemental function quantum_numbers_match_hel_diag (qn1, qn2) result (match) + elemental module function quantum_numbers_match_hel_diag (qn1, qn2) result (match) logical :: match class(quantum_numbers_t), intent(in) :: qn1, qn2 match = (qn1%f .match. qn2%f) .and. & (qn1%c .match. qn2%c) .and. & (qn1%h .dmatch. qn2%h) end function quantum_numbers_match_hel_diag - elemental function quantum_numbers_eq_wo_sub (qn1, qn2) result (eq) + elemental module function quantum_numbers_eq_wo_sub (qn1, qn2) result (eq) logical :: eq type(quantum_numbers_t), intent(in) :: qn1, qn2 eq = (qn1%f == qn2%f) .and. & (qn1%c == qn2%c) .and. & (qn1%h == qn2%h) end function quantum_numbers_eq_wo_sub - elemental function quantum_numbers_eq (qn1, qn2) result (eq) + elemental module function quantum_numbers_eq (qn1, qn2) result (eq) logical :: eq class(quantum_numbers_t), intent(in) :: qn1, qn2 eq = (qn1%f == qn2%f) .and. & (qn1%c == qn2%c) .and. & (qn1%h == qn2%h) .and. & (qn1%sub == qn2%sub) end function quantum_numbers_eq - elemental function quantum_numbers_neq (qn1, qn2) result (neq) + elemental module function quantum_numbers_neq (qn1, qn2) result (neq) logical :: neq class(quantum_numbers_t), intent(in) :: qn1, qn2 neq = (qn1%f /= qn2%f) .or. & (qn1%c /= qn2%c) .or. & (qn1%h /= qn2%h) .or. & (qn1%sub /= qn2%sub) end function quantum_numbers_neq @ %def quantum_numbers_match @ %def quantum_numbers_eq @ %def quantum_numbers_neq <>= public :: assignment(=) <>= interface assignment(=) module procedure quantum_numbers_assign end interface +<>= + module subroutine quantum_numbers_assign (qn_out, qn_in) + type(quantum_numbers_t), intent(out) :: qn_out + type(quantum_numbers_t), intent(in) :: qn_in + end subroutine quantum_numbers_assign <>= - subroutine quantum_numbers_assign (qn_out, qn_in) + module subroutine quantum_numbers_assign (qn_out, qn_in) type(quantum_numbers_t), intent(out) :: qn_out type(quantum_numbers_t), intent(in) :: qn_in qn_out%f = qn_in%f qn_out%c = qn_in%c qn_out%h = qn_in%h qn_out%sub = qn_in%sub end subroutine quantum_numbers_assign @ %def quantum_numbers_assign @ Two sets of quantum numbers are compatible if the individual quantum numbers are compatible, depending on the mask. Flavor has to match, regardless of the flavor mask. If the color flag is set, color is compatible if the ghost property is identical. If the color flag is unset, color has to be identical. I.e., if the flag is set, the color amplitudes can interfere. If it is not set, they must be identical, and there must be no ghost. The latter property is used for expanding physical color flows. Helicity is compatible if the mask is unset, otherwise it has to match. This determines if two amplitudes can be multiplied (no mask) or traced (mask). <>= public :: quantum_numbers_are_compatible +<>= + elemental module function quantum_numbers_are_compatible & + (qn1, qn2, mask) result (flag) + logical :: flag + type(quantum_numbers_t), intent(in) :: qn1, qn2 + type(quantum_numbers_mask_t), intent(in) :: mask + end function quantum_numbers_are_compatible <>= - elemental function quantum_numbers_are_compatible (qn1, qn2, mask) & - result (flag) + elemental module function quantum_numbers_are_compatible & + (qn1, qn2, mask) result (flag) logical :: flag type(quantum_numbers_t), intent(in) :: qn1, qn2 type(quantum_numbers_mask_t), intent(in) :: mask if (mask%h .or. mask%hd) then flag = (qn1%f .match. qn2%f) .and. (qn1%h .match. qn2%h) else flag = (qn1%f .match. qn2%f) end if if (mask%c) then flag = flag .and. (qn1%c%is_ghost () .eqv. qn2%c%is_ghost ()) else flag = flag .and. & .not. (qn1%c%is_ghost () .or. qn2%c%is_ghost ()) .and. & (qn1%c == qn2%c) end if end function quantum_numbers_are_compatible @ %def quantum_numbers_are_compatible @ This is the analog for a single quantum-number set. We just check for color ghosts; they are excluded if the color mask is unset (color-flow expansion). <>= public :: quantum_numbers_are_physical +<>= + elemental module function quantum_numbers_are_physical (qn, mask) result (flag) + logical :: flag + type(quantum_numbers_t), intent(in) :: qn + type(quantum_numbers_mask_t), intent(in) :: mask + end function quantum_numbers_are_physical <>= - elemental function quantum_numbers_are_physical (qn, mask) result (flag) + elemental module function quantum_numbers_are_physical (qn, mask) result (flag) logical :: flag type(quantum_numbers_t), intent(in) :: qn type(quantum_numbers_mask_t), intent(in) :: mask if (mask%c) then flag = .true. else flag = .not. qn%c%is_ghost () end if end function quantum_numbers_are_physical @ %def quantum_numbers_are_physical @ \subsection{Operations} Inherited from the color component: reassign color indices in canonical order. <>= public :: quantum_numbers_canonicalize_color +<>= + module subroutine quantum_numbers_canonicalize_color (qn) + type(quantum_numbers_t), dimension(:), intent(inout) :: qn + end subroutine quantum_numbers_canonicalize_color <>= - subroutine quantum_numbers_canonicalize_color (qn) + module subroutine quantum_numbers_canonicalize_color (qn) type(quantum_numbers_t), dimension(:), intent(inout) :: qn call color_canonicalize (qn%c) end subroutine quantum_numbers_canonicalize_color @ %def quantum_numbers_canonicalize_color @ Inherited from the color component: make a color map for two matching quantum-number arrays. <>= public :: make_color_map <>= interface make_color_map module procedure quantum_numbers_make_color_map end interface make_color_map +<>= + module subroutine quantum_numbers_make_color_map (map, qn1, qn2) + integer, dimension(:,:), intent(out), allocatable :: map + type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2 + end subroutine quantum_numbers_make_color_map <>= - subroutine quantum_numbers_make_color_map (map, qn1, qn2) + module subroutine quantum_numbers_make_color_map (map, qn1, qn2) integer, dimension(:,:), intent(out), allocatable :: map type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2 call make_color_map (map, qn1%c, qn2%c) end subroutine quantum_numbers_make_color_map @ %def make_color_map @ Inherited from the color component: translate the color part using a color-map array <>= public :: quantum_numbers_translate_color <>= interface quantum_numbers_translate_color module procedure quantum_numbers_translate_color0 module procedure quantum_numbers_translate_color1 end interface +<>= + module subroutine quantum_numbers_translate_color0 (qn, map, offset) + type(quantum_numbers_t), intent(inout) :: qn + integer, dimension(:,:), intent(in) :: map + integer, intent(in), optional :: offset + end subroutine quantum_numbers_translate_color0 + module subroutine quantum_numbers_translate_color1 (qn, map, offset) + type(quantum_numbers_t), dimension(:), intent(inout) :: qn + integer, dimension(:,:), intent(in) :: map + integer, intent(in), optional :: offset + end subroutine quantum_numbers_translate_color1 <>= - subroutine quantum_numbers_translate_color0 (qn, map, offset) + module subroutine quantum_numbers_translate_color0 (qn, map, offset) type(quantum_numbers_t), intent(inout) :: qn integer, dimension(:,:), intent(in) :: map integer, intent(in), optional :: offset call color_translate (qn%c, map, offset) end subroutine quantum_numbers_translate_color0 - subroutine quantum_numbers_translate_color1 (qn, map, offset) + module subroutine quantum_numbers_translate_color1 (qn, map, offset) type(quantum_numbers_t), dimension(:), intent(inout) :: qn integer, dimension(:,:), intent(in) :: map integer, intent(in), optional :: offset call color_translate (qn%c, map, offset) end subroutine quantum_numbers_translate_color1 @ %def quantum_numbers_translate_color @ Inherited from the color component: return the color index with highest absolute value. Since the algorithm is not elemental, we keep the separate procedures for different array rank. <>= public :: quantum_numbers_get_max_color_value <>= interface quantum_numbers_get_max_color_value module procedure quantum_numbers_get_max_color_value0 module procedure quantum_numbers_get_max_color_value1 module procedure quantum_numbers_get_max_color_value2 end interface +<>= + pure module function quantum_numbers_get_max_color_value0 (qn) result (cmax) + integer :: cmax + type(quantum_numbers_t), intent(in) :: qn + end function quantum_numbers_get_max_color_value0 + pure module function quantum_numbers_get_max_color_value1 (qn) result (cmax) + integer :: cmax + type(quantum_numbers_t), dimension(:), intent(in) :: qn + end function quantum_numbers_get_max_color_value1 + pure module function quantum_numbers_get_max_color_value2 (qn) result (cmax) + integer :: cmax + type(quantum_numbers_t), dimension(:,:), intent(in) :: qn + end function quantum_numbers_get_max_color_value2 <>= - pure function quantum_numbers_get_max_color_value0 (qn) result (cmax) + pure module function quantum_numbers_get_max_color_value0 (qn) result (cmax) integer :: cmax type(quantum_numbers_t), intent(in) :: qn cmax = color_get_max_value (qn%c) end function quantum_numbers_get_max_color_value0 - pure function quantum_numbers_get_max_color_value1 (qn) result (cmax) + pure module function quantum_numbers_get_max_color_value1 (qn) result (cmax) integer :: cmax type(quantum_numbers_t), dimension(:), intent(in) :: qn cmax = color_get_max_value (qn%c) end function quantum_numbers_get_max_color_value1 - pure function quantum_numbers_get_max_color_value2 (qn) result (cmax) + pure module function quantum_numbers_get_max_color_value2 (qn) result (cmax) integer :: cmax type(quantum_numbers_t), dimension(:,:), intent(in) :: qn cmax = color_get_max_value (qn%c) end function quantum_numbers_get_max_color_value2 @ Inherited from the color component: add an offset to the indices of the color part <>= procedure :: add_color_offset => quantum_numbers_add_color_offset +<>= + elemental module subroutine quantum_numbers_add_color_offset (qn, offset) + class(quantum_numbers_t), intent(inout) :: qn + integer, intent(in) :: offset + end subroutine quantum_numbers_add_color_offset <>= - elemental subroutine quantum_numbers_add_color_offset (qn, offset) + elemental module subroutine quantum_numbers_add_color_offset (qn, offset) class(quantum_numbers_t), intent(inout) :: qn integer, intent(in) :: offset call qn%c%add_offset (offset) end subroutine quantum_numbers_add_color_offset @ %def quantum_numbers_add_color_offset @ Given a quantum number array, return all possible color contractions, leaving the other quantum numbers intact. <>= public :: quantum_number_array_make_color_contractions +<>= + module subroutine quantum_number_array_make_color_contractions (qn_in, qn_out) + type(quantum_numbers_t), dimension(:), intent(in) :: qn_in + type(quantum_numbers_t), dimension(:,:), intent(out), allocatable :: qn_out + end subroutine quantum_number_array_make_color_contractions <>= - subroutine quantum_number_array_make_color_contractions (qn_in, qn_out) + module subroutine quantum_number_array_make_color_contractions (qn_in, qn_out) type(quantum_numbers_t), dimension(:), intent(in) :: qn_in type(quantum_numbers_t), dimension(:,:), intent(out), allocatable :: qn_out type(color_t), dimension(:,:), allocatable :: col integer :: i call color_array_make_contractions (qn_in%c, col) allocate (qn_out (size (col, 1), size (col, 2))) do i = 1, size (qn_out, 2) qn_out(:,i)%f = qn_in%f qn_out(:,i)%c = col(:,i) qn_out(:,i)%h = qn_in%h end do end subroutine quantum_number_array_make_color_contractions @ %def quantum_number_array_make_color_contractions @ Inherited from the color component: invert the color, switching particle/antiparticle. <>= procedure :: invert_color => quantum_numbers_invert_color +<>= + elemental module subroutine quantum_numbers_invert_color (qn) + class(quantum_numbers_t), intent(inout) :: qn + end subroutine quantum_numbers_invert_color <>= - elemental subroutine quantum_numbers_invert_color (qn) + elemental module subroutine quantum_numbers_invert_color (qn) class(quantum_numbers_t), intent(inout) :: qn call qn%c%invert () end subroutine quantum_numbers_invert_color @ %def quantum_numbers_invert_color @ Flip helicity. <>= procedure :: flip_helicity => quantum_numbers_flip_helicity +<>= + elemental module subroutine quantum_numbers_flip_helicity (qn) + class(quantum_numbers_t), intent(inout) :: qn + end subroutine quantum_numbers_flip_helicity <>= - elemental subroutine quantum_numbers_flip_helicity (qn) + elemental module subroutine quantum_numbers_flip_helicity (qn) class(quantum_numbers_t), intent(inout) :: qn call qn%h%flip () end subroutine quantum_numbers_flip_helicity @ %def quantum_numbers_flip_helicity @ Merge two quantum number sets: for each entry, if both are defined, combine them to an off-diagonal entry (meaningful only if the input was diagonal). If either entry is undefined, take the defined one. For flavor, off-diagonal entries are invalid, so both flavors must be equal, otherwise an invalid flavor is inserted. <>= public :: operator(.merge.) <>= interface operator(.merge.) module procedure merge_quantum_numbers0 module procedure merge_quantum_numbers1 end interface +<>= + module function merge_quantum_numbers0 (qn1, qn2) result (qn3) + type(quantum_numbers_t) :: qn3 + type(quantum_numbers_t), intent(in) :: qn1, qn2 + end function merge_quantum_numbers0 + module function merge_quantum_numbers1 (qn1, qn2) result (qn3) + type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2 + type(quantum_numbers_t), dimension(size(qn1)) :: qn3 + end function merge_quantum_numbers1 <>= - function merge_quantum_numbers0 (qn1, qn2) result (qn3) + module function merge_quantum_numbers0 (qn1, qn2) result (qn3) type(quantum_numbers_t) :: qn3 type(quantum_numbers_t), intent(in) :: qn1, qn2 qn3%f = qn1%f .merge. qn2%f qn3%c = qn1%c .merge. qn2%c qn3%h = qn1%h .merge. qn2%h qn3%sub = merge_subtraction_index (qn1%sub, qn2%sub) end function merge_quantum_numbers0 - function merge_quantum_numbers1 (qn1, qn2) result (qn3) + module function merge_quantum_numbers1 (qn1, qn2) result (qn3) type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2 type(quantum_numbers_t), dimension(size(qn1)) :: qn3 qn3%f = qn1%f .merge. qn2%f qn3%c = qn1%c .merge. qn2%c qn3%h = qn1%h .merge. qn2%h qn3%sub = merge_subtraction_index (qn1%sub, qn2%sub) end function merge_quantum_numbers1 @ %def merge_quantum_numbers @ <>= elemental function merge_subtraction_index (sub1, sub2) result (sub3) integer :: sub3 integer, intent(in) :: sub1, sub2 if (sub1 > 0 .and. sub2 > 0) then if (sub1 == sub2) then sub3 = sub1 else sub3 = 0 end if else if (sub1 > 0) then sub3 = sub1 else if (sub2 > 0) then sub3 = sub2 else sub3 = 0 end if end function merge_subtraction_index @ %def merge_subtraction_index @ \subsection{The quantum number mask} The quantum numbers mask is true for quantum numbers that should be ignored or summed over. The three mandatory entries correspond to flavor, color, and helicity, respectively. There is an additional entry [[cg]]: If false, the color-ghosts property should be kept even if color is ignored. This is relevant only if [[c]] is set, otherwise it is always false. The flag [[hd]] tells that only diagonal entries in helicity should be kept. If [[h]] is set, [[hd]] is irrelevant and will be kept [[.false.]] <>= public :: quantum_numbers_mask_t <>= type :: quantum_numbers_mask_t private logical :: f = .false. logical :: c = .false. logical :: cg = .false. logical :: h = .false. logical :: hd = .false. integer :: sub = 0 contains <> end type quantum_numbers_mask_t @ %def quantum_number_t @ Define a quantum number mask: Constructor form <>= public :: quantum_numbers_mask +<>= + elemental module function quantum_numbers_mask & + (mask_f, mask_c, mask_h, mask_cg, mask_hd) result (mask) + type(quantum_numbers_mask_t) :: mask + logical, intent(in) :: mask_f, mask_c, mask_h + logical, intent(in), optional :: mask_cg + logical, intent(in), optional :: mask_hd + end function quantum_numbers_mask <>= - elemental function quantum_numbers_mask & + elemental module function quantum_numbers_mask & (mask_f, mask_c, mask_h, mask_cg, mask_hd) result (mask) type(quantum_numbers_mask_t) :: mask logical, intent(in) :: mask_f, mask_c, mask_h logical, intent(in), optional :: mask_cg logical, intent(in), optional :: mask_hd call quantum_numbers_mask_init & (mask, mask_f, mask_c, mask_h, mask_cg, mask_hd) end function quantum_numbers_mask @ %def new_quantum_numbers_mask @ Define quantum numbers: Initializer form <>= procedure :: init => quantum_numbers_mask_init +<>= + elemental module subroutine quantum_numbers_mask_init & + (mask, mask_f, mask_c, mask_h, mask_cg, mask_hd) + class(quantum_numbers_mask_t), intent(inout) :: mask + logical, intent(in) :: mask_f, mask_c, mask_h + logical, intent(in), optional :: mask_cg, mask_hd + end subroutine quantum_numbers_mask_init <>= - elemental subroutine quantum_numbers_mask_init & + elemental module subroutine quantum_numbers_mask_init & (mask, mask_f, mask_c, mask_h, mask_cg, mask_hd) class(quantum_numbers_mask_t), intent(inout) :: mask logical, intent(in) :: mask_f, mask_c, mask_h logical, intent(in), optional :: mask_cg, mask_hd mask%f = mask_f mask%c = mask_c mask%h = mask_h mask%cg = .false. if (present (mask_cg)) then if (mask%c) mask%cg = mask_cg else mask%cg = mask_c end if mask%hd = .false. if (present (mask_hd)) then if (.not. mask%h) mask%hd = mask_hd end if end subroutine quantum_numbers_mask_init @ %def quantum_numbers_mask_init @ Write a quantum numbers mask. We need the stand-alone subroutine for the array case. <>= public :: quantum_numbers_mask_write <>= interface quantum_numbers_mask_write module procedure quantum_numbers_mask_write_single module procedure quantum_numbers_mask_write_array end interface <>= procedure :: write => quantum_numbers_mask_write_single +<>= + module subroutine quantum_numbers_mask_write_single (mask, unit) + class(quantum_numbers_mask_t), intent(in) :: mask + integer, intent(in), optional :: unit + end subroutine quantum_numbers_mask_write_single + module subroutine quantum_numbers_mask_write_array (mask, unit) + type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask + integer, intent(in), optional :: unit + end subroutine quantum_numbers_mask_write_array <>= - subroutine quantum_numbers_mask_write_single (mask, unit) + module subroutine quantum_numbers_mask_write_single (mask, unit) class(quantum_numbers_mask_t), intent(in) :: mask integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(A)", advance="no") "[" write (u, "(L1)", advance="no") mask%f write (u, "(L1)", advance="no") mask%c if (.not.mask%cg) write (u, "('g')", advance="no") write (u, "(L1)", advance="no") mask%h if (mask%hd) write (u, "('d')", advance="no") write (u, "(A)", advance="no") "]" end subroutine quantum_numbers_mask_write_single - subroutine quantum_numbers_mask_write_array (mask, unit) + module subroutine quantum_numbers_mask_write_array (mask, unit) type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(A)", advance="no") "[" do i = 1, size (mask) if (i > 1) write (u, "(A)", advance="no") "/" write (u, "(L1)", advance="no") mask(i)%f write (u, "(L1)", advance="no") mask(i)%c if (.not.mask(i)%cg) write (u, "('g')", advance="no") write (u, "(L1)", advance="no") mask(i)%h if (mask(i)%hd) write (u, "('d')", advance="no") end do write (u, "(A)", advance="no") "]" end subroutine quantum_numbers_mask_write_array @ %def quantum_numbers_mask_write @ \subsection{Setting mask components} <>= procedure :: set_flavor => quantum_numbers_mask_set_flavor procedure :: set_color => quantum_numbers_mask_set_color procedure :: set_helicity => quantum_numbers_mask_set_helicity procedure :: set_sub => quantum_numbers_mask_set_sub +<>= + elemental module subroutine quantum_numbers_mask_set_flavor (mask, mask_f) + class(quantum_numbers_mask_t), intent(inout) :: mask + logical, intent(in) :: mask_f + end subroutine quantum_numbers_mask_set_flavor + elemental module subroutine quantum_numbers_mask_set_color (mask, mask_c, mask_cg) + class(quantum_numbers_mask_t), intent(inout) :: mask + logical, intent(in) :: mask_c + logical, intent(in), optional :: mask_cg + end subroutine quantum_numbers_mask_set_color + elemental module subroutine quantum_numbers_mask_set_helicity (mask, mask_h, mask_hd) + class(quantum_numbers_mask_t), intent(inout) :: mask + logical, intent(in) :: mask_h + logical, intent(in), optional :: mask_hd + end subroutine quantum_numbers_mask_set_helicity + elemental module subroutine quantum_numbers_mask_set_sub (mask, sub) + class(quantum_numbers_mask_t), intent(inout) :: mask + integer, intent(in) :: sub + end subroutine quantum_numbers_mask_set_sub <>= - elemental subroutine quantum_numbers_mask_set_flavor (mask, mask_f) + elemental module subroutine quantum_numbers_mask_set_flavor (mask, mask_f) class(quantum_numbers_mask_t), intent(inout) :: mask logical, intent(in) :: mask_f mask%f = mask_f end subroutine quantum_numbers_mask_set_flavor - elemental subroutine quantum_numbers_mask_set_color (mask, mask_c, mask_cg) + elemental module subroutine quantum_numbers_mask_set_color (mask, mask_c, mask_cg) class(quantum_numbers_mask_t), intent(inout) :: mask logical, intent(in) :: mask_c logical, intent(in), optional :: mask_cg mask%c = mask_c if (present (mask_cg)) then if (mask%c) mask%cg = mask_cg else mask%cg = mask_c end if end subroutine quantum_numbers_mask_set_color - elemental subroutine quantum_numbers_mask_set_helicity (mask, mask_h, mask_hd) + elemental module subroutine quantum_numbers_mask_set_helicity (mask, mask_h, mask_hd) class(quantum_numbers_mask_t), intent(inout) :: mask logical, intent(in) :: mask_h logical, intent(in), optional :: mask_hd mask%h = mask_h if (present (mask_hd)) then if (.not. mask%h) mask%hd = mask_hd end if end subroutine quantum_numbers_mask_set_helicity - elemental subroutine quantum_numbers_mask_set_sub (mask, sub) + elemental module subroutine quantum_numbers_mask_set_sub (mask, sub) class(quantum_numbers_mask_t), intent(inout) :: mask integer, intent(in) :: sub mask%sub = sub end subroutine quantum_numbers_mask_set_sub @ %def quantum_numbers_mask_set_flavor @ %def quantum_numbers_mask_set_color @ %def quantum_numbers_mask_set_helicity @ %def quantum_numbers_mask_set_sub @ The following routines assign part of a mask, depending on the flags given. <>= procedure :: assign => quantum_numbers_mask_assign +<>= + elemental module subroutine quantum_numbers_mask_assign & + (mask, mask_in, flavor, color, helicity) + class(quantum_numbers_mask_t), intent(inout) :: mask + class(quantum_numbers_mask_t), intent(in) :: mask_in + logical, intent(in), optional :: flavor, color, helicity + end subroutine quantum_numbers_mask_assign <>= - elemental subroutine quantum_numbers_mask_assign & + elemental module subroutine quantum_numbers_mask_assign & (mask, mask_in, flavor, color, helicity) class(quantum_numbers_mask_t), intent(inout) :: mask class(quantum_numbers_mask_t), intent(in) :: mask_in logical, intent(in), optional :: flavor, color, helicity if (present (flavor)) then if (flavor) then mask%f = mask_in%f end if end if if (present (color)) then if (color) then mask%c = mask_in%c mask%cg = mask_in%cg end if end if if (present (helicity)) then if (helicity) then mask%h = mask_in%h mask%hd = mask_in%hd end if end if end subroutine quantum_numbers_mask_assign @ %def quantum_numbers_mask_assign @ \subsection{Mask predicates} Return true if either one of the entries is set: <>= public :: any <>= interface any module procedure quantum_numbers_mask_any end interface +<>= + module function quantum_numbers_mask_any (mask) result (match) + logical :: match + type(quantum_numbers_mask_t), intent(in) :: mask + end function quantum_numbers_mask_any <>= - function quantum_numbers_mask_any (mask) result (match) + module function quantum_numbers_mask_any (mask) result (match) logical :: match type(quantum_numbers_mask_t), intent(in) :: mask match = mask%f .or. mask%c .or. mask%h .or. mask%hd end function quantum_numbers_mask_any @ %def any @ \subsection{Operators} The OR operation is applied to all components. <>= generic :: operator(.or.) => quantum_numbers_mask_or procedure, private :: quantum_numbers_mask_or @ %def .or. +<>= + elemental module function quantum_numbers_mask_or (mask1, mask2) result (mask) + type(quantum_numbers_mask_t) :: mask + class(quantum_numbers_mask_t), intent(in) :: mask1, mask2 + end function quantum_numbers_mask_or <>= - elemental function quantum_numbers_mask_or (mask1, mask2) result (mask) + elemental module function quantum_numbers_mask_or (mask1, mask2) result (mask) type(quantum_numbers_mask_t) :: mask class(quantum_numbers_mask_t), intent(in) :: mask1, mask2 mask%f = mask1%f .or. mask2%f mask%c = mask1%c .or. mask2%c if (mask%c) mask%cg = mask1%cg .or. mask2%cg mask%h = mask1%h .or. mask2%h if (.not. mask%h) mask%hd = mask1%hd .or. mask2%hd end function quantum_numbers_mask_or @ %def quantum_numbers_mask_or @ \subsection{Mask comparisons} Return true if the two masks are equivalent / differ: <>= generic :: operator(.eqv.) => quantum_numbers_mask_eqv generic :: operator(.neqv.) => quantum_numbers_mask_neqv procedure, private :: quantum_numbers_mask_eqv procedure, private :: quantum_numbers_mask_neqv +<>= + elemental module function quantum_numbers_mask_eqv (mask1, mask2) result (eqv) + logical :: eqv + class(quantum_numbers_mask_t), intent(in) :: mask1, mask2 + end function quantum_numbers_mask_eqv + elemental module function quantum_numbers_mask_neqv (mask1, mask2) result (neqv) + logical :: neqv + class(quantum_numbers_mask_t), intent(in) :: mask1, mask2 + end function quantum_numbers_mask_neqv <>= - elemental function quantum_numbers_mask_eqv (mask1, mask2) result (eqv) + elemental module function quantum_numbers_mask_eqv (mask1, mask2) result (eqv) logical :: eqv class(quantum_numbers_mask_t), intent(in) :: mask1, mask2 eqv = (mask1%f .eqv. mask2%f) .and. & (mask1%c .eqv. mask2%c) .and. & (mask1%cg .eqv. mask2%cg) .and. & (mask1%h .eqv. mask2%h) .and. & (mask1%hd .eqv. mask2%hd) end function quantum_numbers_mask_eqv - elemental function quantum_numbers_mask_neqv (mask1, mask2) result (neqv) + elemental module function quantum_numbers_mask_neqv (mask1, mask2) result (neqv) logical :: neqv class(quantum_numbers_mask_t), intent(in) :: mask1, mask2 neqv = (mask1%f .neqv. mask2%f) .or. & (mask1%c .neqv. mask2%c) .or. & (mask1%cg .neqv. mask2%cg) .or. & (mask1%h .neqv. mask2%h) .or. & (mask1%hd .neqv. mask2%hd) end function quantum_numbers_mask_neqv @ %def .eqv. .neqv. @ \subsection{Apply a mask} Applying a mask to the quantum number object means undefining those entries where the mask is set. The others remain unaffected. The [[hd]] mask has the special property that it ``diagonalizes'' helicity, i.e., the second helicity entry is dropped and the result is a diagonal helicity quantum number. <>= procedure :: undefine => quantum_numbers_undefine procedure :: undefined => quantum_numbers_undefined0 <>= public :: quantum_numbers_undefined <>= interface quantum_numbers_undefined module procedure quantum_numbers_undefined0 module procedure quantum_numbers_undefined1 module procedure quantum_numbers_undefined11 end interface +<>= + elemental module subroutine quantum_numbers_undefine (qn, mask) + class(quantum_numbers_t), intent(inout) :: qn + type(quantum_numbers_mask_t), intent(in) :: mask + end subroutine quantum_numbers_undefine + module function quantum_numbers_undefined0 (qn, mask) result (qn_new) + class(quantum_numbers_t), intent(in) :: qn + type(quantum_numbers_mask_t), intent(in) :: mask + type(quantum_numbers_t) :: qn_new + end function quantum_numbers_undefined0 + module function quantum_numbers_undefined1 (qn, mask) result (qn_new) + type(quantum_numbers_t), dimension(:), intent(in) :: qn + type(quantum_numbers_mask_t), intent(in) :: mask + type(quantum_numbers_t), dimension(size(qn)) :: qn_new + end function quantum_numbers_undefined1 + module function quantum_numbers_undefined11 (qn, mask) result (qn_new) + type(quantum_numbers_t), dimension(:), intent(in) :: qn + type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask + type(quantum_numbers_t), dimension(size(qn)) :: qn_new + end function quantum_numbers_undefined11 <>= - elemental subroutine quantum_numbers_undefine (qn, mask) + elemental module subroutine quantum_numbers_undefine (qn, mask) class(quantum_numbers_t), intent(inout) :: qn type(quantum_numbers_mask_t), intent(in) :: mask if (mask%f) call qn%f%undefine () if (mask%c) call qn%c%undefine (undefine_ghost = mask%cg) if (mask%h) then call qn%h%undefine () else if (mask%hd) then if (.not. qn%h%is_diagonal ()) then call qn%h%diagonalize () end if end if if (mask%sub > 0) qn%sub = 0 end subroutine quantum_numbers_undefine - function quantum_numbers_undefined0 (qn, mask) result (qn_new) + module function quantum_numbers_undefined0 (qn, mask) result (qn_new) class(quantum_numbers_t), intent(in) :: qn type(quantum_numbers_mask_t), intent(in) :: mask type(quantum_numbers_t) :: qn_new select type (qn) type is (quantum_numbers_t); qn_new = qn end select call quantum_numbers_undefine (qn_new, mask) end function quantum_numbers_undefined0 - function quantum_numbers_undefined1 (qn, mask) result (qn_new) + module function quantum_numbers_undefined1 (qn, mask) result (qn_new) type(quantum_numbers_t), dimension(:), intent(in) :: qn type(quantum_numbers_mask_t), intent(in) :: mask type(quantum_numbers_t), dimension(size(qn)) :: qn_new qn_new = qn call quantum_numbers_undefine (qn_new, mask) end function quantum_numbers_undefined1 - function quantum_numbers_undefined11 (qn, mask) result (qn_new) + module function quantum_numbers_undefined11 (qn, mask) result (qn_new) type(quantum_numbers_t), dimension(:), intent(in) :: qn type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask type(quantum_numbers_t), dimension(size(qn)) :: qn_new qn_new = qn call quantum_numbers_undefine (qn_new, mask) end function quantum_numbers_undefined11 @ %def quantum_numbers_undefine @ %def quantum_numbers_undefined @ Return true if the input quantum number set has entries that would be removed by the applied mask, e.g., if polarization is defined but [[mask%h]] is set: <>= procedure :: are_redundant => quantum_numbers_are_redundant +<>= + elemental module function quantum_numbers_are_redundant (qn, mask) & + result (redundant) + logical :: redundant + class(quantum_numbers_t), intent(in) :: qn + type(quantum_numbers_mask_t), intent(in) :: mask + end function quantum_numbers_are_redundant <>= - elemental function quantum_numbers_are_redundant (qn, mask) & + elemental module function quantum_numbers_are_redundant (qn, mask) & result (redundant) logical :: redundant class(quantum_numbers_t), intent(in) :: qn type(quantum_numbers_mask_t), intent(in) :: mask redundant = .false. if (mask%f) then redundant = qn%f%is_defined () end if if (mask%c) then redundant = qn%c%is_defined () end if if (mask%h) then redundant = qn%h%is_defined () else if (mask%hd) then redundant = .not. qn%h%is_diagonal () end if if (mask%sub > 0) redundant = qn%sub >= mask%sub end function quantum_numbers_are_redundant @ %def quantum_numbers_are_redundant @ Return true if the helicity flag is set or the diagonal-helicity flag is set. <>= procedure :: diagonal_helicity => quantum_numbers_mask_diagonal_helicity +<>= + elemental module function quantum_numbers_mask_diagonal_helicity (mask) & + result (flag) + logical :: flag + class(quantum_numbers_mask_t), intent(in) :: mask + end function quantum_numbers_mask_diagonal_helicity <>= - elemental function quantum_numbers_mask_diagonal_helicity (mask) & + elemental module function quantum_numbers_mask_diagonal_helicity (mask) & result (flag) logical :: flag class(quantum_numbers_mask_t), intent(in) :: mask flag = mask%h .or. mask%hd end function quantum_numbers_mask_diagonal_helicity @ %def quantum_numbers_mask_diagonal_helicity @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Transition Matrices and Evaluation} The modules in this chapter implement transition matrices and calculations. The functionality is broken down in three modules \begin{description} \item[state\_matrices] represent state and transition density matrices built from particle quantum numbers (helicity, color, flavor) \item[interactions] extend state matrices with the record of particle momenta. They also distinguish in- and out-particles and store parent-child relations. \item[evaluators] These objects extend interaction objects by the information how to calculate matrix elements from products and squares of other interactions. They implement the methods to actually compute those matrix elements. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{State matrices} This module deals with the internal state of a particle system, i.e., with its density matrix in flavor, color, and helicity space. <<[[state_matrices.f90]]>>= <> module state_matrices <> - use constants, only: zero - use io_units - use format_utils, only: pac_fmt - use format_defs, only: FMT_17, FMT_19 - use diagnostics - use sorting use model_data use flavors use colors use helicities use quantum_numbers <> <> <> <> <> + interface +<> + end interface + +end module state_matrices +@ %def state_matrices +@ +<<[[state_matrices_sub.f90]]>>= +<> + +submodule (state_matrices) state_matrices_s + + use constants, only: zero + use format_utils, only: pac_fmt + use format_defs, only: FMT_17, FMT_19 + use io_units + use diagnostics + use sorting + + implicit none + contains <> -end module state_matrices -@ %def state_matrices +end submodule state_matrices_s + +@ %def state_matrices_s @ \subsection{Nodes of the quantum state trie} A quantum state object represents an unnormalized density matrix, i.e., an array of possibilities for flavor, color, and helicity indices with associated complex values. Physically, the trace of this matrix is the summed squared matrix element for an interaction, and the matrix elements divided by this value correspond to the flavor-color-helicity density matrix. (Flavor and color are diagonal.) We store density matrices as tries, that is, as trees where each branching represents the possible quantum numbers of a particle. The first branching is the first particle in the system. A leaf (the node corresponding to the last particle) contains the value of the matrix element. Each node contains a flavor, color, and helicity entry. Note that each of those entries may be actually undefined, so we can also represent, e.g., unpolarized particles. The value is meaningful only for leaves, which have no child nodes. There is a pointer to the parent node which allows for following the trie downwards from a leaf, it is null for a root node. The child nodes are implemented as a list, so there is a pointer to the first and last child, and each node also has a [[next]] pointer to the next sibling. The root node does not correspond to a particle, only its children do. The quantum numbers of the root node are irrelevant and will not be set. However, we use a common type for the three classes (root, branch, leaf); they may easily be distinguished by the association status of parent and child. \subsubsection{Node type} The node is linked in all directions: the parent, the first and last in the list of children, and the previous and next sibling. This allows us for adding and removing nodes and whole branches anywhere in the trie. (Circular links are not allowed, however.). The node holds its associated set of quantum numbers. The integer index, which is set only for leaf nodes, is the index of the corresponding matrix element value within the state matrix. Temporarily, matrix-element values may be stored within a leaf node. This is used during state-matrix factorization. When the state matrix is [[freeze]]d, these values are transferred to the matrix-element array within the host state matrix. <>= type :: node_t private type(quantum_numbers_t) :: qn type(node_t), pointer :: parent => null () type(node_t), pointer :: child_first => null () type(node_t), pointer :: child_last => null () type(node_t), pointer :: next => null () type(node_t), pointer :: previous => null () integer :: me_index = 0 integer, dimension(:), allocatable :: me_count complex(default) :: me = 0 end type node_t @ %def node_t @ \subsubsection{Operations on nodes} Recursively deallocate all children of the current node. This includes any values associated with the children. <>= pure recursive subroutine node_delete_offspring (node) type(node_t), pointer :: node type(node_t), pointer :: child child => node%child_first do while (associated (child)) node%child_first => node%child_first%next call node_delete_offspring (child) deallocate (child) child => node%child_first end do node%child_last => null () end subroutine node_delete_offspring @ %def node_delete_offspring @ Remove a node including its offspring. Adjust the pointers of parent and siblings, if necessary. <>= pure subroutine node_delete (node) type(node_t), pointer :: node call node_delete_offspring (node) if (associated (node%previous)) then node%previous%next => node%next else if (associated (node%parent)) then node%parent%child_first => node%next end if if (associated (node%next)) then node%next%previous => node%previous else if (associated (node%parent)) then node%parent%child_last => node%previous end if deallocate (node) end subroutine node_delete @ %def node_delete @ Append a child node <>= subroutine node_append_child (node, child) type(node_t), target, intent(inout) :: node type(node_t), pointer :: child allocate (child) if (associated (node%child_last)) then node%child_last%next => child child%previous => node%child_last else node%child_first => child end if node%child_last => child child%parent => node end subroutine node_append_child @ %def node_append_child @ \subsubsection{I/O} Output of a single node, no recursion. We print the quantum numbers in square brackets, then the value (if any). <>= subroutine node_write (node, me_array, verbose, unit, col_verbose, testflag) type(node_t), intent(in) :: node complex(default), dimension(:), intent(in), optional :: me_array logical, intent(in), optional :: verbose, col_verbose, testflag integer, intent(in), optional :: unit logical :: verb integer :: u character(len=7) :: fmt call pac_fmt (fmt, FMT_19, FMT_17, testflag) verb = .false.; if (present (verbose)) verb = verbose u = given_output_unit (unit); if (u < 0) return call node%qn%write (u, col_verbose) if (node%me_index /= 0) then write (u, "(A,I0,A)", advance="no") " => ME(", node%me_index, ")" if (present (me_array)) then write (u, "(A)", advance="no") " = " write (u, "('('," // fmt // ",','," // fmt // ",')')", & advance="no") pacify_complex (me_array(node%me_index)) end if end if write (u, *) if (verb) then call ptr_write ("parent ", node%parent) call ptr_write ("child_first", node%child_first) call ptr_write ("child_last ", node%child_last) call ptr_write ("next ", node%next) call ptr_write ("previous ", node%previous) end if contains subroutine ptr_write (label, node) character(*), intent(in) :: label type(node_t), pointer :: node if (associated (node)) then write (u, "(10x,A,1x,'->',1x)", advance="no") label call node%qn%write (u, col_verbose) write (u, *) end if end subroutine ptr_write end subroutine node_write @ %def node_write @ Recursive output of a node: <>= recursive subroutine node_write_rec (node, me_array, verbose, & indent, unit, col_verbose, testflag) type(node_t), intent(in), target :: node complex(default), dimension(:), intent(in), optional :: me_array logical, intent(in), optional :: verbose, col_verbose, testflag integer, intent(in), optional :: indent integer, intent(in), optional :: unit type(node_t), pointer :: current logical :: verb integer :: i, u verb = .false.; if (present (verbose)) verb = verbose i = 0; if (present (indent)) i = indent u = given_output_unit (unit); if (u < 0) return current => node%child_first do while (associated (current)) write (u, "(A)", advance="no") repeat (" ", i) call node_write (current, me_array, verbose = verb, & unit = u, col_verbose = col_verbose, testflag = testflag) call node_write_rec (current, me_array, verbose = verb, & indent = i + 2, unit = u, col_verbose = col_verbose, testflag = testflag) current => current%next end do end subroutine node_write_rec @ %def node_write_rec @ Binary I/O. Matrix elements are written only for leaf nodes. <>= recursive subroutine node_write_raw_rec (node, u) type(node_t), intent(in), target :: node integer, intent(in) :: u logical :: associated_child_first, associated_next call node%qn%write_raw (u) associated_child_first = associated (node%child_first) write (u) associated_child_first associated_next = associated (node%next) write (u) associated_next if (associated_child_first) then call node_write_raw_rec (node%child_first, u) else write (u) node%me_index write (u) node%me end if if (associated_next) then call node_write_raw_rec (node%next, u) end if end subroutine node_write_raw_rec recursive subroutine node_read_raw_rec (node, u, parent, iostat) type(node_t), intent(out), target :: node integer, intent(in) :: u type(node_t), intent(in), optional, target :: parent integer, intent(out), optional :: iostat logical :: associated_child_first, associated_next type(node_t), pointer :: child call node%qn%read_raw (u, iostat=iostat) read (u, iostat=iostat) associated_child_first read (u, iostat=iostat) associated_next if (present (parent)) node%parent => parent if (associated_child_first) then allocate (child) node%child_first => child node%child_last => null () call node_read_raw_rec (child, u, node, iostat=iostat) do while (associated (child)) child%previous => node%child_last node%child_last => child child => child%next end do else read (u, iostat=iostat) node%me_index read (u, iostat=iostat) node%me end if if (associated_next) then allocate (node%next) call node_read_raw_rec (node%next, u, parent, iostat=iostat) end if end subroutine node_read_raw_rec @ %def node_write_raw @ \subsection{State matrix} \subsubsection{Definition} The quantum state object is a container that keeps and hides the root node. For direct accessibility of values, they are stored in a separate array. The leaf nodes of the quantum-number tree point to those values, once the state matrix is finalized. The [[norm]] component is redefined if a common factor is extracted from all nodes. <>= public :: state_matrix_t <>= type :: state_matrix_t private type(node_t), pointer :: root => null () integer :: depth = 0 integer :: n_matrix_elements = 0 logical :: leaf_nodes_store_values = .false. integer :: n_counters = 0 complex(default), dimension(:), allocatable :: me real(default) :: norm = 1 integer :: n_sub = -1 contains <> end type state_matrix_t @ %def state_matrix_t @ This initializer allocates the root node but does not fill anything. We declare whether values are stored within the nodes during state-matrix construction, and how many counters should be maintained (default: none). <>= procedure :: init => state_matrix_init +<>= + module subroutine state_matrix_init (state, store_values, n_counters) + class(state_matrix_t), intent(out) :: state + logical, intent(in), optional :: store_values + integer, intent(in), optional :: n_counters + end subroutine state_matrix_init <>= - subroutine state_matrix_init (state, store_values, n_counters) + module subroutine state_matrix_init (state, store_values, n_counters) class(state_matrix_t), intent(out) :: state logical, intent(in), optional :: store_values integer, intent(in), optional :: n_counters allocate (state%root) if (present (store_values)) & state%leaf_nodes_store_values = store_values if (present (n_counters)) state%n_counters = n_counters end subroutine state_matrix_init @ %def state_matrix_init @ This recursively deletes all children of the root node, restoring the initial state. The matrix element array is not finalized, since it does not contain physical entries, just pointers. <>= procedure :: final => state_matrix_final +<>= + module subroutine state_matrix_final (state) + class(state_matrix_t), intent(inout) :: state + end subroutine state_matrix_final <>= - subroutine state_matrix_final (state) + module subroutine state_matrix_final (state) class(state_matrix_t), intent(inout) :: state if (allocated (state%me)) deallocate (state%me) if (associated (state%root)) call node_delete (state%root) state%depth = 0 state%n_matrix_elements = 0 end subroutine state_matrix_final @ %def state_matrix_final @ Output: Present the tree as a nested list with appropriate indentation. <>= procedure :: write => state_matrix_write +<>= + module subroutine state_matrix_write (state, unit, write_value_list, & + verbose, col_verbose, testflag) + class(state_matrix_t), intent(in) :: state + logical, intent(in), optional :: write_value_list, verbose, col_verbose + logical, intent(in), optional :: testflag + integer, intent(in), optional :: unit + end subroutine state_matrix_write <>= - subroutine state_matrix_write (state, unit, write_value_list, & + module subroutine state_matrix_write (state, unit, write_value_list, & verbose, col_verbose, testflag) class(state_matrix_t), intent(in) :: state logical, intent(in), optional :: write_value_list, verbose, col_verbose logical, intent(in), optional :: testflag integer, intent(in), optional :: unit complex(default) :: me_dum character(len=7) :: fmt integer :: u integer :: i call pac_fmt (fmt, FMT_19, FMT_17, testflag) u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A," // fmt // ")") "State matrix: norm = ", state%norm if (associated (state%root)) then if (allocated (state%me)) then call node_write_rec (state%root, state%me, verbose = verbose, & indent = 1, unit = u, col_verbose = col_verbose, & testflag = testflag) else call node_write_rec (state%root, verbose = verbose, indent = 1, & unit = u, col_verbose = col_verbose, testflag = testflag) end if end if if (present (write_value_list)) then if (write_value_list .and. allocated (state%me)) then do i = 1, size (state%me) write (u, "(1x,I0,A)", advance="no") i, ":" me_dum = state%me(i) if (real(state%me(i)) == -real(state%me(i))) then me_dum = & cmplx (0._default, aimag(me_dum), kind=default) end if if (aimag(me_dum) == -aimag(me_dum)) then me_dum = & cmplx (real(me_dum), 0._default, kind=default) end if write (u, "('('," // fmt // ",','," // fmt // & ",')')") me_dum end do end if end if end subroutine state_matrix_write @ %def state_matrix_write @ Binary I/O. The auxiliary matrix-element array is not written, but reconstructed after reading the tree. Note: To be checked. Might be broken, don't use (unless trivial). <>= procedure :: write_raw => state_matrix_write_raw procedure :: read_raw => state_matrix_read_raw +<>= + module subroutine state_matrix_write_raw (state, u) + class(state_matrix_t), intent(in), target :: state + integer, intent(in) :: u + end subroutine state_matrix_write_raw + module subroutine state_matrix_read_raw (state, u, iostat) + class(state_matrix_t), intent(out) :: state + integer, intent(in) :: u + integer, intent(out) :: iostat + end subroutine state_matrix_read_raw <>= - subroutine state_matrix_write_raw (state, u) + module subroutine state_matrix_write_raw (state, u) class(state_matrix_t), intent(in), target :: state integer, intent(in) :: u logical :: is_defined integer :: depth, j type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:), allocatable :: qn is_defined = state%is_defined () write (u) is_defined if (is_defined) then write (u) state%get_norm () write (u) state%get_n_leaves () depth = state%get_depth () write (u) depth allocate (qn (depth)) call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () do j = 1, depth call qn(j)%write_raw (u) end do write (u) it%get_me_index () write (u) it%get_matrix_element () call it%advance () end do end if end subroutine state_matrix_write_raw - subroutine state_matrix_read_raw (state, u, iostat) + module subroutine state_matrix_read_raw (state, u, iostat) class(state_matrix_t), intent(out) :: state integer, intent(in) :: u integer, intent(out) :: iostat logical :: is_defined real(default) :: norm integer :: n_leaves, depth, i, j type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: me_index complex(default) :: me read (u, iostat=iostat) is_defined if (iostat /= 0) goto 1 if (is_defined) then call state%init (store_values = .true.) read (u, iostat=iostat) norm if (iostat /= 0) goto 1 call state_matrix_set_norm (state, norm) read (u) n_leaves if (iostat /= 0) goto 1 read (u) depth if (iostat /= 0) goto 1 allocate (qn (depth)) do i = 1, n_leaves do j = 1, depth call qn(j)%read_raw (u, iostat=iostat) if (iostat /= 0) goto 1 end do read (u, iostat=iostat) me_index if (iostat /= 0) goto 1 read (u, iostat=iostat) me if (iostat /= 0) goto 1 call state%add_state (qn, index = me_index, value = me) end do call state_matrix_freeze (state) end if return ! Clean up on error 1 continue call state%final () end subroutine state_matrix_read_raw @ %def state_matrix_write_raw state_matrix_read_raw @ Assign a model pointer to all flavor entries. This will become necessary when we have read a state matrix from file. <>= procedure :: set_model => state_matrix_set_model +<>= + module subroutine state_matrix_set_model (state, model) + class(state_matrix_t), intent(inout), target :: state + class(model_data_t), intent(in), target :: model + end subroutine state_matrix_set_model <>= - subroutine state_matrix_set_model (state, model) + module subroutine state_matrix_set_model (state, model) class(state_matrix_t), intent(inout), target :: state class(model_data_t), intent(in), target :: model type(state_iterator_t) :: it call it%init (state) do while (it%is_valid ()) call it%set_model (model) call it%advance () end do end subroutine state_matrix_set_model @ %def state_matrix_set_model @ Iterate over [[state]], get the quantum numbers array [[qn]] for each iteration, and tag all array elements of [[qn]] with the indizes given by [[tag]] as part of the hard interaction. Then add them to [[tagged_state]] and return it. If no [[tag]] is given, tag all [[qn]] as part of the hard process. <>= procedure :: tag_hard_process => state_matrix_tag_hard_process +<>= + module subroutine state_matrix_tag_hard_process (state, tagged_state, tag) + class(state_matrix_t), intent(in), target :: state + type(state_matrix_t), intent(out) :: tagged_state + integer, dimension(:), intent(in), optional :: tag + end subroutine state_matrix_tag_hard_process <>= - subroutine state_matrix_tag_hard_process (state, tagged_state, tag) + module subroutine state_matrix_tag_hard_process (state, tagged_state, tag) class(state_matrix_t), intent(in), target :: state type(state_matrix_t), intent(out) :: tagged_state integer, dimension(:), intent(in), optional :: tag type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:), allocatable :: qn complex(default) :: value integer :: i call tagged_state%init (store_values = .true.) call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () value = it%get_matrix_element () if (present (tag)) then do i = 1, size (tag) call qn(tag(i))%tag_hard_process () end do else call qn%tag_hard_process () end if call tagged_state%add_state (qn, index = it%get_me_index (), value = value) call it%advance () end do call tagged_state%freeze () end subroutine state_matrix_tag_hard_process @ %def state_matrix_tag_hard_process \subsubsection{Properties of the quantum state} A state is defined if its root is allocated: <>= procedure :: is_defined => state_matrix_is_defined +<>= + elemental module function state_matrix_is_defined (state) result (defined) + logical :: defined + class(state_matrix_t), intent(in) :: state + end function state_matrix_is_defined <>= - elemental function state_matrix_is_defined (state) result (defined) + elemental module function state_matrix_is_defined (state) result (defined) logical :: defined class(state_matrix_t), intent(in) :: state defined = associated (state%root) end function state_matrix_is_defined @ %def state_matrix_is_defined @ A state is empty if its depth is zero: <>= procedure :: is_empty => state_matrix_is_empty +<>= + elemental module function state_matrix_is_empty (state) result (flag) + logical :: flag + class(state_matrix_t), intent(in) :: state + end function state_matrix_is_empty <>= - elemental function state_matrix_is_empty (state) result (flag) + elemental module function state_matrix_is_empty (state) result (flag) logical :: flag class(state_matrix_t), intent(in) :: state flag = state%depth == 0 end function state_matrix_is_empty @ %def state_matrix_is_empty @ Return the number of matrix-element values. <>= generic :: get_n_matrix_elements => get_n_matrix_elements_all, get_n_matrix_elements_mask procedure :: get_n_matrix_elements_all => state_matrix_get_n_matrix_elements_all procedure :: get_n_matrix_elements_mask => state_matrix_get_n_matrix_elements_mask +<>= + pure module function state_matrix_get_n_matrix_elements_all (state) result (n) + integer :: n + class(state_matrix_t), intent(in) :: state + end function state_matrix_get_n_matrix_elements_all <>= - pure function state_matrix_get_n_matrix_elements_all (state) result (n) + pure module function state_matrix_get_n_matrix_elements_all (state) result (n) integer :: n class(state_matrix_t), intent(in) :: state n = state%n_matrix_elements end function state_matrix_get_n_matrix_elements_all @ %def state_matrix_get_n_matrix_elements_all @ +<>= + module function state_matrix_get_n_matrix_elements_mask (state, qn_mask) result (n) + integer :: n + class(state_matrix_t), intent(in) :: state + type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask + end function state_matrix_get_n_matrix_elements_mask <>= - function state_matrix_get_n_matrix_elements_mask (state, qn_mask) result (n) + module function state_matrix_get_n_matrix_elements_mask (state, qn_mask) result (n) integer :: n class(state_matrix_t), intent(in) :: state type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask type(state_iterator_t) :: it type(quantum_numbers_t), dimension(size(qn_mask)) :: qn type(state_matrix_t) :: state_tmp call state_tmp%init () call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () call qn%undefine (qn_mask) call state_tmp%add_state (qn) call it%advance () end do n = state_tmp%n_matrix_elements call state_tmp%final () end function state_matrix_get_n_matrix_elements_mask @ %def state_matrix_get_n_matrix_elments_mask @ Return the size of the [[me]]-array for debugging purposes. <>= procedure :: get_me_size => state_matrix_get_me_size +<>= + pure module function state_matrix_get_me_size (state) result (n) + integer :: n + class(state_matrix_t), intent(in) :: state + end function state_matrix_get_me_size <>= - pure function state_matrix_get_me_size (state) result (n) + pure module function state_matrix_get_me_size (state) result (n) integer :: n class(state_matrix_t), intent(in) :: state if (allocated (state%me)) then n = size (state%me) else n = 0 end if end function state_matrix_get_me_size @ %def state_matrix_get_me_size @ <>= procedure :: compute_n_sub => state_matrix_compute_n_sub +<>= + module function state_matrix_compute_n_sub (state) result (n_sub) + integer :: n_sub + class(state_matrix_t), intent(in) :: state + end function state_matrix_compute_n_sub <>= - function state_matrix_compute_n_sub (state) result (n_sub) + module function state_matrix_compute_n_sub (state) result (n_sub) integer :: n_sub class(state_matrix_t), intent(in) :: state type(state_iterator_t) :: it type(quantum_numbers_t), dimension(state%depth) :: qn integer :: sub, sub_pos n_sub = 0 call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () sub = 0 sub_pos = qn_array_sub_pos () if (sub_pos > 0) sub = qn(sub_pos)%get_sub () if (sub > n_sub) n_sub = sub call it%advance () end do contains function qn_array_sub_pos () result (pos) integer :: pos integer :: i pos = 0 do i = 1, state%depth if (qn(i)%get_sub () > 0) then pos = i exit end if end do end function qn_array_sub_pos end function state_matrix_compute_n_sub @ %def state_matrix_compute_n_sub @ <>= procedure :: set_n_sub => state_matrix_set_n_sub +<>= + module subroutine state_matrix_set_n_sub (state) + class(state_matrix_t), intent(inout) :: state + end subroutine state_matrix_set_n_sub <>= - subroutine state_matrix_set_n_sub (state) + module subroutine state_matrix_set_n_sub (state) class(state_matrix_t), intent(inout) :: state state%n_sub = state%compute_n_sub () end subroutine state_matrix_set_n_sub @ %def state_matrix_set_n_sub @ Return number of subtractions. <>= procedure :: get_n_sub => state_matrix_get_n_sub +<>= + module function state_matrix_get_n_sub (state) result (n_sub) + integer :: n_sub + class(state_matrix_t), intent(in) :: state + end function state_matrix_get_n_sub <>= - function state_matrix_get_n_sub (state) result (n_sub) + module function state_matrix_get_n_sub (state) result (n_sub) integer :: n_sub class(state_matrix_t), intent(in) :: state if (state%n_sub < 0) then call msg_bug ("[state_matrix_get_n_sub] number of subtractions not set.") end if n_sub = state%n_sub end function state_matrix_get_n_sub @ %def state_matrix_get_n_sub @ Return the number of leaves. This can be larger than the number of independent matrix elements. <>= procedure :: get_n_leaves => state_matrix_get_n_leaves +<>= + module function state_matrix_get_n_leaves (state) result (n) + integer :: n + class(state_matrix_t), intent(in) :: state + type(state_iterator_t) :: it + end function state_matrix_get_n_leaves <>= - function state_matrix_get_n_leaves (state) result (n) + module function state_matrix_get_n_leaves (state) result (n) integer :: n class(state_matrix_t), intent(in) :: state type(state_iterator_t) :: it n = 0 call it%init (state) do while (it%is_valid ()) n = n + 1 call it%advance () end do end function state_matrix_get_n_leaves @ %def state_matrix_get_n_leaves @ Return the depth: <>= procedure :: get_depth => state_matrix_get_depth +<>= + pure module function state_matrix_get_depth (state) result (depth) + integer :: depth + class(state_matrix_t), intent(in) :: state + end function state_matrix_get_depth <>= - pure function state_matrix_get_depth (state) result (depth) + pure module function state_matrix_get_depth (state) result (depth) integer :: depth class(state_matrix_t), intent(in) :: state depth = state%depth end function state_matrix_get_depth @ %def state_matrix_get_depth @ Return the norm: <>= procedure :: get_norm => state_matrix_get_norm +<>= + pure module function state_matrix_get_norm (state) result (norm) + real(default) :: norm + class(state_matrix_t), intent(in) :: state + end function state_matrix_get_norm <>= - pure function state_matrix_get_norm (state) result (norm) + pure module function state_matrix_get_norm (state) result (norm) real(default) :: norm class(state_matrix_t), intent(in) :: state norm = state%norm end function state_matrix_get_norm @ %def state_matrix_get_norm @ \subsubsection{Retrieving contents} Return the quantum number array, using an index. We have to scan the state matrix since there is no shortcut. <>= procedure :: get_quantum_number => & state_matrix_get_quantum_number +<>= + module function state_matrix_get_quantum_number (state, i, by_me_index) result (qn) + class(state_matrix_t), intent(in), target :: state + integer, intent(in) :: i + logical, intent(in), optional :: by_me_index + type(quantum_numbers_t), dimension(state%depth) :: qn + end function state_matrix_get_quantum_number <>= - function state_matrix_get_quantum_number (state, i, by_me_index) result (qn) + module function state_matrix_get_quantum_number (state, i, by_me_index) result (qn) class(state_matrix_t), intent(in), target :: state integer, intent(in) :: i logical, intent(in), optional :: by_me_index logical :: opt_by_me_index type(quantum_numbers_t), dimension(state%depth) :: qn type(state_iterator_t) :: it integer :: k opt_by_me_index = .false. if (present (by_me_index)) opt_by_me_index = by_me_index k = 0 call it%init (state) do while (it%is_valid ()) if (opt_by_me_index) then k = it%get_me_index () else k = k + 1 end if if (k == i) then qn = it%get_quantum_numbers () exit end if call it%advance () end do end function state_matrix_get_quantum_number @ %def state_matrix_get_quantum_number <>= generic :: get_quantum_numbers => get_quantum_numbers_all, get_quantum_numbers_mask procedure :: get_quantum_numbers_all => state_matrix_get_quantum_numbers_all procedure :: get_quantum_numbers_mask => state_matrix_get_quantum_numbers_mask +<>= + module subroutine state_matrix_get_quantum_numbers_all (state, qn) + class(state_matrix_t), intent(in), target :: state + type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn + end subroutine state_matrix_get_quantum_numbers_all <>= - subroutine state_matrix_get_quantum_numbers_all (state, qn) + module subroutine state_matrix_get_quantum_numbers_all (state, qn) class(state_matrix_t), intent(in), target :: state type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn integer :: i allocate (qn (state%get_n_matrix_elements (), & state%get_depth())) do i = 1, state%get_n_matrix_elements () qn (i, :) = state%get_quantum_number (i) end do end subroutine state_matrix_get_quantum_numbers_all @ %def state_matrix_get_quantum_numbers_all @ +<>= + module subroutine state_matrix_get_quantum_numbers_mask (state, qn_mask, qn) + class(state_matrix_t), intent(in), target :: state + type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask + type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn + end subroutine state_matrix_get_quantum_numbers_mask <>= - subroutine state_matrix_get_quantum_numbers_mask (state, qn_mask, qn) + module subroutine state_matrix_get_quantum_numbers_mask (state, qn_mask, qn) class(state_matrix_t), intent(in), target :: state type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn type(quantum_numbers_t), dimension(:), allocatable :: qn_tmp type(state_matrix_t) :: state_tmp type(state_iterator_t) :: it integer :: i, n n = state%get_n_matrix_elements (qn_mask) allocate (qn (n, state%get_depth ())) allocate (qn_tmp (state%get_depth ())) call it%init (state) call state_tmp%init () do while (it%is_valid ()) qn_tmp = it%get_quantum_numbers () call qn_tmp%undefine (qn_mask) call state_tmp%add_state (qn_tmp) call it%advance () end do do i = 1, n qn (i, :) = state_tmp%get_quantum_number (i) end do call state_tmp%final () end subroutine state_matrix_get_quantum_numbers_mask @ %def state_matrix_get_quantum_numbers_mask @ <>= procedure :: get_flavors => state_matrix_get_flavors +<>= + module subroutine state_matrix_get_flavors (state, only_elementary, qn_mask, flv) + class(state_matrix_t), intent(in), target :: state + logical, intent(in) :: only_elementary + type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask + integer, intent(out), dimension(:,:), allocatable :: flv + end subroutine state_matrix_get_flavors <>= - subroutine state_matrix_get_flavors (state, only_elementary, qn_mask, flv) + module subroutine state_matrix_get_flavors (state, only_elementary, qn_mask, flv) class(state_matrix_t), intent(in), target :: state logical, intent(in) :: only_elementary type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask integer, intent(out), dimension(:,:), allocatable :: flv type(quantum_numbers_t), dimension(:,:), allocatable :: qn integer :: i_flv, n_partons type(flavor_t), dimension(:), allocatable :: flv_flv if (present (qn_mask)) then call state%get_quantum_numbers (qn_mask, qn) else call state%get_quantum_numbers (qn) end if allocate (flv_flv (size (qn, dim=2))) if (only_elementary) then flv_flv = qn(1, :)%get_flavor () n_partons = count (is_elementary (flv_flv%get_pdg ())) end if allocate (flv (n_partons, size (qn, dim=1))) associate (n_flv => size (qn, dim=1)) do i_flv = 1, size (qn, dim=1) flv_flv = qn(i_flv, :)%get_flavor () flv(:, i_flv) = pack (flv_flv%get_pdg (), is_elementary(flv_flv%get_pdg())) end do end associate contains elemental function is_elementary (pdg) logical :: is_elementary integer, intent(in) :: pdg is_elementary = abs(pdg) /= 2212 .and. abs(pdg) /= 92 .and. abs(pdg) /= 93 end function is_elementary end subroutine state_matrix_get_flavors @ %def state_matrix_get_flavors @ Return a single matrix element using its index. Works only if the shortcut array is allocated. <>= generic :: get_matrix_element => get_matrix_element_single generic :: get_matrix_element => get_matrix_element_array procedure :: get_matrix_element_single => & state_matrix_get_matrix_element_single procedure :: get_matrix_element_array => & state_matrix_get_matrix_element_array +<>= + elemental module function state_matrix_get_matrix_element_single (state, i) result (me) + complex(default) :: me + class(state_matrix_t), intent(in) :: state + integer, intent(in) :: i + end function state_matrix_get_matrix_element_single <>= - elemental function state_matrix_get_matrix_element_single (state, i) result (me) + elemental module function state_matrix_get_matrix_element_single (state, i) result (me) complex(default) :: me class(state_matrix_t), intent(in) :: state integer, intent(in) :: i if (allocated (state%me)) then me = state%me(i) else me = 0 end if end function state_matrix_get_matrix_element_single @ %def state_matrix_get_matrix_element_single @ +<>= + module function state_matrix_get_matrix_element_array (state) result (me) + complex(default), dimension(:), allocatable :: me + class(state_matrix_t), intent(in) :: state + end function state_matrix_get_matrix_element_array <>= - function state_matrix_get_matrix_element_array (state) result (me) + module function state_matrix_get_matrix_element_array (state) result (me) complex(default), dimension(:), allocatable :: me class(state_matrix_t), intent(in) :: state if (allocated (state%me)) then allocate (me (size (state%me))) me = state%me else me = 0 end if end function state_matrix_get_matrix_element_array @ %def state_matrix_get_matrix_element_array @ Return the color index with maximum absolute value that is present within the state matrix. <>= procedure :: get_max_color_value => state_matrix_get_max_color_value +<>= + module function state_matrix_get_max_color_value (state) result (cmax) + integer :: cmax + class(state_matrix_t), intent(in) :: state + end function state_matrix_get_max_color_value <>= - function state_matrix_get_max_color_value (state) result (cmax) + module function state_matrix_get_max_color_value (state) result (cmax) integer :: cmax class(state_matrix_t), intent(in) :: state if (associated (state%root)) then cmax = node_get_max_color_value (state%root) else cmax = 0 end if contains recursive function node_get_max_color_value (node) result (cmax) integer :: cmax type(node_t), intent(in), target :: node type(node_t), pointer :: current cmax = quantum_numbers_get_max_color_value (node%qn) current => node%child_first do while (associated (current)) cmax = max (cmax, node_get_max_color_value (current)) current => current%next end do end function node_get_max_color_value end function state_matrix_get_max_color_value @ %def state_matrix_get_max_color_value @ \subsubsection{Building the quantum state} The procedure generates a branch associated to the input array of quantum numbers. If the branch exists already, it is used. Optionally, we set the matrix-element index, a value (which may be added to the previous one), and increment one of the possible counters. We may also return the matrix element index of the current node. <>= procedure :: add_state => state_matrix_add_state +<>= + module subroutine state_matrix_add_state (state, qn, index, value, & + sum_values, counter_index, ignore_sub_for_qn, me_index) + class(state_matrix_t), intent(inout) :: state + type(quantum_numbers_t), dimension(:), intent(in) :: qn + integer, intent(in), optional :: index + complex(default), intent(in), optional :: value + logical, intent(in), optional :: sum_values + integer, intent(in), optional :: counter_index + logical, intent(in), optional :: ignore_sub_for_qn + integer, intent(out), optional :: me_index + end subroutine state_matrix_add_state <>= - subroutine state_matrix_add_state (state, qn, index, value, & + module subroutine state_matrix_add_state (state, qn, index, value, & sum_values, counter_index, ignore_sub_for_qn, me_index) class(state_matrix_t), intent(inout) :: state type(quantum_numbers_t), dimension(:), intent(in) :: qn integer, intent(in), optional :: index complex(default), intent(in), optional :: value logical, intent(in), optional :: sum_values integer, intent(in), optional :: counter_index logical, intent(in), optional :: ignore_sub_for_qn integer, intent(out), optional :: me_index logical :: set_index, get_index, add set_index = present (index) get_index = present (me_index) add = .false.; if (present (sum_values)) add = sum_values if (state%depth == 0) then state%depth = size (qn) else if (state%depth /= size (qn)) then call state%write () call msg_bug ("State matrix: depth mismatch") end if if (size (qn) > 0) call node_make_branch (state%root, qn) contains recursive subroutine node_make_branch (parent, qn) type(node_t), pointer :: parent type(quantum_numbers_t), dimension(:), intent(in) :: qn type(node_t), pointer :: child logical :: match match = .false. child => parent%child_first SCAN_CHILDREN: do while (associated (child)) if (present (ignore_sub_for_qn)) then if (ignore_sub_for_qn) then match = quantum_numbers_eq_wo_sub (child%qn, qn(1)) else match = child%qn == qn(1) end if else match = child%qn == qn(1) end if if (match) exit SCAN_CHILDREN child => child%next end do SCAN_CHILDREN if (.not. match) then call node_append_child (parent, child) child%qn = qn(1) end if select case (size (qn)) case (1) if (.not. match) then state%n_matrix_elements = state%n_matrix_elements + 1 child%me_index = state%n_matrix_elements end if if (set_index) then child%me_index = index end if if (get_index) then me_index = child%me_index end if if (present (counter_index)) then if (.not. allocated (child%me_count)) then allocate (child%me_count (state%n_counters)) child%me_count = 0 end if child%me_count(counter_index) = child%me_count(counter_index) + 1 end if if (present (value)) then if (add) then child%me = child%me + value else child%me = value end if end if case (2:) call node_make_branch (child, qn(2:)) end select end subroutine node_make_branch end subroutine state_matrix_add_state @ %def state_matrix_add_state @ Remove irrelevant flavor/color/helicity labels and the corresponding branchings. The masks indicate which particles are affected; the masks length should coincide with the depth of the trie (without the root node). Recursively scan the whole tree, starting from the leaf nodes and working up to the root node. If a mask entry is set for the current tree level, scan the children there. For each child within that level make a new empty branch where the masked quantum number is undefined. Then recursively combine all following children with matching quantum number into this new node and move on. <>= procedure :: collapse => state_matrix_collapse +<>= + module subroutine state_matrix_collapse (state, mask) + class(state_matrix_t), intent(inout) :: state + type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask + end subroutine state_matrix_collapse <>= - subroutine state_matrix_collapse (state, mask) + module subroutine state_matrix_collapse (state, mask) class(state_matrix_t), intent(inout) :: state type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask type(state_matrix_t) :: red_state if (state%is_defined ()) then call state%reduce (mask, red_state) call state%final () state = red_state end if end subroutine state_matrix_collapse @ %def state_matrix_collapse @ Transform the given state matrix into a reduced state matrix where some quantum numbers are removed, as indicated by the mask. The procedure creates a new state matrix, so the old one can be deleted after this if it is no longer used. It is said that the matrix element ordering is lost afterwards. We allow to keep the original matrix element index in the new state matrix. If the matrix element indices are kept, we do not freeze the state matrix. After reordering the matrix element indices by [[state_matrix_reorder_me]], the state matrix can be frozen. <>= procedure :: reduce => state_matrix_reduce +<>= + module subroutine state_matrix_reduce (state, mask, red_state, keep_me_index) + class(state_matrix_t), intent(in), target :: state + type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask + type(state_matrix_t), intent(out) :: red_state + logical, optional, intent(in) :: keep_me_index + end subroutine state_matrix_reduce <>= - subroutine state_matrix_reduce (state, mask, red_state, keep_me_index) + module subroutine state_matrix_reduce (state, mask, red_state, keep_me_index) class(state_matrix_t), intent(in), target :: state type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask type(state_matrix_t), intent(out) :: red_state logical, optional, intent(in) :: keep_me_index logical :: opt_keep_me_index type(state_iterator_t) :: it type(quantum_numbers_t), dimension(size(mask)) :: qn opt_keep_me_index = .false. if (present (keep_me_index)) opt_keep_me_index = keep_me_index call red_state%init () call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () call qn%undefine (mask) if (opt_keep_me_index) then call red_state%add_state (qn, index = it%get_me_index ()) else call red_state%add_state (qn) end if call it%advance () end do if (.not. opt_keep_me_index) then call red_state%freeze () end if end subroutine state_matrix_reduce @ %def state_matrix_reduce @ Reorder the matrix elements -- not the tree itself. The procedure is necessary in case the matrix element indices were kept when reducing over quantum numbers and one wants to reintroduce the previous order of the matrix elements. <>= procedure :: reorder_me => state_matrix_reorder_me +<>= + module subroutine state_matrix_reorder_me (state, ordered_state) + class(state_matrix_t), intent(in), target :: state + type(state_matrix_t), intent(out) :: ordered_state + end subroutine state_matrix_reorder_me <>= - subroutine state_matrix_reorder_me (state, ordered_state) + module subroutine state_matrix_reorder_me (state, ordered_state) class(state_matrix_t), intent(in), target :: state type(state_matrix_t), intent(out) :: ordered_state type(state_iterator_t) :: it type(quantum_numbers_t), dimension(state%depth) :: qn integer, dimension(:), allocatable :: me_index integer :: i call ordered_state%init () call get_me_index_sorted (state, me_index) i = 1; call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () call ordered_state%add_state (qn, index = me_index(i)) i = i + 1; call it%advance () end do call ordered_state%freeze () contains subroutine get_me_index_sorted (state, me_index) class(state_matrix_t), intent(in), target :: state integer, dimension(:), allocatable, intent(out) :: me_index type(state_iterator_t) :: it integer :: i, j integer, dimension(:), allocatable :: me_index_unsorted, me_index_sorted associate (n_matrix_elements => state%get_n_matrix_elements ()) allocate (me_index(n_matrix_elements), source = 0) allocate (me_index_sorted(n_matrix_elements), source = 0) allocate (me_index_unsorted(n_matrix_elements), source = 0) i = 1; call it%init (state) do while (it%is_valid ()) me_index_unsorted(i) = it%get_me_index () i = i + 1 call it%advance () end do me_index_sorted = sort (me_index_unsorted) ! We do not care about efficiency at this point. UNSORTED: do i = 1, n_matrix_elements SORTED: do j = 1, n_matrix_elements if (me_index_unsorted(i) == me_index_sorted(j)) then me_index(i) = j cycle UNSORTED end if end do SORTED end do UNSORTED end associate end subroutine get_me_index_sorted end subroutine state_matrix_reorder_me @ %def state_matrix_order_by_flavors @ Sets all matrix elements whose flavor structure is a duplicate of another flavor structure to zero. We need this for the real finite to ignore duplicate flavor structures while keeping the indices identical to the singular real component. When comparing the flavor structures, we take into account permutations of final- state particles. To do this properly, we keep only the non-hard flavors and the initial-state flavors, i.e. the first two hard flavors fixed. <>= procedure :: set_duplicate_flv_zero => state_matrix_set_duplicate_flv_zero +<>= + module subroutine state_matrix_set_duplicate_flv_zero (state) + class(state_matrix_t), intent(inout), target :: state + end subroutine state_matrix_set_duplicate_flv_zero <>= - subroutine state_matrix_set_duplicate_flv_zero (state) + module subroutine state_matrix_set_duplicate_flv_zero (state) class(state_matrix_t), intent(inout), target :: state type(quantum_numbers_t), dimension(state%depth) :: qn type(flavor_t) :: flv - class(state_flv_content_t), allocatable :: state_flv + type(state_flv_content_t), allocatable :: state_flv logical, dimension(:), allocatable :: hard_mask, sort_mask, duplicate_mask integer :: i, j, n_in, n_flvs n_flvs = state%get_depth () n_in = 2 !!! TODO (PS-28-07-21) n_in should not be hard coded to work for decays !!! This assumes that the positions of the non-hard flavors are the same for all flavor structures. qn = state%get_quantum_number(1) allocate (hard_mask(n_flvs)) do i = 1, n_flvs flv = qn(i)%get_flavor() hard_mask(i) = flv%is_hard_process () end do allocate (sort_mask(n_flvs)) sort_mask = hard_mask j = 0 do i = 1, n_flvs if (j == n_in) exit if (sort_mask(i)) then sort_mask(i) = .false. j = j + 1 end if end do allocate (state_flv) call state_flv%fill (state, sort_mask) call state_flv%find_duplicates (duplicate_mask) do i = 1, state%get_n_matrix_elements () if (duplicate_mask(i)) then call state%set_matrix_element_single(i, cmplx(zero, zero, default)) end if end do end subroutine state_matrix_set_duplicate_flv_zero @ %def state_matrix_set_duplicate_flv_zero @ This subroutine sets up the matrix-element array. The leaf nodes aquire the index values that point to the appropriate matrix-element entry. We recursively scan the trie. Once we arrive at a leaf node, the index is increased and associated to that node. Finally, we allocate the matrix-element array with the appropriate size. If matrix element values are temporarily stored within the leaf nodes, we scan the state again and transfer them to the matrix-element array. <>= procedure :: freeze => state_matrix_freeze +<>= + module subroutine state_matrix_freeze (state) + class(state_matrix_t), intent(inout), target :: state + end subroutine state_matrix_freeze <>= - subroutine state_matrix_freeze (state) + module subroutine state_matrix_freeze (state) class(state_matrix_t), intent(inout), target :: state type(state_iterator_t) :: it if (associated (state%root)) then if (allocated (state%me)) deallocate (state%me) allocate (state%me (state%n_matrix_elements)) state%me = 0 call state%set_n_sub () end if if (state%leaf_nodes_store_values) then call it%init (state) do while (it%is_valid ()) state%me(it%get_me_index ()) = it%get_matrix_element () call it%advance () end do state%leaf_nodes_store_values = .false. end if end subroutine state_matrix_freeze @ %def state_matrix_freeze @ \subsubsection{Direct access to the value array} Several methods for setting a value directly are summarized in this generic: <>= generic :: set_matrix_element => set_matrix_element_qn generic :: set_matrix_element => set_matrix_element_all generic :: set_matrix_element => set_matrix_element_array generic :: set_matrix_element => set_matrix_element_single generic :: set_matrix_element => set_matrix_element_clone procedure :: set_matrix_element_qn => state_matrix_set_matrix_element_qn procedure :: set_matrix_element_all => state_matrix_set_matrix_element_all procedure :: set_matrix_element_array => & state_matrix_set_matrix_element_array procedure :: set_matrix_element_single => & state_matrix_set_matrix_element_single procedure :: set_matrix_element_clone => & state_matrix_set_matrix_element_clone @ %def state_matrix_set_matrix_element @ Set a value that corresponds to a quantum number array: +<>= + module subroutine state_matrix_set_matrix_element_qn (state, qn, value) + class(state_matrix_t), intent(inout), target :: state + type(quantum_numbers_t), dimension(:), intent(in) :: qn + complex(default), intent(in) :: value + end subroutine state_matrix_set_matrix_element_qn <>= - subroutine state_matrix_set_matrix_element_qn (state, qn, value) + module subroutine state_matrix_set_matrix_element_qn (state, qn, value) class(state_matrix_t), intent(inout), target :: state type(quantum_numbers_t), dimension(:), intent(in) :: qn complex(default), intent(in) :: value type(state_iterator_t) :: it if (.not. allocated (state%me)) then allocate (state%me (size(qn))) end if call it%init (state) call it%go_to_qn (qn) call it%set_matrix_element (value) end subroutine state_matrix_set_matrix_element_qn @ %def state_matrix_set_matrix_element_qn @ Set all matrix elements to a single value +<>= + module subroutine state_matrix_set_matrix_element_all (state, value) + class(state_matrix_t), intent(inout) :: state + complex(default), intent(in) :: value + end subroutine state_matrix_set_matrix_element_all <>= - subroutine state_matrix_set_matrix_element_all (state, value) + module subroutine state_matrix_set_matrix_element_all (state, value) class(state_matrix_t), intent(inout) :: state complex(default), intent(in) :: value if (.not. allocated (state%me)) then allocate (state%me (state%n_matrix_elements)) end if state%me = value end subroutine state_matrix_set_matrix_element_all @ %def state_matrix_set_matrix_element_all @ Set the matrix-element array directly. +<>= + module subroutine state_matrix_set_matrix_element_array (state, value, range) + class(state_matrix_t), intent(inout) :: state + complex(default), intent(in), dimension(:) :: value + integer, intent(in), dimension(:), optional :: range + end subroutine state_matrix_set_matrix_element_array <>= - subroutine state_matrix_set_matrix_element_array (state, value, range) + module subroutine state_matrix_set_matrix_element_array (state, value, range) class(state_matrix_t), intent(inout) :: state complex(default), intent(in), dimension(:) :: value integer, intent(in), dimension(:), optional :: range if (present (range)) then state%me(range) = value else if (.not. allocated (state%me)) & allocate (state%me (size (value))) state%me(:) = value end if end subroutine state_matrix_set_matrix_element_array @ %def state_matrix_set_matrix_element_array @ Set a matrix element at position [[i]] to [[value]]. +<>= + pure module subroutine state_matrix_set_matrix_element_single (state, i, value) + class(state_matrix_t), intent(inout) :: state + integer, intent(in) :: i + complex(default), intent(in) :: value + end subroutine state_matrix_set_matrix_element_single <>= - pure subroutine state_matrix_set_matrix_element_single (state, i, value) + pure module subroutine state_matrix_set_matrix_element_single (state, i, value) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i complex(default), intent(in) :: value if (.not. allocated (state%me)) then allocate (state%me (state%n_matrix_elements)) end if state%me(i) = value end subroutine state_matrix_set_matrix_element_single @ %def state_matrix_set_matrix_element_single @ Clone the matrix elements from another (matching) state matrix. +<>= + module subroutine state_matrix_set_matrix_element_clone (state, state1) + class(state_matrix_t), intent(inout) :: state + type(state_matrix_t), intent(in) :: state1 + end subroutine state_matrix_set_matrix_element_clone <>= - subroutine state_matrix_set_matrix_element_clone (state, state1) + module subroutine state_matrix_set_matrix_element_clone (state, state1) class(state_matrix_t), intent(inout) :: state type(state_matrix_t), intent(in) :: state1 if (.not. allocated (state1%me)) return if (.not. allocated (state%me)) allocate (state%me (size (state1%me))) state%me = state1%me end subroutine state_matrix_set_matrix_element_clone @ %def state_matrix_set_matrix_element_clone @ Add a value to a matrix element <>= procedure :: add_to_matrix_element => state_matrix_add_to_matrix_element +<>= + module subroutine state_matrix_add_to_matrix_element (state, qn, value, match_only_flavor) + class(state_matrix_t), intent(inout), target :: state + type(quantum_numbers_t), dimension(:), intent(in) :: qn + complex(default), intent(in) :: value + logical, intent(in), optional :: match_only_flavor + end subroutine state_matrix_add_to_matrix_element <>= - subroutine state_matrix_add_to_matrix_element (state, qn, value, match_only_flavor) + module subroutine state_matrix_add_to_matrix_element (state, qn, value, match_only_flavor) class(state_matrix_t), intent(inout), target :: state type(quantum_numbers_t), dimension(:), intent(in) :: qn complex(default), intent(in) :: value logical, intent(in), optional :: match_only_flavor type(state_iterator_t) :: it call it%init (state) call it%go_to_qn (qn, match_only_flavor) if (it%is_valid ()) then call it%add_to_matrix_element (value) else call msg_fatal ("Cannot add to matrix element - it%node not allocated") end if end subroutine state_matrix_add_to_matrix_element @ %def state_matrix_add_to_matrix_element @ \subsection{State iterators} Accessing the quantum state from outside is best done using a specialized iterator, i.e., a pointer to a particular branch of the quantum state trie. Technically, the iterator contains a pointer to a leaf node, but via parent pointers it allows to access the whole branch where the leaf is attached. For quick access, we also keep the branch depth (which is assumed to be universal for a quantum state). <>= public :: state_iterator_t <>= type :: state_iterator_t private integer :: depth = 0 type(state_matrix_t), pointer :: state => null () type(node_t), pointer :: node => null () contains <> end type state_iterator_t @ %def state_iterator @ The initializer: Point at the first branch. Note that this cannot be pure, thus not be elemental, because the iterator can be used to manipulate data in the state matrix. <>= procedure :: init => state_iterator_init +<>= + module subroutine state_iterator_init (it, state) + class(state_iterator_t), intent(out) :: it + type(state_matrix_t), intent(in), target :: state + end subroutine state_iterator_init <>= - subroutine state_iterator_init (it, state) + module subroutine state_iterator_init (it, state) class(state_iterator_t), intent(out) :: it type(state_matrix_t), intent(in), target :: state it%state => state it%depth = state%depth if (state%is_defined ()) then it%node => state%root do while (associated (it%node%child_first)) it%node => it%node%child_first end do else it%node => null () end if end subroutine state_iterator_init @ %def state_iterator_init @ Go forward. Recursively programmed: if the next node does not exist, go back to the parent node and look at its successor (if present), etc. There is a possible pitfall in the implementation: If the dummy pointer argument to the [[find_next]] routine is used directly, we still get the correct result for the iterator, but calling the recursion on [[node%parent]] means that we manipulate a parent pointer in the original state in addition to the iterator. Making a local copy of the pointer avoids this. Using pointer intent would be helpful, but we do not yet rely on this F2003 feature. <>= procedure :: advance => state_iterator_advance +<>= + module subroutine state_iterator_advance (it) + class(state_iterator_t), intent(inout) :: it + end subroutine state_iterator_advance <>= - subroutine state_iterator_advance (it) + module subroutine state_iterator_advance (it) class(state_iterator_t), intent(inout) :: it call find_next (it%node) contains recursive subroutine find_next (node_in) type(node_t), intent(in), target :: node_in type(node_t), pointer :: node node => node_in if (associated (node%next)) then node => node%next do while (associated (node%child_first)) node => node%child_first end do it%node => node else if (associated (node%parent)) then call find_next (node%parent) else it%node => null () end if end subroutine find_next end subroutine state_iterator_advance @ %def state_iterator_advance @ If all has been scanned, the iterator is at an undefined state. Check for this: <>= procedure :: is_valid => state_iterator_is_valid +<>= + module function state_iterator_is_valid (it) result (defined) + logical :: defined + class(state_iterator_t), intent(in) :: it + end function state_iterator_is_valid <>= - function state_iterator_is_valid (it) result (defined) + module function state_iterator_is_valid (it) result (defined) logical :: defined class(state_iterator_t), intent(in) :: it defined = associated (it%node) end function state_iterator_is_valid @ %def state_iterator_is_valid @ Return the matrix-element index that corresponds to the current node <>= procedure :: get_me_index => state_iterator_get_me_index +<>= + module function state_iterator_get_me_index (it) result (n) + integer :: n + class(state_iterator_t), intent(in) :: it + end function state_iterator_get_me_index <>= - function state_iterator_get_me_index (it) result (n) + module function state_iterator_get_me_index (it) result (n) integer :: n class(state_iterator_t), intent(in) :: it n = it%node%me_index end function state_iterator_get_me_index @ %def state_iterator_get_me_index @ Return the number of times this quantum-number state has been added (noting that it is physically inserted only the first time). Note that for each state, there is an array of counters. <>= procedure :: get_me_count => state_iterator_get_me_count +<>= + module function state_iterator_get_me_count (it) result (n) + integer, dimension(:), allocatable :: n + class(state_iterator_t), intent(in) :: it + end function state_iterator_get_me_count <>= - function state_iterator_get_me_count (it) result (n) + module function state_iterator_get_me_count (it) result (n) integer, dimension(:), allocatable :: n class(state_iterator_t), intent(in) :: it if (allocated (it%node%me_count)) then allocate (n (size (it%node%me_count))) n = it%node%me_count else allocate (n (0)) end if end function state_iterator_get_me_count @ %def state_iterator_get_me_count @ <>= procedure :: get_depth => state_iterator_get_depth +<>= + pure module function state_iterator_get_depth (state_iterator) result (depth) + integer :: depth + class(state_iterator_t), intent(in) :: state_iterator + end function state_iterator_get_depth <>= - pure function state_iterator_get_depth (state_iterator) result (depth) + pure module function state_iterator_get_depth (state_iterator) result (depth) integer :: depth class(state_iterator_t), intent(in) :: state_iterator depth = state_iterator%depth end function state_iterator_get_depth @ %def state_iterator_get_depth @ Proceed to the state associated with the quantum numbers [[qn]]. <>= procedure :: go_to_qn => state_iterator_go_to_qn +<>= + module subroutine state_iterator_go_to_qn (it, qn, match_only_flavor) + class(state_iterator_t), intent(inout) :: it + type(quantum_numbers_t), dimension(:), intent(in) :: qn + logical, intent(in), optional :: match_only_flavor + end subroutine state_iterator_go_to_qn <>= - subroutine state_iterator_go_to_qn (it, qn, match_only_flavor) + module subroutine state_iterator_go_to_qn (it, qn, match_only_flavor) class(state_iterator_t), intent(inout) :: it type(quantum_numbers_t), dimension(:), intent(in) :: qn logical, intent(in), optional :: match_only_flavor type(quantum_numbers_t), dimension(:), allocatable :: qn_hard, qn_tmp logical :: match_flv match_flv = .false.; if (present (match_only_flavor)) match_flv = .true. do while (it%is_valid ()) if (match_flv) then qn_tmp = it%get_quantum_numbers () qn_hard = pack (qn_tmp, qn_tmp%are_hard_process ()) if (all (qn .fmatch. qn_hard)) then return else call it%advance () end if else if (all (qn == it%get_quantum_numbers ())) then return else call it%advance () end if end if end do end subroutine state_iterator_go_to_qn @ %def state_iterator_go_to_qn @ Use the iterator to retrieve quantum-number information: <>= generic :: get_quantum_numbers => get_qn_multi, get_qn_slice, & get_qn_range, get_qn_single generic :: get_flavor => get_flv_multi, get_flv_slice, & get_flv_range, get_flv_single generic :: get_color => get_col_multi, get_col_slice, & get_col_range, get_col_single generic :: get_helicity => get_hel_multi, get_hel_slice, & get_hel_range, get_hel_single <>= procedure :: get_qn_multi => state_iterator_get_qn_multi procedure :: get_qn_slice => state_iterator_get_qn_slice procedure :: get_qn_range => state_iterator_get_qn_range procedure :: get_qn_single => state_iterator_get_qn_single procedure :: get_flv_multi => state_iterator_get_flv_multi procedure :: get_flv_slice => state_iterator_get_flv_slice procedure :: get_flv_range => state_iterator_get_flv_range procedure :: get_flv_single => state_iterator_get_flv_single procedure :: get_col_multi => state_iterator_get_col_multi procedure :: get_col_slice => state_iterator_get_col_slice procedure :: get_col_range => state_iterator_get_col_range procedure :: get_col_single => state_iterator_get_col_single procedure :: get_hel_multi => state_iterator_get_hel_multi procedure :: get_hel_slice => state_iterator_get_hel_slice procedure :: get_hel_range => state_iterator_get_hel_range procedure :: get_hel_single => state_iterator_get_hel_single @ These versions return the whole quantum number array +<>= + module function state_iterator_get_qn_multi (it) result (qn) + class(state_iterator_t), intent(in) :: it + type(quantum_numbers_t), dimension(it%depth) :: qn + end function state_iterator_get_qn_multi + module function state_iterator_get_flv_multi (it) result (flv) + class(state_iterator_t), intent(in) :: it + type(flavor_t), dimension(it%depth) :: flv + end function state_iterator_get_flv_multi + module function state_iterator_get_col_multi (it) result (col) + class(state_iterator_t), intent(in) :: it + type(color_t), dimension(it%depth) :: col + end function state_iterator_get_col_multi + module function state_iterator_get_hel_multi (it) result (hel) + class(state_iterator_t), intent(in) :: it + type(helicity_t), dimension(it%depth) :: hel + end function state_iterator_get_hel_multi <>= - function state_iterator_get_qn_multi (it) result (qn) + module function state_iterator_get_qn_multi (it) result (qn) class(state_iterator_t), intent(in) :: it type(quantum_numbers_t), dimension(it%depth) :: qn type(node_t), pointer :: node integer :: i node => it%node do i = it%depth, 1, -1 qn(i) = node%qn node => node%parent end do end function state_iterator_get_qn_multi - function state_iterator_get_flv_multi (it) result (flv) + module function state_iterator_get_flv_multi (it) result (flv) class(state_iterator_t), intent(in) :: it type(flavor_t), dimension(it%depth) :: flv flv = quantum_numbers_get_flavor & (it%get_quantum_numbers ()) end function state_iterator_get_flv_multi - function state_iterator_get_col_multi (it) result (col) + module function state_iterator_get_col_multi (it) result (col) class(state_iterator_t), intent(in) :: it type(color_t), dimension(it%depth) :: col col = quantum_numbers_get_color & (it%get_quantum_numbers ()) end function state_iterator_get_col_multi - function state_iterator_get_hel_multi (it) result (hel) + module function state_iterator_get_hel_multi (it) result (hel) class(state_iterator_t), intent(in) :: it type(helicity_t), dimension(it%depth) :: hel hel = quantum_numbers_get_helicity & (it%get_quantum_numbers ()) end function state_iterator_get_hel_multi @ An array slice (derived from the above). +<>= + module function state_iterator_get_qn_slice (it, index) result (qn) + class(state_iterator_t), intent(in) :: it + integer, dimension(:), intent(in) :: index + type(quantum_numbers_t), dimension(size(index)) :: qn + end function state_iterator_get_qn_slice + module function state_iterator_get_flv_slice (it, index) result (flv) + class(state_iterator_t), intent(in) :: it + integer, dimension(:), intent(in) :: index + type(flavor_t), dimension(size(index)) :: flv + end function state_iterator_get_flv_slice + module function state_iterator_get_col_slice (it, index) result (col) + class(state_iterator_t), intent(in) :: it + integer, dimension(:), intent(in) :: index + type(color_t), dimension(size(index)) :: col + end function state_iterator_get_col_slice + module function state_iterator_get_hel_slice (it, index) result (hel) + class(state_iterator_t), intent(in) :: it + integer, dimension(:), intent(in) :: index + type(helicity_t), dimension(size(index)) :: hel + end function state_iterator_get_hel_slice <>= - function state_iterator_get_qn_slice (it, index) result (qn) + module function state_iterator_get_qn_slice (it, index) result (qn) class(state_iterator_t), intent(in) :: it integer, dimension(:), intent(in) :: index type(quantum_numbers_t), dimension(size(index)) :: qn type(quantum_numbers_t), dimension(it%depth) :: qn_tmp qn_tmp = state_iterator_get_qn_multi (it) qn = qn_tmp(index) end function state_iterator_get_qn_slice - function state_iterator_get_flv_slice (it, index) result (flv) + module function state_iterator_get_flv_slice (it, index) result (flv) class(state_iterator_t), intent(in) :: it integer, dimension(:), intent(in) :: index type(flavor_t), dimension(size(index)) :: flv flv = quantum_numbers_get_flavor & (it%get_quantum_numbers (index)) end function state_iterator_get_flv_slice - function state_iterator_get_col_slice (it, index) result (col) + module function state_iterator_get_col_slice (it, index) result (col) class(state_iterator_t), intent(in) :: it integer, dimension(:), intent(in) :: index type(color_t), dimension(size(index)) :: col col = quantum_numbers_get_color & (it%get_quantum_numbers (index)) end function state_iterator_get_col_slice - function state_iterator_get_hel_slice (it, index) result (hel) + module function state_iterator_get_hel_slice (it, index) result (hel) class(state_iterator_t), intent(in) :: it integer, dimension(:), intent(in) :: index type(helicity_t), dimension(size(index)) :: hel hel = quantum_numbers_get_helicity & (it%get_quantum_numbers (index)) end function state_iterator_get_hel_slice @ An array range (implemented directly). +<>= + module function state_iterator_get_qn_range (it, k1, k2) result (qn) + class(state_iterator_t), intent(in) :: it + integer, intent(in) :: k1, k2 + type(quantum_numbers_t), dimension(k2-k1+1) :: qn + end function state_iterator_get_qn_range + module function state_iterator_get_flv_range (it, k1, k2) result (flv) + class(state_iterator_t), intent(in) :: it + integer, intent(in) :: k1, k2 + type(flavor_t), dimension(k2-k1+1) :: flv + end function state_iterator_get_flv_range + module function state_iterator_get_col_range (it, k1, k2) result (col) + class(state_iterator_t), intent(in) :: it + integer, intent(in) :: k1, k2 + type(color_t), dimension(k2-k1+1) :: col + end function state_iterator_get_col_range + module function state_iterator_get_hel_range (it, k1, k2) result (hel) + class(state_iterator_t), intent(in) :: it + integer, intent(in) :: k1, k2 + type(helicity_t), dimension(k2-k1+1) :: hel + end function state_iterator_get_hel_range <>= - function state_iterator_get_qn_range (it, k1, k2) result (qn) + module function state_iterator_get_qn_range (it, k1, k2) result (qn) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k1, k2 type(quantum_numbers_t), dimension(k2-k1+1) :: qn type(node_t), pointer :: node integer :: i node => it%node SCAN: do i = it%depth, 1, -1 if (k1 <= i .and. i <= k2) then qn(i-k1+1) = node%qn else node => node%parent end if end do SCAN end function state_iterator_get_qn_range - function state_iterator_get_flv_range (it, k1, k2) result (flv) + module function state_iterator_get_flv_range (it, k1, k2) result (flv) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k1, k2 type(flavor_t), dimension(k2-k1+1) :: flv flv = quantum_numbers_get_flavor & (it%get_quantum_numbers (k1, k2)) end function state_iterator_get_flv_range - function state_iterator_get_col_range (it, k1, k2) result (col) + module function state_iterator_get_col_range (it, k1, k2) result (col) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k1, k2 type(color_t), dimension(k2-k1+1) :: col col = quantum_numbers_get_color & (it%get_quantum_numbers (k1, k2)) end function state_iterator_get_col_range - function state_iterator_get_hel_range (it, k1, k2) result (hel) + module function state_iterator_get_hel_range (it, k1, k2) result (hel) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k1, k2 type(helicity_t), dimension(k2-k1+1) :: hel hel = quantum_numbers_get_helicity & (it%get_quantum_numbers (k1, k2)) end function state_iterator_get_hel_range @ Just a specific single element +<>= + module function state_iterator_get_qn_single (it, k) result (qn) + class(state_iterator_t), intent(in) :: it + integer, intent(in) :: k + type(quantum_numbers_t) :: qn + end function state_iterator_get_qn_single + module function state_iterator_get_flv_single (it, k) result (flv) + class(state_iterator_t), intent(in) :: it + integer, intent(in) :: k + type(flavor_t) :: flv + end function state_iterator_get_flv_single + module function state_iterator_get_col_single (it, k) result (col) + class(state_iterator_t), intent(in) :: it + integer, intent(in) :: k + type(color_t) :: col + end function state_iterator_get_col_single + module function state_iterator_get_hel_single (it, k) result (hel) + class(state_iterator_t), intent(in) :: it + integer, intent(in) :: k + type(helicity_t) :: hel + end function state_iterator_get_hel_single <>= - function state_iterator_get_qn_single (it, k) result (qn) + module function state_iterator_get_qn_single (it, k) result (qn) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k type(quantum_numbers_t) :: qn type(node_t), pointer :: node integer :: i node => it%node SCAN: do i = it%depth, 1, -1 if (i == k) then qn = node%qn exit SCAN else node => node%parent end if end do SCAN end function state_iterator_get_qn_single - function state_iterator_get_flv_single (it, k) result (flv) + module function state_iterator_get_flv_single (it, k) result (flv) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k type(flavor_t) :: flv flv = quantum_numbers_get_flavor & (it%get_quantum_numbers (k)) end function state_iterator_get_flv_single - function state_iterator_get_col_single (it, k) result (col) + module function state_iterator_get_col_single (it, k) result (col) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k type(color_t) :: col col = quantum_numbers_get_color & (it%get_quantum_numbers (k)) end function state_iterator_get_col_single - function state_iterator_get_hel_single (it, k) result (hel) + module function state_iterator_get_hel_single (it, k) result (hel) class(state_iterator_t), intent(in) :: it integer, intent(in) :: k type(helicity_t) :: hel hel = quantum_numbers_get_helicity & (it%get_quantum_numbers (k)) end function state_iterator_get_hel_single @ %def state_iterator_get_quantum_numbers @ %def state_iterator_get_flavor @ %def state_iterator_get_color @ %def state_iterator_get_helicity @ Assign a model pointer to the current flavor entries. <>= procedure :: set_model => state_iterator_set_model +<>= + module subroutine state_iterator_set_model (it, model) + class(state_iterator_t), intent(inout) :: it + class(model_data_t), intent(in), target :: model + end subroutine state_iterator_set_model <>= - subroutine state_iterator_set_model (it, model) + module subroutine state_iterator_set_model (it, model) class(state_iterator_t), intent(inout) :: it class(model_data_t), intent(in), target :: model type(node_t), pointer :: node integer :: i node => it%node do i = it%depth, 1, -1 call node%qn%set_model (model) node => node%parent end do end subroutine state_iterator_set_model @ %def state_iterator_set_model @ Modify the hard-interaction tag of the current flavor entries at a specific position, in-place. <>= procedure :: retag_hard_process => state_iterator_retag_hard_process +<>= + module subroutine state_iterator_retag_hard_process (it, i, hard) + class(state_iterator_t), intent(inout) :: it + integer, intent(in) :: i + logical, intent(in) :: hard + end subroutine state_iterator_retag_hard_process <>= - subroutine state_iterator_retag_hard_process (it, i, hard) + module subroutine state_iterator_retag_hard_process (it, i, hard) class(state_iterator_t), intent(inout) :: it integer, intent(in) :: i logical, intent(in) :: hard type(node_t), pointer :: node integer :: j node => it%node do j = 1, it%depth-i node => node%parent end do call node%qn%tag_hard_process (hard) end subroutine state_iterator_retag_hard_process @ %def state_iterator_retag_hard_process @ Retrieve the matrix element value associated with the current node. <>= procedure :: get_matrix_element => state_iterator_get_matrix_element +<>= + module function state_iterator_get_matrix_element (it) result (me) + complex(default) :: me + class(state_iterator_t), intent(in) :: it + end function state_iterator_get_matrix_element <>= - function state_iterator_get_matrix_element (it) result (me) + module function state_iterator_get_matrix_element (it) result (me) complex(default) :: me class(state_iterator_t), intent(in) :: it if (it%state%leaf_nodes_store_values) then me = it%node%me else if (it%node%me_index /= 0) then me = it%state%me(it%node%me_index) else me = 0 end if end function state_iterator_get_matrix_element @ %def state_iterator_get_matrix_element @ Set the matrix element value using the state iterator. <>= procedure :: set_matrix_element => state_iterator_set_matrix_element +<>= + module subroutine state_iterator_set_matrix_element (it, value) + class(state_iterator_t), intent(inout) :: it + complex(default), intent(in) :: value + end subroutine state_iterator_set_matrix_element <>= - subroutine state_iterator_set_matrix_element (it, value) + module subroutine state_iterator_set_matrix_element (it, value) class(state_iterator_t), intent(inout) :: it complex(default), intent(in) :: value if (it%node%me_index /= 0) it%state%me(it%node%me_index) = value end subroutine state_iterator_set_matrix_element @ %def state_iterator_set_matrix_element @ <>= procedure :: add_to_matrix_element => state_iterator_add_to_matrix_element +<>= + module subroutine state_iterator_add_to_matrix_element (it, value) + class(state_iterator_t), intent(inout) :: it + complex(default), intent(in) :: value + end subroutine state_iterator_add_to_matrix_element <>= - subroutine state_iterator_add_to_matrix_element (it, value) + module subroutine state_iterator_add_to_matrix_element (it, value) class(state_iterator_t), intent(inout) :: it complex(default), intent(in) :: value if (it%node%me_index /= 0) & it%state%me(it%node%me_index) = it%state%me(it%node%me_index) + value end subroutine state_iterator_add_to_matrix_element @ %def state_iterator_add_to_matrix_element @ \subsection{Operations on quantum states} Return a deep copy of a state matrix. <>= public :: assignment(=) <>= interface assignment(=) module procedure state_matrix_assign end interface +<>= + module subroutine state_matrix_assign (state_out, state_in) + type(state_matrix_t), intent(out) :: state_out + type(state_matrix_t), intent(in), target :: state_in + end subroutine state_matrix_assign <>= - subroutine state_matrix_assign (state_out, state_in) + module subroutine state_matrix_assign (state_out, state_in) type(state_matrix_t), intent(out) :: state_out type(state_matrix_t), intent(in), target :: state_in type(state_iterator_t) :: it if (.not. state_in%is_defined ()) return call state_out%init () call it%init (state_in) do while (it%is_valid ()) call state_out%add_state (it%get_quantum_numbers (), & it%get_me_index ()) call it%advance () end do if (allocated (state_in%me)) then allocate (state_out%me (size (state_in%me))) state_out%me = state_in%me end if state_out%n_sub = state_in%n_sub end subroutine state_matrix_assign @ %def state_matrix_assign @ Determine the indices of all diagonal matrix elements. <>= procedure :: get_diagonal_entries => state_matrix_get_diagonal_entries +<>= + module subroutine state_matrix_get_diagonal_entries (state, i) + class(state_matrix_t), intent(in) :: state + integer, dimension(:), allocatable, intent(out) :: i + end subroutine state_matrix_get_diagonal_entries <>= - subroutine state_matrix_get_diagonal_entries (state, i) + module subroutine state_matrix_get_diagonal_entries (state, i) class(state_matrix_t), intent(in) :: state integer, dimension(:), allocatable, intent(out) :: i integer, dimension(state%n_matrix_elements) :: tmp integer :: n type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:), allocatable :: qn n = 0 call it%init (state) allocate (qn (it%depth)) do while (it%is_valid ()) qn = it%get_quantum_numbers () if (all (qn%are_diagonal ())) then n = n + 1 tmp(n) = it%get_me_index () end if call it%advance () end do allocate (i(n)) if (n > 0) i = tmp(:n) end subroutine state_matrix_get_diagonal_entries @ %def state_matrices_get_diagonal_entries @ Normalize all matrix elements, i.e., multiply by a common factor. Assuming that the factor is nonzero, of course. <>= procedure :: renormalize => state_matrix_renormalize +<>= + module subroutine state_matrix_renormalize (state, factor) + class(state_matrix_t), intent(inout) :: state + complex(default), intent(in) :: factor + end subroutine state_matrix_renormalize <>= - subroutine state_matrix_renormalize (state, factor) + module subroutine state_matrix_renormalize (state, factor) class(state_matrix_t), intent(inout) :: state complex(default), intent(in) :: factor state%me = state%me * factor end subroutine state_matrix_renormalize @ %def state_matrix_renormalize @ Renormalize the state matrix by its trace, if nonzero. The renormalization is reflected in the state-matrix norm. <>= procedure :: normalize_by_trace => state_matrix_normalize_by_trace +<>= + module subroutine state_matrix_normalize_by_trace (state) + class(state_matrix_t), intent(inout) :: state + end subroutine state_matrix_normalize_by_trace <>= - subroutine state_matrix_normalize_by_trace (state) + module subroutine state_matrix_normalize_by_trace (state) class(state_matrix_t), intent(inout) :: state real(default) :: trace trace = state%trace () if (trace /= 0) then state%me = state%me / trace state%norm = state%norm * trace end if end subroutine state_matrix_normalize_by_trace @ %def state_matrix_renormalize_by_trace @ Analogous, but renormalize by maximal (absolute) value. <>= procedure :: normalize_by_max => state_matrix_normalize_by_max +<>= + module subroutine state_matrix_normalize_by_max (state) + class(state_matrix_t), intent(inout) :: state + end subroutine state_matrix_normalize_by_max <>= - subroutine state_matrix_normalize_by_max (state) + module subroutine state_matrix_normalize_by_max (state) class(state_matrix_t), intent(inout) :: state real(default) :: m m = maxval (abs (state%me)) if (m /= 0) then state%me = state%me / m state%norm = state%norm * m end if end subroutine state_matrix_normalize_by_max @ %def state_matrix_renormalize_by_max @ Explicitly set the norm of a state matrix. <>= procedure :: set_norm => state_matrix_set_norm +<>= + module subroutine state_matrix_set_norm (state, norm) + class(state_matrix_t), intent(inout) :: state + real(default), intent(in) :: norm + end subroutine state_matrix_set_norm <>= - subroutine state_matrix_set_norm (state, norm) + module subroutine state_matrix_set_norm (state, norm) class(state_matrix_t), intent(inout) :: state real(default), intent(in) :: norm state%norm = norm end subroutine state_matrix_set_norm @ %def state_matrix_set_norm @ Return the sum of all matrix element values. <>= procedure :: sum => state_matrix_sum +<>= + pure module function state_matrix_sum (state) result (value) + complex(default) :: value + class(state_matrix_t), intent(in) :: state + end function state_matrix_sum <>= - pure function state_matrix_sum (state) result (value) + pure module function state_matrix_sum (state) result (value) complex(default) :: value class(state_matrix_t), intent(in) :: state value = sum (state%me) end function state_matrix_sum @ %def state_matrix_sum @ Return the trace of a state matrix, i.e., the sum over all diagonal values. If [[qn_in]] is provided, only branches that match this quantum-numbers array in flavor and helicity are considered. (This mode is used for selecting a color state.) <>= procedure :: trace => state_matrix_trace +<>= + module function state_matrix_trace (state, qn_in) result (trace) + complex(default) :: trace + class(state_matrix_t), intent(in), target :: state + type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in + end function state_matrix_trace <>= - function state_matrix_trace (state, qn_in) result (trace) + module function state_matrix_trace (state, qn_in) result (trace) complex(default) :: trace class(state_matrix_t), intent(in), target :: state type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in type(quantum_numbers_t), dimension(:), allocatable :: qn type(state_iterator_t) :: it allocate (qn (state%get_depth ())) trace = 0 call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () if (present (qn_in)) then if (.not. all (qn .fhmatch. qn_in)) then call it%advance (); cycle end if end if if (all (qn%are_diagonal ())) then trace = trace + it%get_matrix_element () end if call it%advance () end do end function state_matrix_trace @ %def state_matrix_trace @ Append new states which are color-contracted versions of the existing states. The matrix element index of each color contraction coincides with the index of its origin, so no new matrix elements are generated. After this operation, no [[freeze]] must be performed anymore. <>= procedure :: add_color_contractions => state_matrix_add_color_contractions +<>= + module subroutine state_matrix_add_color_contractions (state) + class(state_matrix_t), intent(inout), target :: state + end subroutine state_matrix_add_color_contractions <>= - subroutine state_matrix_add_color_contractions (state) + module subroutine state_matrix_add_color_contractions (state) class(state_matrix_t), intent(inout), target :: state type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:,:), allocatable :: qn type(quantum_numbers_t), dimension(:,:), allocatable :: qn_con integer, dimension(:), allocatable :: me_index integer :: depth, n_me, i, j depth = state%get_depth () n_me = state%get_n_matrix_elements () allocate (qn (depth, n_me)) allocate (me_index (n_me)) i = 0 call it%init (state) do while (it%is_valid ()) i = i + 1 qn(:,i) = it%get_quantum_numbers () me_index(i) = it%get_me_index () call it%advance () end do do i = 1, n_me call quantum_number_array_make_color_contractions (qn(:,i), qn_con) do j = 1, size (qn_con, 2) call state%add_state (qn_con(:,j), index = me_index(i)) end do end do end subroutine state_matrix_add_color_contractions @ %def state_matrix_add_color_contractions @ This procedure merges two state matrices of equal depth. For each quantum number (flavor, color, helicity), we take the entry from the first argument where defined, otherwise the second one. (If both are defined, we get an off-diagonal matrix.) The resulting trie combines the information of the input tries in all possible ways. Note that values are ignored, all values in the result are zero. <>= public :: merge_state_matrices +<>= + module subroutine merge_state_matrices (state1, state2, state3) + type(state_matrix_t), intent(in), target :: state1, state2 + type(state_matrix_t), intent(out) :: state3 + end subroutine merge_state_matrices <>= - subroutine merge_state_matrices (state1, state2, state3) + module subroutine merge_state_matrices (state1, state2, state3) type(state_matrix_t), intent(in), target :: state1, state2 type(state_matrix_t), intent(out) :: state3 type(state_iterator_t) :: it1, it2 type(quantum_numbers_t), dimension(state1%depth) :: qn1, qn2 if (state1%depth /= state2%depth) then call state1%write () call state2%write () call msg_bug ("State matrices merge impossible: incompatible depths") end if call state3%init () call it1%init (state1) do while (it1%is_valid ()) qn1 = it1%get_quantum_numbers () call it2%init (state2) do while (it2%is_valid ()) qn2 = it2%get_quantum_numbers () call state3%add_state (qn1 .merge. qn2) call it2%advance () end do call it1%advance () end do call state3%freeze () end subroutine merge_state_matrices @ %def merge_state_matrices @ Multiply matrix elements from two state matrices. Choose the elements as given by the integer index arrays, multiply them and store the sum of products in the indicated matrix element. The suffixes mean: c=conjugate first factor; f=include weighting factor. Note that the [[dot_product]] intrinsic function conjugates its first complex argument. This is intended for the [[c]] suffix case, but must be reverted for the plain-product case. We provide analogous subroutines for just summing over state matrix entries. The [[evaluate_sum]] variant includes the state-matrix norm in the evaluation, the [[evaluate_me_sum]] takes into account just the matrix elements proper. <>= procedure :: evaluate_product => state_matrix_evaluate_product procedure :: evaluate_product_cf => state_matrix_evaluate_product_cf procedure :: evaluate_square_c => state_matrix_evaluate_square_c procedure :: evaluate_sum => state_matrix_evaluate_sum procedure :: evaluate_me_sum => state_matrix_evaluate_me_sum +<>= + pure module subroutine state_matrix_evaluate_product & + (state, i, state1, state2, index1, index2) + class(state_matrix_t), intent(inout) :: state + integer, intent(in) :: i + type(state_matrix_t), intent(in) :: state1, state2 + integer, dimension(:), intent(in) :: index1, index2 + end subroutine state_matrix_evaluate_product + pure module subroutine state_matrix_evaluate_product_cf & + (state, i, state1, state2, index1, index2, factor) + class(state_matrix_t), intent(inout) :: state + integer, intent(in) :: i + type(state_matrix_t), intent(in) :: state1, state2 + integer, dimension(:), intent(in) :: index1, index2 + complex(default), dimension(:), intent(in) :: factor + end subroutine state_matrix_evaluate_product_cf + pure module subroutine state_matrix_evaluate_square_c (state, i, state1, index1) + class(state_matrix_t), intent(inout) :: state + integer, intent(in) :: i + type(state_matrix_t), intent(in) :: state1 + integer, dimension(:), intent(in) :: index1 + end subroutine state_matrix_evaluate_square_c + pure module subroutine state_matrix_evaluate_sum (state, i, state1, index1) + class(state_matrix_t), intent(inout) :: state + integer, intent(in) :: i + type(state_matrix_t), intent(in) :: state1 + integer, dimension(:), intent(in) :: index1 + end subroutine state_matrix_evaluate_sum + pure module subroutine state_matrix_evaluate_me_sum (state, i, state1, index1) + class(state_matrix_t), intent(inout) :: state + integer, intent(in) :: i + type(state_matrix_t), intent(in) :: state1 + integer, dimension(:), intent(in) :: index1 + end subroutine state_matrix_evaluate_me_sum <>= - pure subroutine state_matrix_evaluate_product & + pure module subroutine state_matrix_evaluate_product & (state, i, state1, state2, index1, index2) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i type(state_matrix_t), intent(in) :: state1, state2 integer, dimension(:), intent(in) :: index1, index2 state%me(i) = & dot_product (conjg (state1%me(index1)), state2%me(index2)) state%norm = state1%norm * state2%norm end subroutine state_matrix_evaluate_product - pure subroutine state_matrix_evaluate_product_cf & + pure module subroutine state_matrix_evaluate_product_cf & (state, i, state1, state2, index1, index2, factor) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i type(state_matrix_t), intent(in) :: state1, state2 integer, dimension(:), intent(in) :: index1, index2 complex(default), dimension(:), intent(in) :: factor state%me(i) = & dot_product (state1%me(index1), factor * state2%me(index2)) state%norm = state1%norm * state2%norm end subroutine state_matrix_evaluate_product_cf - pure subroutine state_matrix_evaluate_square_c (state, i, state1, index1) + pure module subroutine state_matrix_evaluate_square_c (state, i, state1, index1) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i type(state_matrix_t), intent(in) :: state1 integer, dimension(:), intent(in) :: index1 state%me(i) = & dot_product (state1%me(index1), state1%me(index1)) state%norm = abs (state1%norm) ** 2 end subroutine state_matrix_evaluate_square_c - pure subroutine state_matrix_evaluate_sum (state, i, state1, index1) + pure module subroutine state_matrix_evaluate_sum (state, i, state1, index1) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i type(state_matrix_t), intent(in) :: state1 integer, dimension(:), intent(in) :: index1 state%me(i) = & sum (state1%me(index1)) * state1%norm end subroutine state_matrix_evaluate_sum - pure subroutine state_matrix_evaluate_me_sum (state, i, state1, index1) + pure module subroutine state_matrix_evaluate_me_sum (state, i, state1, index1) class(state_matrix_t), intent(inout) :: state integer, intent(in) :: i type(state_matrix_t), intent(in) :: state1 integer, dimension(:), intent(in) :: index1 state%me(i) = sum (state1%me(index1)) end subroutine state_matrix_evaluate_me_sum @ %def state_matrix_evaluate_product @ %def state_matrix_evaluate_product_cf @ %def state_matrix_evaluate_square_c @ %def state_matrix_evaluate_sum @ %def state_matrix_evaluate_me_sum @ Outer product (of states and matrix elements): <>= public :: outer_multiply <>= interface outer_multiply module procedure outer_multiply_pair module procedure outer_multiply_array end interface @ %def outer_multiply @ This procedure constructs the outer product of two state matrices. +<>= + module subroutine outer_multiply_pair (state1, state2, state3) + type(state_matrix_t), intent(in), target :: state1, state2 + type(state_matrix_t), intent(out) :: state3 + end subroutine outer_multiply_pair <>= - subroutine outer_multiply_pair (state1, state2, state3) + module subroutine outer_multiply_pair (state1, state2, state3) type(state_matrix_t), intent(in), target :: state1, state2 type(state_matrix_t), intent(out) :: state3 type(state_iterator_t) :: it1, it2 type(quantum_numbers_t), dimension(state1%depth) :: qn1 type(quantum_numbers_t), dimension(state2%depth) :: qn2 type(quantum_numbers_t), dimension(state1%depth+state2%depth) :: qn3 complex(default) :: val1, val2 call state3%init (store_values = .true.) call it1%init (state1) do while (it1%is_valid ()) qn1 = it1%get_quantum_numbers () val1 = it1%get_matrix_element () call it2%init (state2) do while (it2%is_valid ()) qn2 = it2%get_quantum_numbers () val2 = it2%get_matrix_element () qn3(:state1%depth) = qn1 qn3(state1%depth+1:) = qn2 call state3%add_state (qn3, value=val1 * val2) call it2%advance () end do call it1%advance () end do call state3%freeze () end subroutine outer_multiply_pair @ %def outer_multiply_state_pair @ This executes the above routine iteratively for an arbitrary number of state matrices. +<>= + module subroutine outer_multiply_array (state_in, state_out) + type(state_matrix_t), dimension(:), intent(in), target :: state_in + type(state_matrix_t), intent(out) :: state_out + end subroutine outer_multiply_array <>= - subroutine outer_multiply_array (state_in, state_out) + module subroutine outer_multiply_array (state_in, state_out) type(state_matrix_t), dimension(:), intent(in), target :: state_in type(state_matrix_t), intent(out) :: state_out type(state_matrix_t), dimension(:), allocatable, target :: state_tmp integer :: i, n n = size (state_in) select case (n) case (0) call state_out%init () case (1) state_out = state_in(1) case (2) call outer_multiply_pair (state_in(1), state_in(2), state_out) case default allocate (state_tmp (n-2)) call outer_multiply_pair (state_in(1), state_in(2), state_tmp(1)) do i = 2, n - 2 call outer_multiply_pair (state_tmp(i-1), state_in(i+1), state_tmp(i)) end do call outer_multiply_pair (state_tmp(n-2), state_in(n), state_out) do i = 1, size(state_tmp) call state_tmp(i)%final () end do end select end subroutine outer_multiply_array @ %def outer_multiply_pair @ %def outer_multiply_array @ \subsection{Factorization} In physical events, the state matrix is factorized into single-particle state matrices. This is essentially a measurement. In a simulation, we select one particular branch of the state matrix with a probability that is determined by the matrix elements at the leaves. (This makes sense only if the state matrix represents a squared amplitude.) The selection is based on a (random) value [[x]] between 0 and one that is provided as the third argument. For flavor and color, we select a unique value for each particle. For polarization, we have three options (modes). Option 1 is to drop helicity information altogether and sum over all diagonal helicities. Option 2 is to select a unique diagonal helicity in the same way as flavor and color. Option 3 is, for each particle, to trace over all remaining helicities in order to obtain an array of independent single-particle helicity matrices. Only branches that match the given quantum-number array [[qn_in]], if present, are considered. For this array, color is ignored. If the optional [[correlated_state]] is provided, it is assigned the correlated density matrix for the selected flavor-color branch, so multi-particle spin correlations remain available even if they are dropped in the single-particle density matrices. This should be done by the caller for the choice [[FM_CORRELATED_HELICITY]], which otherwise is handled as [[FM_IGNORE_HELICITY]]. The algorithm is as follows: First, we determine the normalization by summing over all diagonal matrix elements. In a second scan, we select one of the diagonal matrix elements by a cumulative comparison with the normalized random number. In the corresponding quantum number array, we undefine the helicity entries. Then, we scan the third time. For each branch that matches the selected quantum number array (i.e., definite flavor and color, arbitrary helicity), we determine its contribution to any of the single-particle state matrices. The matrix-element value is added if all other quantum numbers are diagonal, while the helicity of the chosen particle may be arbitrary; this helicity determines the branch in the single-particle state. As a result, flavor and color quantum numbers are selected with the correct probability. Within this subset of states, each single-particle state matrix results from tracing over all other particles. Note that the single-particle state matrices are not normalized. The flag [[ok]] is set to false if the matrix element sum is zero, so factorization is not possible. This can happen if an event did not pass cuts. <>= integer, parameter, public :: FM_IGNORE_HELICITY = 1 integer, parameter, public :: FM_SELECT_HELICITY = 2 integer, parameter, public :: FM_FACTOR_HELICITY = 3 integer, parameter, public :: FM_CORRELATED_HELICITY = 4 @ %def FM_IGNORE_HELICITY FM_SELECT_HELICITY FM_FACTOR_HELICITY @ %def FM_CORRELATED_HELICITY <>= procedure :: factorize => state_matrix_factorize +<>= + module subroutine state_matrix_factorize & + (state, mode, x, ok, single_state, correlated_state, qn_in) + class(state_matrix_t), intent(in), target :: state + integer, intent(in) :: mode + real(default), intent(in) :: x + logical, intent(out) :: ok + type(state_matrix_t), & + dimension(:), allocatable, intent(out) :: single_state + type(state_matrix_t), intent(out), optional :: correlated_state + type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in + end subroutine state_matrix_factorize <>= - subroutine state_matrix_factorize & + module subroutine state_matrix_factorize & (state, mode, x, ok, single_state, correlated_state, qn_in) class(state_matrix_t), intent(in), target :: state integer, intent(in) :: mode real(default), intent(in) :: x logical, intent(out) :: ok type(state_matrix_t), & dimension(:), allocatable, intent(out) :: single_state type(state_matrix_t), intent(out), optional :: correlated_state type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in type(state_iterator_t) :: it real(default) :: s, xt complex(default) :: value integer :: i, depth type(quantum_numbers_t), dimension(:), allocatable :: qn, qn1 type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask logical, dimension(:), allocatable :: diagonal logical, dimension(:,:), allocatable :: mask ok = .true. if (x /= 0) then xt = x * abs (state%trace (qn_in)) else xt = 0 end if s = 0 depth = state%get_depth () allocate (qn (depth), qn1 (depth), diagonal (depth)) call it%init (state) do while (it%is_valid ()) qn = it%get_quantum_numbers () if (present (qn_in)) then if (.not. all (qn .fhmatch. qn_in)) then call it%advance (); cycle end if end if if (all (qn%are_diagonal ())) then value = abs (it%get_matrix_element ()) s = s + value if (s > xt) exit end if call it%advance () end do if (.not. it%is_valid ()) then if (s == 0) ok = .false. call it%init (state) end if allocate (single_state (depth)) do i = 1, depth call single_state(i)%init (store_values = .true.) end do if (present (correlated_state)) & call correlated_state%init (store_values = .true.) qn = it%get_quantum_numbers () select case (mode) case (FM_SELECT_HELICITY) ! single branch selected; shortcut do i = 1, depth call single_state(i)%add_state ([qn(i)], value=value) end do if (.not. present (correlated_state)) then do i = 1, size(single_state) call single_state(i)%freeze () end do return end if end select allocate (qn_mask (depth)) call qn_mask%init (.false., .false., .false., .true.) call qn%undefine (qn_mask) select case (mode) case (FM_FACTOR_HELICITY) allocate (mask (depth, depth)) mask = .false. forall (i = 1:depth) mask(i,i) = .true. end select call it%init (state) do while (it%is_valid ()) qn1 = it%get_quantum_numbers () if (all (qn .match. qn1)) then diagonal = qn1%are_diagonal () value = it%get_matrix_element () select case (mode) case (FM_IGNORE_HELICITY, FM_CORRELATED_HELICITY) !!! trace over diagonal states that match qn if (all (diagonal)) then do i = 1, depth call single_state(i)%add_state & ([qn(i)], value=value, sum_values=.true.) end do end if case (FM_FACTOR_HELICITY) !!! trace over all other particles do i = 1, depth if (all (diagonal .or. mask(:,i))) then call single_state(i)%add_state & ([qn1(i)], value=value, sum_values=.true.) end if end do end select if (present (correlated_state)) & call correlated_state%add_state (qn1, value=value) end if call it%advance () end do do i = 1, depth call single_state(i)%freeze () end do if (present (correlated_state)) & call correlated_state%freeze () end subroutine state_matrix_factorize @ %def state_matrix_factorize @ \subsubsection{Auxiliary functions} <>= procedure :: get_polarization_density_matrix & => state_matrix_get_polarization_density_matrix +<>= + module function state_matrix_get_polarization_density_matrix & + (state) result (pol_matrix) + real(default), dimension(:,:), allocatable :: pol_matrix + class(state_matrix_t), intent(in) :: state + end function state_matrix_get_polarization_density_matrix <>= - function state_matrix_get_polarization_density_matrix (state) result (pol_matrix) + module function state_matrix_get_polarization_density_matrix & + (state) result (pol_matrix) real(default), dimension(:,:), allocatable :: pol_matrix class(state_matrix_t), intent(in) :: state type(node_t), pointer :: current => null () !!! What's the generic way to allocate the matrix? allocate (pol_matrix (4,4)); pol_matrix = 0 if (associated (state%root%child_first)) then current => state%root%child_first do while (associated (current)) call current%qn%write () current => current%next end do else call msg_fatal ("Polarization state not allocated!") end if end function state_matrix_get_polarization_density_matrix @ %def state_matrix_get_polarization_density_matrix @ \subsubsection{Quantum-number matching} This feature allows us to check whether a given string of PDG values matches, in any ordering, any of the flavor combinations that the state matrix provides. We will also request the permutation of the successful match. This type provides an account of the state's flavor content. We store all flavor combinations, as [[pdg]] values, in an array, assuming that the length is uniform. We check only the entries selected by [[mask_match]]. Among those, only the entries selected by [[mask_sort]] are sorted and thus matched without respecting array element order. The entries that correspond to a true value in the associated [[mask]] are sorted. The mapping from the original state to the sorted state is given by the index array [[map]]. <>= public :: state_flv_content_t <>= type :: state_flv_content_t private integer, dimension(:,:), allocatable :: pdg integer, dimension(:,:), allocatable :: map logical, dimension(:), allocatable :: mask contains <> end type state_flv_content_t @ %def state_matrix_flavor_content @ Output (debugging aid). <>= procedure :: write => state_flv_content_write +<>= + module subroutine state_flv_content_write (state_flv, unit) + class(state_flv_content_t), intent(in), target :: state_flv + integer, intent(in), optional :: unit + end subroutine state_flv_content_write <>= - subroutine state_flv_content_write (state_flv, unit) + module subroutine state_flv_content_write (state_flv, unit) class(state_flv_content_t), intent(in), target :: state_flv integer, intent(in), optional :: unit integer :: u, n, d, i, j u = given_output_unit (unit) d = size (state_flv%pdg, 1) n = size (state_flv%pdg, 2) do i = 1, n write (u, "(2x,'PDG =')", advance="no") do j = 1, d write (u, "(1x,I0)", advance="no") state_flv%pdg(j,i) end do write (u, "(' :: map = (')", advance="no") do j = 1, d write (u, "(1x,I0)", advance="no") state_flv%map(j,i) end do write (u, "(' )')") end do end subroutine state_flv_content_write @ %def state_flv_content_write @ Initialize with table length and mask. Each row of the [[map]] array, of length $d$, is initialized with $(0,1,\ldots,d)$. <>= procedure :: init => state_flv_content_init +<>= + module subroutine state_flv_content_init (state_flv, n, mask) + class(state_flv_content_t), intent(out) :: state_flv + integer, intent(in) :: n + logical, dimension(:), intent(in) :: mask + end subroutine state_flv_content_init <>= - subroutine state_flv_content_init (state_flv, n, mask) + module subroutine state_flv_content_init (state_flv, n, mask) class(state_flv_content_t), intent(out) :: state_flv integer, intent(in) :: n logical, dimension(:), intent(in) :: mask integer :: d, i d = size (mask) allocate (state_flv%pdg (d, n), source = 0) allocate (state_flv%map (d, n), source = spread ([(i, i = 1, d)], 2, n)) allocate (state_flv%mask (d), source = mask) end subroutine state_flv_content_init @ %def state_flv_content_init @ Manually fill the entries, one flavor set and mapping at a time. <>= procedure :: set_entry => state_flv_content_set_entry +<>= + module subroutine state_flv_content_set_entry (state_flv, i, pdg, map) + class(state_flv_content_t), intent(inout) :: state_flv + integer, intent(in) :: i + integer, dimension(:), intent(in) :: pdg, map + end subroutine state_flv_content_set_entry <>= - subroutine state_flv_content_set_entry (state_flv, i, pdg, map) + module subroutine state_flv_content_set_entry (state_flv, i, pdg, map) class(state_flv_content_t), intent(inout) :: state_flv integer, intent(in) :: i integer, dimension(:), intent(in) :: pdg, map state_flv%pdg(:,i) = pdg where (map /= 0) state_flv%map(:,i) = map end where end subroutine state_flv_content_set_entry @ %def state_flv_content_set_entry @ Given a state matrix, determine the flavor content. That is, scan the state matrix and extract flavor only, build a new state matrix from that. <>= procedure :: fill => state_flv_content_fill +<>= + module subroutine state_flv_content_fill & + (state_flv, state_full, mask) + class(state_flv_content_t), intent(out) :: state_flv + type(state_matrix_t), intent(in), target :: state_full + logical, dimension(:), intent(in) :: mask + end subroutine state_flv_content_fill <>= - subroutine state_flv_content_fill & + module subroutine state_flv_content_fill & (state_flv, state_full, mask) class(state_flv_content_t), intent(out) :: state_flv type(state_matrix_t), intent(in), target :: state_full logical, dimension(:), intent(in) :: mask type(state_matrix_t), target :: state_tmp type(state_iterator_t) :: it type(flavor_t), dimension(:), allocatable :: flv integer, dimension(:), allocatable :: pdg, pdg_subset integer, dimension(:), allocatable :: idx, map_subset, idx_subset, map type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: n, d, c, i call state_tmp%init () d = state_full%get_depth () allocate (flv (d), qn (d), pdg (d), idx (d), map (d)) idx = [(i, i = 1, d)] c = count (mask) allocate (pdg_subset (c), map_subset (c), idx_subset (c)) call it%init (state_full) do while (it%is_valid ()) flv = it%get_flavor () call qn%init (flv) call state_tmp%add_state (qn) call it%advance () end do n = state_tmp%get_n_leaves () call state_flv%init (n, mask) i = 0 call it%init (state_tmp) do while (it%is_valid ()) i = i + 1 flv = it%get_flavor () pdg = flv%get_pdg () idx_subset = pack (idx, mask) pdg_subset = pack (pdg, mask) map_subset = order_abs (pdg_subset) map = unpack (idx_subset (map_subset), mask, idx) call state_flv%set_entry (i, & unpack (pdg_subset(map_subset), mask, pdg), & order (map)) call it%advance () end do call state_tmp%final () end subroutine state_flv_content_fill @ %def state_flv_content_fill @ Match a given flavor string against the flavor content. We sort the input string and check whether it matches any of the stored strings. If yes, return the mapping. Only PDG entries under the preset mask are sorted before matching. The other entries must match exactly (i.e., without reordering). A zero entry matches anything. In any case, the length of the PDG string must be equal to the length $d$ of the individual flavor-state entries. <>= procedure :: match => state_flv_content_match +<>= + module subroutine state_flv_content_match (state_flv, pdg, success, map) + class(state_flv_content_t), intent(in) :: state_flv + integer, dimension(:), intent(in) :: pdg + logical, intent(out) :: success + integer, dimension(:), intent(out) :: map + end subroutine state_flv_content_match <>= - subroutine state_flv_content_match (state_flv, pdg, success, map) + module subroutine state_flv_content_match (state_flv, pdg, success, map) class(state_flv_content_t), intent(in) :: state_flv integer, dimension(:), intent(in) :: pdg logical, intent(out) :: success integer, dimension(:), intent(out) :: map integer, dimension(:), allocatable :: pdg_subset, pdg_sorted, map1, map2 integer, dimension(:), allocatable :: idx, map_subset, idx_subset integer :: i, n, c, d c = count (state_flv%mask) d = size (state_flv%pdg, 1) n = size (state_flv%pdg, 2) allocate (idx (d), source = [(i, i = 1, d)]) allocate (idx_subset (c), pdg_subset (c), map_subset (c)) allocate (pdg_sorted (d), map1 (d), map2 (d)) idx_subset = pack (idx, state_flv%mask) pdg_subset = pack (pdg, state_flv%mask) map_subset = order_abs (pdg_subset) pdg_sorted = unpack (pdg_subset(map_subset), state_flv%mask, pdg) success = .false. do i = 1, n if (all (pdg_sorted == state_flv%pdg(:,i) & .or. pdg_sorted == 0)) then success = .true. exit end if end do if (success) then map1 = state_flv%map(:,i) map2 = unpack (idx_subset(map_subset), state_flv%mask, idx) map = map2(map1) where (pdg == 0) map = 0 end if end subroutine state_flv_content_match @ %def state_flv_content_match @ Check if a given PDG code occurs anywhere in the table. <>= procedure :: contains => state_flv_content_contains +<>= + module function state_flv_content_contains (state_flv, pdg) result (success) + class(state_flv_content_t), intent(in) :: state_flv + integer, intent(in) :: pdg + logical :: success + end function state_flv_content_contains <>= - function state_flv_content_contains (state_flv, pdg) result (success) + module function state_flv_content_contains (state_flv, pdg) result (success) class(state_flv_content_t), intent(in) :: state_flv integer, intent(in) :: pdg logical :: success success = any (state_flv%pdg == pdg) end function state_flv_content_contains @ %def state_flv_content_contains @ <>= elemental function pacify_complex (c_in) result (c_pac) complex(default), intent(in) :: c_in complex(default) :: c_pac c_pac = c_in if (real(c_pac) == -real(c_pac)) then c_pac = & cmplx (0._default, aimag(c_pac), kind=default) end if if (aimag(c_pac) == -aimag(c_pac)) then c_pac = & cmplx (real(c_pac), 0._default, kind=default) end if end function pacify_complex @ %def pacify_complex @ Looks for flavor structures that only differ by a permutation of the masked flavors. The result is returned in form of a mask which is [[.true.]] at the positions of a duplicate flavor structure from the second encounter on. This routine implements the naive approach: We go through all flavor structures and compare each one with each preceeding one. This works but is $\mathcal{O}(n^2)$ in the number of flavor structures. Using a table to remember which flavor structure has already been encountered, if would be possible to find the duplicates in $\mathcal{O}(n)$. <>= procedure :: find_duplicates => state_flv_content_find_duplicates +<>= + module subroutine state_flv_content_find_duplicates (state_flv, duplicate_mask) + class(state_flv_content_t), intent(in) :: state_flv + logical, dimension(:), allocatable, intent(out) :: duplicate_mask + end subroutine state_flv_content_find_duplicates <>= - subroutine state_flv_content_find_duplicates (state_flv, duplicate_mask) + module subroutine state_flv_content_find_duplicates (state_flv, duplicate_mask) class(state_flv_content_t), intent(in) :: state_flv logical, dimension(:), allocatable, intent(out) :: duplicate_mask integer, dimension(:), allocatable :: flvst integer :: i1, i2, n_flvsts logical :: found_once n_flvsts = size (state_flv%pdg, 2) allocate (duplicate_mask (n_flvsts)) duplicate_mask = .false. do i1 = 1, n_flvsts found_once = .false. flvst = state_flv%pdg(:,i1) do i2 = 1, i1 if (all(flvst == state_flv%pdg(:,i2))) then if (found_once) then duplicate_mask(i1) = .true. exit else found_once = .true. end if end if end do end do end subroutine state_flv_content_find_duplicates @ %def state_flv_content_find_duplicates @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[state_matrices_ut.f90]]>>= <> module state_matrices_ut use unit_tests use state_matrices_uti <> <> contains <> end module state_matrices_ut @ %def state_matrices_ut @ <<[[state_matrices_uti.f90]]>>= <> module state_matrices_uti <> use io_units use format_defs, only: FMT_19 use flavors use colors use helicities use quantum_numbers use state_matrices <> <> contains <> end module state_matrices_uti @ %def state_matrices_ut @ API: driver for the unit tests below. <>= public :: state_matrix_test <>= subroutine state_matrix_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine state_matrix_test @ %def state_matrix_test @ Create two quantum states of equal depth and merge them. <>= call test (state_matrix_1, "state_matrix_1", & "check merge of quantum states of equal depth", & u, results) <>= public :: state_matrix_1 <>= subroutine state_matrix_1 (u) integer, intent(in) :: u type(state_matrix_t) :: state1, state2, state3 type(flavor_t), dimension(3) :: flv type(color_t), dimension(3) :: col type(quantum_numbers_t), dimension(3) :: qn write (u, "(A)") "* Test output: state_matrix_1" write (u, "(A)") "* Purpose: create and merge two quantum states" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") write (u, "(A)") "* State matrix 1" write (u, "(A)") call state1%init () call flv%init ([1, 2, 11]) call qn%init (flv, helicity ([ 1, 1, 1])) call state1%add_state (qn) call qn%init (flv, helicity ([ 1, 1, 1], [-1, 1, -1])) call state1%add_state (qn) call state1%freeze () call state1%write (u) write (u, "(A)") write (u, "(A)") "* State matrix 2" write (u, "(A)") call state2%init () call col(1)%init ([501]) call col(2)%init ([-501]) call col(3)%init ([0]) call qn%init (col, helicity ([-1, -1, 0])) call state2%add_state (qn) call col(3)%init ([99]) call qn%init (col, helicity ([-1, -1, 0])) call state2%add_state (qn) call state2%freeze () call state2%write (u) write (u, "(A)") write (u, "(A)") "* Merge the state matrices" write (u, "(A)") call merge_state_matrices (state1, state2, state3) call state3%write (u) write (u, "(A)") write (u, "(A)") "* Collapse the state matrix" write (u, "(A)") call state3%collapse (quantum_numbers_mask (.false., .false., & [.true.,.false.,.false.])) call state3%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") call state1%final () call state2%final () call state3%final () write (u, "(A)") write (u, "(A)") "* Test output end: state_matrix_1" write (u, "(A)") end subroutine state_matrix_1 @ %def state_matrix_1 @ Create a correlated three-particle state matrix and factorize it. <>= call test (state_matrix_2, "state_matrix_2", & "check factorizing 3-particle state matrix", & u, results) <>= public :: state_matrix_2 <>= subroutine state_matrix_2 (u) integer, intent(in) :: u type(state_matrix_t) :: state type(state_matrix_t), dimension(:), allocatable :: single_state type(state_matrix_t) :: correlated_state integer :: f, h11, h12, h21, h22, i, mode type(flavor_t), dimension(2) :: flv type(color_t), dimension(2) :: col type(helicity_t), dimension(2) :: hel type(quantum_numbers_t), dimension(2) :: qn logical :: ok write (u, "(A)") write (u, "(A)") "* Test output: state_matrix_2" write (u, "(A)") "* Purpose: factorize correlated 3-particle state" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call state%init () do f = 1, 2 do h11 = -1, 1, 2 do h12 = -1, 1, 2 do h21 = -1, 1, 2 do h22 = -1, 1, 2 call flv%init ([f, -f]) call col(1)%init ([1]) call col(2)%init ([-1]) call hel%init ([h11,h12], [h21, h22]) call qn%init (flv, col, hel) call state%add_state (qn) end do end do end do end do end do call state%freeze () call state%write (u) write (u, "(A)") write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") & "* Trace = ", state%trace () write (u, "(A)") do mode = 1, 3 write (u, "(A)") write (u, "(A,I1)") "* Mode = ", mode call state%factorize & (mode, 0.15_default, ok, single_state, correlated_state) do i = 1, size (single_state) write (u, "(A)") call single_state(i)%write (u) write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") & "Trace = ", single_state(i)%trace () end do write (u, "(A)") call correlated_state%write (u) write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") & "Trace = ", correlated_state%trace () do i = 1, size(single_state) call single_state(i)%final () end do call correlated_state%final () end do write (u, "(A)") write (u, "(A)") "* Cleanup" call state%final () write (u, "(A)") write (u, "(A)") "* Test output end: state_matrix_2" end subroutine state_matrix_2 @ %def state_matrix_2 @ Create a colored state matrix and add color contractions. <>= call test (state_matrix_3, "state_matrix_3", & "check factorizing 3-particle state matrix", & u, results) <>= public :: state_matrix_3 <>= subroutine state_matrix_3 (u) use physics_defs, only: HADRON_REMNANT_TRIPLET, HADRON_REMNANT_OCTET integer, intent(in) :: u type(state_matrix_t) :: state type(flavor_t), dimension(4) :: flv type(color_t), dimension(4) :: col type(quantum_numbers_t), dimension(4) :: qn write (u, "(A)") "* Test output: state_matrix_3" write (u, "(A)") "* Purpose: add color connections to colored state" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") call state%init () call flv%init ([ 1, -HADRON_REMNANT_TRIPLET, -1, HADRON_REMNANT_TRIPLET ]) call col(1)%init ([17]) call col(2)%init ([-17]) call col(3)%init ([-19]) call col(4)%init ([19]) call qn%init (flv, col) call state%add_state (qn) call flv%init ([ 1, -HADRON_REMNANT_TRIPLET, 21, HADRON_REMNANT_OCTET ]) call col(1)%init ([17]) call col(2)%init ([-17]) call col(3)%init ([3, -5]) call col(4)%init ([5, -3]) call qn%init (flv, col) call state%add_state (qn) call state%freeze () write (u, "(A)") "* State:" write (u, "(A)") call state%write (u) call state%add_color_contractions () write (u, "(A)") "* State with contractions:" write (u, "(A)") call state%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call state%final () write (u, "(A)") write (u, "(A)") "* Test output end: state_matrx_3" end subroutine state_matrix_3 @ %def state_matrix_3 @ Create a correlated three-particle state matrix, write it to file and read again. <>= call test (state_matrix_4, "state_matrix_4", & "check raw I/O", & u, results) <>= public :: state_matrix_4 <>= subroutine state_matrix_4 (u) integer, intent(in) :: u type(state_matrix_t), allocatable :: state integer :: f, h11, h12, h21, h22, i type(flavor_t), dimension(2) :: flv type(color_t), dimension(2) :: col type(helicity_t), dimension(2) :: hel type(quantum_numbers_t), dimension(2) :: qn integer :: unit, iostat write (u, "(A)") write (u, "(A)") "* Test output: state_matrix_4" write (u, "(A)") "* Purpose: raw I/O for correlated 3-particle state" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") allocate (state) call state%init () do f = 1, 2 do h11 = -1, 1, 2 do h12 = -1, 1, 2 do h21 = -1, 1, 2 do h22 = -1, 1, 2 call flv%init ([f, -f]) call col(1)%init ([1]) call col(2)%init ([-1]) call hel%init ([h11, h12], [h21, h22]) call qn%init (flv, col, hel) call state%add_state (qn) end do end do end do end do end do call state%freeze () call state%set_norm (3._default) do i = 1, state%get_n_leaves () call state%set_matrix_element (i, cmplx (2 * i, 2 * i + 1, default)) end do call state%write (u) write (u, "(A)") write (u, "(A)") "* Write to file and read again " write (u, "(A)") unit = free_unit () open (unit, action="readwrite", form="unformatted", status="scratch") call state%write_raw (unit) call state%final () deallocate (state) allocate(state) rewind (unit) call state%read_raw (unit, iostat=iostat) close (unit) call state%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call state%final () deallocate (state) write (u, "(A)") write (u, "(A)") "* Test output end: state_matrix_4" end subroutine state_matrix_4 @ %def state_matrix_4 @ Create a flavor-content object for a given state matrix and match it against trial flavor (i.e., PDG) strings. <>= call test (state_matrix_5, "state_matrix_5", & "check flavor content", & u, results) <>= public :: state_matrix_5 <>= subroutine state_matrix_5 (u) integer, intent(in) :: u type(state_matrix_t), allocatable, target :: state type(state_iterator_t) :: it type(state_flv_content_t), allocatable :: state_flv type(flavor_t), dimension(4) :: flv1, flv2, flv3, flv4 type(color_t), dimension(4) :: col1, col2 type(helicity_t), dimension(4) :: hel1, hel2, hel3 type(quantum_numbers_t), dimension(4) :: qn logical, dimension(4) :: mask write (u, "(A)") "* Test output: state_matrix_5" write (u, "(A)") "* Purpose: check flavor-content state" write (u, "(A)") write (u, "(A)") "* Set up arbitrary state matrix" write (u, "(A)") call flv1%init ([1, 4, 2, 7]) call flv2%init ([1, 3,-3, 8]) call flv3%init ([5, 6, 3, 7]) call flv4%init ([6, 3, 5, 8]) call hel1%init ([0, 1, -1, 0]) call hel2%init ([0, 1, 1, 1]) call hel3%init ([1, 0, 0, 0]) call col1(1)%init ([0]) call col1(2)%init ([0]) call col1(3)%init ([0]) call col1(4)%init ([0]) call col2(1)%init ([5, -6]) call col2(2)%init ([0]) call col2(3)%init ([6, -5]) call col2(4)%init ([0]) allocate (state) call state%init () call qn%init (flv1, col1, hel1) call state%add_state (qn) call qn%init (flv1, col1, hel2) call state%add_state (qn) call qn%init (flv3, col1, hel3) call state%add_state (qn) call qn%init (flv4, col1, hel3) call state%add_state (qn) call qn%init (flv1, col2, hel3) call state%add_state (qn) call qn%init (flv2, col2, hel2) call state%add_state (qn) call qn%init (flv2, col2, hel1) call state%add_state (qn) call qn%init (flv2, col1, hel1) call state%add_state (qn) call qn%init (flv3, col1, hel1) call state%add_state (qn) call qn%init (flv3, col2, hel3) call state%add_state (qn) call qn%init (flv1, col1, hel1) call state%add_state (qn) write (u, "(A)") "* Quantum number content" write (u, "(A)") call it%init (state) do while (it%is_valid ()) call quantum_numbers_write (it%get_quantum_numbers (), u) write (u, *) call it%advance () end do write (u, "(A)") write (u, "(A)") "* Extract the flavor content" write (u, "(A)") mask = [.true., .true., .true., .false.] allocate (state_flv) call state_flv%fill (state, mask) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Match trial sets" write (u, "(A)") call check ([1, 2, 3, 0]) call check ([1, 4, 2, 0]) call check ([4, 2, 1, 0]) call check ([1, 3, -3, 0]) call check ([1, -3, 3, 0]) call check ([6, 3, 5, 0]) write (u, "(A)") write (u, "(A)") "* Determine the flavor content with mask" write (u, "(A)") mask = [.false., .true., .true., .false.] call state_flv%fill (state, mask) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Match trial sets" write (u, "(A)") call check ([1, 2, 3, 0]) call check ([1, 4, 2, 0]) call check ([4, 2, 1, 0]) call check ([1, 3, -3, 0]) call check ([1, -3, 3, 0]) call check ([6, 3, 5, 0]) write (u, "(A)") write (u, "(A)") "* Cleanup" deallocate (state_flv) call state%final () deallocate (state) write (u, "(A)") write (u, "(A)") "* Test output end: state_matrix_5" contains subroutine check (pdg) integer, dimension(4), intent(in) :: pdg integer, dimension(4) :: map logical :: success call state_flv%match (pdg, success, map) write (u, "(2x,4(1x,I0),':',1x,L1)", advance="no") pdg, success if (success) then write (u, "(2x,'map = (',4(1x,I0),' )')") map else write (u, *) end if end subroutine check end subroutine state_matrix_5 @ %def state_matrix_5 @ Create a state matrix with full flavor, color and helicity information. Afterwards, reduce such that it is only differential in flavor and initial-state helicities. This is used when preparing states for beam- polarized computations with external matrix element providers. <>= call test (state_matrix_6, "state_matrix_6", & "check state matrix reduction", & u, results) <>= public :: state_matrix_6 <>= subroutine state_matrix_6 (u) integer, intent(in) :: u type(state_matrix_t), allocatable :: state_orig, state_reduced type(flavor_t), dimension(4) :: flv type(helicity_t), dimension(4) :: hel type(color_t), dimension(4) :: col type(quantum_numbers_t), dimension(4) :: qn type(quantum_numbers_mask_t), dimension(4) :: qn_mask integer :: h1, h2, h3 , h4 integer :: n_states = 0 write (u, "(A)") "* Test output: state_matrix_6" write (u, "(A)") "* Purpose: Check state matrix reduction" write (u, "(A)") write (u, "(A)") "* Set up helicity-diagonal state matrix" write (u, "(A)") allocate (state_orig) call state_orig%init () call flv%init ([11, -11, 1, -1]) call col(3)%init ([1]) call col(4)%init ([-1]) 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]) call qn%init (flv, col, hel) call state_orig%add_state (qn) end do end do end do end do call state_orig%freeze () write (u, "(A)") "* Original state: " write (u, "(A)") call state_orig%write (u) write (u, "(A)") write (u, "(A)") "* Setup quantum mask: " call qn_mask%init ([.false., .false., .false., .false.], & [.true., .true., .true., .true.], & [.false., .false., .true., .true.]) call quantum_numbers_mask_write (qn_mask, u) write (u, "(A)") write (u, "(A)") "* Reducing the state matrix using above mask" write (u, "(A)") allocate (state_reduced) call state_orig%reduce (qn_mask, state_reduced) write (u, "(A)") "* Reduced state matrix: " call state_reduced%write (u) write (u, "(A)") "* Test output end: state_matrix_6" end subroutine state_matrix_6 @ %def state_matrix_6 @ Create a state matrix with full flavor, color and helicity information. Afterwards, reduce such that it is only differential in flavor and initial-state helicities, and keeping old indices. Afterwards reorder the reduced state matrix in accordance to the original state matrix. <>= call test (state_matrix_7, "state_matrix_7", & "check ordered state matrix reduction", & u, results) <>= public :: state_matrix_7 <>= subroutine state_matrix_7 (u) integer, intent(in) :: u type(state_matrix_t), allocatable :: state_orig, state_reduced, & state_ordered type(flavor_t), dimension(4) :: flv type(helicity_t), dimension(4) :: hel type(color_t), dimension(4) :: col type(quantum_numbers_t), dimension(4) :: qn type(quantum_numbers_mask_t), dimension(4) :: qn_mask integer :: h1, h2, h3 , h4 integer :: n_states = 0 write (u, "(A)") "* Test output: state_matrix_7" write (u, "(A)") "* Purpose: Check ordered state matrix reduction" write (u, "(A)") write (u, "(A)") "* Set up helicity-diagonal state matrix" write (u, "(A)") allocate (state_orig) call state_orig%init () call flv%init ([11, -11, 1, -1]) call col(3)%init ([1]) call col(4)%init ([-1]) 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]) call qn%init (flv, col, hel) call state_orig%add_state (qn) end do end do end do end do call state_orig%freeze () write (u, "(A)") "* Original state: " write (u, "(A)") call state_orig%write (u) write (u, "(A)") write (u, "(A)") "* Setup quantum mask: " call qn_mask%init ([.false., .false., .false., .false.], & [.true., .true., .true., .true.], & [.false., .false., .true., .true.]) call quantum_numbers_mask_write (qn_mask, u) write (u, "(A)") write (u, "(A)") "* Reducing the state matrix using above mask and keeping the old indices:" write (u, "(A)") allocate (state_reduced) call state_orig%reduce (qn_mask, state_reduced, keep_me_index = .true.) write (u, "(A)") "* Reduced state matrix with kept indices: " call state_reduced%write (u) write (u, "(A)") write (u, "(A)") "* Reordering reduced state matrix:" write (u, "(A)") allocate (state_ordered) call state_reduced%reorder_me (state_ordered) write (u, "(A)") "* Reduced and ordered state matrix:" call state_ordered%write (u) write (u, "(A)") "* Test output end: state_matrix_6" end subroutine state_matrix_7 @ %def state_matrix_7 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Interactions} This module defines the [[interaction_t]] type. It is an extension of the [[state_matrix_t]] type. The state matrix is a representation of a multi-particle density matrix. It implements all possible flavor, color, and quantum-number assignments of the entries in a generic density matrix, and it can hold a complex matrix element for each entry. (Note that this matrix can hold non-diagonal entries in color and helicity space.) The [[interaction_t]] object associates this with a list of momenta, such that the whole object represents a multi-particle state. The [[interaction_t]] holds information about which particles are incoming, virtual (i.e., kept for the records), or outgoing. Each particle can be associated to a source within another interaction. This allows us to automatically fill those interaction momenta which have been computed or defined elsewhere. It also contains internal parent-child relations and flags for (virtual) particles which are to be treated as resonances. A quantum-number mask array summarizes, for each particle within the interaction, the treatment of flavor, color, or helicity (expose or ignore). A list of locks states which particles are bound to have an identical quantum-number mask. This is useful when the mask is changed at one place. <<[[interactions.f90]]>>= <> module interactions <> - use io_units - use diagnostics - use sorting use lorentz use flavors use colors use helicities use quantum_numbers use state_matrices <> <> <> <> + interface +<> + end interface + +end module interactions +@ %def interactions +<<[[interactions_sub.f90]]>>= +<> + +submodule (interactions) interactions_s + + use io_units + use diagnostics + use sorting + + implicit none + contains <> -end module interactions -@ %def interactions +end submodule interactions_s + +@ %def interactions_s @ Given an ordered list of quantum numbers (without any subtraction index) map this list to a state matrix, such that each list index corresponds to an index of a set of quantum numbers in the state matrix, hence, the matrix element. The (unphysical) subtraction index is not a genuine quantum number and as such handled specially. <>= public :: qn_index_map_t <>= type :: qn_index_map_t private type(quantum_numbers_t), dimension(:, :), allocatable :: qn_flv type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel logical :: flip_hel = .false. integer :: n_flv = 0, n_hel = 0, n_sub = 0 integer, dimension(:, :, :), allocatable :: index integer, dimension(:,:), allocatable :: sf_index_born, sf_index_real contains <> end type qn_index_map_t @ %def qn_index_map_t @ Construct a mapping from interaction to an array of (sorted) quantum numbers. We strip all non-elementary particles (like beam) from the quantum numbers which we retrieve from the interaction. We consider helicity matrix elements only, when [[qn_hel]] is allocated. Else the helicity index is handled trivially as [[1]]. For the rescaling of the structure functions in the real subtraction and DGLAP components we need a mapping (initialized by [[qn_index_map_init_sf]]) from the real and born flavor structure indices to the structure function chain interaction matrix element with the correct initial state quantum numbers. This is stored in [[sf_index_born]] and [[sf_index_real]]. The array [[index]] is only needed for the initialisation of the Born and real index arrays and is therefore deallocated again. <>= generic :: init => init_trivial, & init_involved, & init_sf procedure, private :: init_trivial => qn_index_map_init_trivial procedure, private :: init_involved => qn_index_map_init_involved procedure, private :: init_sf => qn_index_map_init_sf +<>= + module subroutine qn_index_map_init_trivial (self, int) + class(qn_index_map_t), intent(out) :: self + class(interaction_t), intent(in) :: int + end subroutine qn_index_map_init_trivial + module subroutine qn_index_map_init_involved (self, int, qn_flv, n_sub, qn_hel) + class(qn_index_map_t), intent(out) :: self + type(interaction_t), intent(in) :: int + type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_flv + integer, intent(in) :: n_sub + type(quantum_numbers_t), dimension(:, :), intent(in), optional :: qn_hel + end subroutine qn_index_map_init_involved + module subroutine qn_index_map_init_sf (self, int, qn_flv, n_flv_born, n_flv_real) + class(qn_index_map_t), intent(out) :: self + type(interaction_t), intent(in) :: int + integer, intent(in) :: n_flv_born, n_flv_real + type(quantum_numbers_t), dimension(:,:), intent(in) :: qn_flv + end subroutine qn_index_map_init_sf <>= - subroutine qn_index_map_init_trivial (self, int) + module subroutine qn_index_map_init_trivial (self, int) class(qn_index_map_t), intent(out) :: self class(interaction_t), intent(in) :: int integer :: qn self%n_flv = int%get_n_matrix_elements () self%n_hel = 1 self%n_sub = 0 allocate (self%index(self%n_flv, self%n_hel, 0:self%n_sub), source = 0) do qn = 1, self%n_flv self%index(qn, 1, 0) = qn end do end subroutine qn_index_map_init_trivial - subroutine qn_index_map_init_involved (self, int, qn_flv, n_sub, qn_hel) + module subroutine qn_index_map_init_involved (self, int, qn_flv, n_sub, qn_hel) class(qn_index_map_t), intent(out) :: self type(interaction_t), intent(in) :: int type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_flv integer, intent(in) :: n_sub type(quantum_numbers_t), dimension(:, :), intent(in), optional :: qn_hel type(quantum_numbers_t), dimension(:), allocatable :: qn, qn_int integer :: i, i_flv, i_hel, i_sub self%qn_flv = qn_flv self%n_flv = size (qn_flv, dim=2) self%n_sub = n_sub if (present (qn_hel)) then if (size (qn_flv, dim=1) /= size (qn_hel, dim=1)) then call msg_bug ("[qn_index_map_init] number of particles does not match.") end if self%qn_hel = qn_hel self%n_hel = size (qn_hel, dim=2) else self%n_hel = 1 end if allocate (self%index (self%n_flv, self%n_hel, 0:self%n_sub), source=0) associate (n_me => int%get_n_matrix_elements ()) do i = 1, n_me qn_int = int%get_quantum_numbers (i, by_me_index = .true.) qn = pack (qn_int, qn_int%are_hard_process ()) i_flv = find_flv_index (self, qn) i_hel = 1; if (allocated (self%qn_hel)) & i_hel = find_hel_index (self, qn) i_sub = find_sub_index (self, qn) self%index(i_flv, i_hel, i_sub) = i end do end associate contains integer function find_flv_index (self, qn) result (i_flv) type(qn_index_map_t), intent(in) :: self type(quantum_numbers_t), dimension(:), intent(in) :: qn integer :: j i_flv = 0 do j = 1, self%n_flv if (.not. all (qn .fmatch. self%qn_flv(:, j))) cycle i_flv = j exit end do if (i_flv < 1) then call msg_message ("QN:") call quantum_numbers_write (qn) call msg_message ("") call msg_message ("QN_FLV:") do j = 1, self%n_flv call quantum_numbers_write (self%qn_flv(:, j)) call msg_message ("") end do call msg_bug ("[find_flv_index] could not find flv in qn_flv.") end if end function find_flv_index integer function find_hel_index (self, qn) result (i_hel) type(qn_index_map_t), intent(in) :: self type(quantum_numbers_t), dimension(:), intent(in) :: qn integer :: j i_hel = 0 do j = 1, self%n_hel if (.not. all (qn .hmatch. self%qn_hel(:, j))) cycle i_hel = j exit end do if (i_hel < 1) then call msg_message ("QN:") call quantum_numbers_write (qn) call msg_message ("") call msg_message ("QN_HEL:") do j = 1, self%n_hel call quantum_numbers_write (self%qn_hel(:, j)) call msg_message ("") end do call msg_bug ("[find_hel_index] could not find hel in qn_hel.") end if end function find_hel_index integer function find_sub_index (self, qn) result (i_sub) type(qn_index_map_t), intent(in) :: self type(quantum_numbers_t), dimension(:), intent(in) :: qn integer :: s i_sub = -1 do s = 0, self%n_sub if ((all (pack(qn%get_sub (), qn%get_sub () > 0) == s)) & .or. (all (qn%get_sub () == 0) .and. s == 0)) then i_sub = s exit end if end do if (i_sub < 0) then call msg_message ("QN:") call quantum_numbers_write (qn) call msg_bug ("[find_sub_index] could not find sub in qn.") end if end function find_sub_index end subroutine qn_index_map_init_involved - subroutine qn_index_map_init_sf (self, int, qn_flv, n_flv_born, n_flv_real) + module subroutine qn_index_map_init_sf (self, int, qn_flv, n_flv_born, n_flv_real) class(qn_index_map_t), intent(out) :: self type(interaction_t), intent(in) :: int integer, intent(in) :: n_flv_born, n_flv_real type(quantum_numbers_t), dimension(:,:), intent(in) :: qn_flv type(quantum_numbers_t), dimension(:,:), allocatable :: qn_int type(quantum_numbers_t), dimension(:), allocatable :: qn_int_tmp integer :: i, i_sub, n_flv, n_hard n_flv = int%get_n_matrix_elements () qn_int_tmp = int%get_quantum_numbers (1, by_me_index = .true.) n_hard = count (qn_int_tmp%are_hard_process ()) allocate (qn_int(n_hard, n_flv)) do i = 1, n_flv qn_int_tmp = int%get_quantum_numbers (i, by_me_index = .true.) qn_int(:, i) = pack (qn_int_tmp, qn_int_tmp%are_hard_process ()) end do call self%init (int, qn_int, int%get_n_sub ()) allocate (self%sf_index_born(n_flv_born, 0:self%n_sub)) allocate (self%sf_index_real(n_flv_real, 0:self%n_sub)) do i_sub = 0, self%n_sub do i = 1, n_flv_born self%sf_index_born(i, i_sub) = self%get_index_by_qn (qn_flv(:,i), i_sub) end do do i = 1, n_flv_real self%sf_index_real(i, i_sub) = & self%get_index_by_qn (qn_flv(:,n_flv_born + i), i_sub) end do end do deallocate (self%index) end subroutine qn_index_map_init_sf @ %def qn_index_map_init_trivial @ %def qn_index_map_init_involved @ %def qn_index_map_init_sf @ Write the index map to unit. <>= procedure :: write => qn_index_map_write +<>= + module subroutine qn_index_map_write (self, unit) + class(qn_index_map_t), intent(in) :: self + integer, intent(in), optional :: unit + end subroutine qn_index_map_write <>= - subroutine qn_index_map_write (self, unit) + module subroutine qn_index_map_write (self, unit) class(qn_index_map_t), intent(in) :: self integer, intent(in), optional :: unit integer :: u, i_flv, i_hel, i_sub u = given_output_unit (unit); if (u < 0) return write (u, *) "flip_hel: ", self%flip_hel do i_flv = 1, self%n_flv if (allocated (self%qn_flv)) & call quantum_numbers_write (self%qn_flv(:, i_flv)) write (u, *) do i_hel = 1, self%n_hel if (allocated (self%qn_hel)) then call quantum_numbers_write (self%qn_hel(:, i_hel)) write (u, *) end if do i_sub = 0, self%n_sub write (u, *) & "(", i_flv, ",", i_hel, ",", i_sub, ") => ", self%index(i_flv, i_hel, i_sub) end do end do end do end subroutine qn_index_map_write @ %def qn_index_map_write @ Set helicity convention. If [[flip]], then we flip the helicities of anti-particles and we remap the indices accordingly. <>= procedure :: set_helicity_flip => qn_index_map_set_helicity_flip +<>= + module subroutine qn_index_map_set_helicity_flip (self, yorn) + class(qn_index_map_t), intent(inout) :: self + logical, intent(in) :: yorn + end subroutine qn_index_map_set_helicity_flip <>= - subroutine qn_index_map_set_helicity_flip (self, yorn) + module subroutine qn_index_map_set_helicity_flip (self, yorn) class(qn_index_map_t), intent(inout) :: self logical, intent(in) :: yorn integer :: i, i_flv, i_hel, i_hel_new type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel_flip integer, dimension(:, :, :), allocatable :: index if (.not. allocated (self%qn_hel)) then call msg_bug ("[qn_index_map_set_helicity_flip] & &cannot flip not-given helicity.") end if allocate (index (self%n_flv, self%n_hel, 0:self%n_sub), & source=self%index) self%flip_hel = yorn if (self%flip_hel) then do i_flv = 1, self%n_flv qn_hel_flip = self%qn_hel do i_hel = 1, self%n_hel do i = 1, size (self%qn_flv, dim=1) if (is_anti_particle (self%qn_flv(i, i_flv))) then call qn_hel_flip(i, i_hel)%flip_helicity () end if end do end do do i_hel = 1, self%n_hel i_hel_new = find_hel_index (qn_hel_flip, self%qn_hel(:, i_hel)) self%index(i_flv, i_hel_new, :) = index(i_flv, i_hel, :) end do end do end if contains logical function is_anti_particle (qn) result (yorn) type(quantum_numbers_t), intent(in) :: qn type(flavor_t) :: flv flv = qn%get_flavor () yorn = flv%get_pdg () < 0 end function is_anti_particle integer function find_hel_index (qn_sort, qn) result (i_hel) type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_sort type(quantum_numbers_t), dimension(:), intent(in) :: qn integer :: j do j = 1, size(qn_sort, dim=2) if (.not. all (qn .hmatch. qn_sort(:, j))) cycle i_hel = j exit end do end function find_hel_index end subroutine qn_index_map_set_helicity_flip @ %def qn_index_map_set_helicity_flip @ Map from the previously given quantum number and subtraction index (latter ranging from 0 to [[n_sub]]) to the (interaction) matrix element. <>= procedure :: get_index => qn_index_map_get_index +<>= + module function qn_index_map_get_index (self, i_flv, i_hel, i_sub) result (index) + class(qn_index_map_t), intent(in) :: self + integer :: index + integer, intent(in) :: i_flv + integer, intent(in), optional :: i_hel + integer, intent(in), optional :: i_sub + end function qn_index_map_get_index <>= - integer function qn_index_map_get_index (self, i_flv, i_hel, i_sub) result (index) + module function qn_index_map_get_index (self, i_flv, i_hel, i_sub) result (index) class(qn_index_map_t), intent(in) :: self + integer :: index integer, intent(in) :: i_flv integer, intent(in), optional :: i_hel integer, intent(in), optional :: i_sub integer :: i_sub_opt, i_hel_opt i_sub_opt = 0; if (present (i_sub)) & i_sub_opt = i_sub i_hel_opt = 1; if (present (i_hel)) & i_hel_opt = i_hel index = 0 if (.not. allocated (self%index)) then call msg_bug ("[qn_index_map_get_index] The index map is not allocated.") end if index = self%index(i_flv, i_hel_opt, i_sub_opt) if (index <= 0) then call self%write () call msg_bug ("[qn_index_map_get_index] The index for the given quantum numbers could not be retrieved.") end if end function qn_index_map_get_index @ %def qn_index_map_get_i_flv @ Get [[n_flv]]. <>= procedure :: get_n_flv => qn_index_map_get_n_flv +<>= + module function qn_index_map_get_n_flv (self) result (n_flv) + class(qn_index_map_t), intent(in) :: self + integer :: n_flv + end function qn_index_map_get_n_flv <>= - integer function qn_index_map_get_n_flv (self) result (n_flv) + module function qn_index_map_get_n_flv (self) result (n_flv) class(qn_index_map_t), intent(in) :: self + integer :: n_flv n_flv = self%n_flv end function qn_index_map_get_n_flv @ %def qn_index_map_get_n_flv @ Get [[n_hel]]. <>= procedure :: get_n_hel => qn_index_map_get_n_hel +<>= + module function qn_index_map_get_n_hel (self) result (n_hel) + class(qn_index_map_t), intent(in) :: self + integer :: n_hel + end function qn_index_map_get_n_hel <>= - integer function qn_index_map_get_n_hel (self) result (n_hel) + module function qn_index_map_get_n_hel (self) result (n_hel) class(qn_index_map_t), intent(in) :: self + integer :: n_hel n_hel = self%n_hel end function qn_index_map_get_n_hel @ %def qn_index_map_get_n_flv @ Get [[n_sub]]. <>= procedure :: get_n_sub => qn_index_map_get_n_sub +<>= + module function qn_index_map_get_n_sub (self) result (n_sub) + class(qn_index_map_t), intent(in) :: self + integer :: n_sub + end function qn_index_map_get_n_sub <>= - integer function qn_index_map_get_n_sub (self) result (n_sub) + module function qn_index_map_get_n_sub (self) result (n_sub) class(qn_index_map_t), intent(in) :: self + integer :: n_sub n_sub = self%n_sub end function qn_index_map_get_n_sub @ %def qn_index_map_get_n_sub @ Gets the index for the matrix element corresponding to a set of quantum numbers. So far, it ignores helicity (and color) indices. <>= procedure :: get_index_by_qn => qn_index_map_get_index_by_qn +<>= + module function qn_index_map_get_index_by_qn (self, qn, i_sub) result (index) + class(qn_index_map_t), intent(in) :: self + integer :: index + type(quantum_numbers_t), dimension(:), intent(in) :: qn + integer, intent(in), optional :: i_sub + end function qn_index_map_get_index_by_qn <>= - integer function qn_index_map_get_index_by_qn (self, qn, i_sub) result (index) + module function qn_index_map_get_index_by_qn (self, qn, i_sub) result (index) class(qn_index_map_t), intent(in) :: self + integer :: index type(quantum_numbers_t), dimension(:), intent(in) :: qn integer, intent(in), optional :: i_sub integer :: i_qn if (size (qn) /= size (self%qn_flv, dim = 1)) & call msg_bug ("[qn_index_map_get_index_by_qn] number of particles does not match.") do i_qn = 1, self%n_flv if (all (qn .fmatch. self%qn_flv(:, i_qn))) then index = self%get_index (i_qn, i_sub = i_sub) return end if end do call self%write () call msg_bug ("[qn_index_map_get_index_by_qn] The index for the given quantum & & numbers could not be retrieved.") end function qn_index_map_get_index_by_qn @ %def qn_index_map_get_index_by_qn @ <>= procedure :: get_sf_index_born => qn_index_map_get_sf_index_born +<>= + module function qn_index_map_get_sf_index_born (self, i_born, i_sub) result (index) + class(qn_index_map_t), intent(in) :: self + integer, intent(in) :: i_born, i_sub + integer :: index + end function qn_index_map_get_sf_index_born <>= - integer function qn_index_map_get_sf_index_born (self, i_born, i_sub) result (index) + module function qn_index_map_get_sf_index_born (self, i_born, i_sub) result (index) class(qn_index_map_t), intent(in) :: self integer, intent(in) :: i_born, i_sub + integer :: index index = self%sf_index_born(i_born, i_sub) end function qn_index_map_get_sf_index_born @ %def qn_index_map_get_sf_index_born @ <>= procedure :: get_sf_index_real => qn_index_map_get_sf_index_real +<>= + module function qn_index_map_get_sf_index_real (self, i_real, i_sub) result (index) + class(qn_index_map_t), intent(in) :: self + integer, intent(in) :: i_real, i_sub + integer :: index + end function qn_index_map_get_sf_index_real <>= - integer function qn_index_map_get_sf_index_real (self, i_real, i_sub) result (index) + module function qn_index_map_get_sf_index_real (self, i_real, i_sub) result (index) class(qn_index_map_t), intent(in) :: self integer, intent(in) :: i_real, i_sub + integer :: index index = self%sf_index_real(i_real, i_sub) end function qn_index_map_get_sf_index_real @ %def qn_index_map_get_sf_index_real @ \subsection{External interaction links} Each particle in an interaction can have a link to a corresponding particle in another interaction. This allows to fetch the momenta of incoming or virtual particles from the interaction where they are defined. The link object consists of a pointer to the interaction and an index. <>= type :: external_link_t private type(interaction_t), pointer :: int => null () integer :: i end type external_link_t @ %def external_link_t @ Set an external link. +<>= + module subroutine external_link_set (link, int, i) + type(external_link_t), intent(out) :: link + type(interaction_t), target, intent(in) :: int + integer, intent(in) :: i + end subroutine external_link_set <>= - subroutine external_link_set (link, int, i) + module subroutine external_link_set (link, int, i) type(external_link_t), intent(out) :: link type(interaction_t), target, intent(in) :: int integer, intent(in) :: i if (i /= 0) then link%int => int link%i = i end if end subroutine external_link_set @ %def external_link_set @ Reassign an external link to a new interaction (which should be an image of the original target). +<>= + module subroutine external_link_reassign (link, int_src, int_target) + type(external_link_t), intent(inout) :: link + type(interaction_t), intent(in) :: int_src + type(interaction_t), intent(in), target :: int_target + end subroutine external_link_reassign <>= - subroutine external_link_reassign (link, int_src, int_target) + module subroutine external_link_reassign (link, int_src, int_target) type(external_link_t), intent(inout) :: link type(interaction_t), intent(in) :: int_src type(interaction_t), intent(in), target :: int_target if (associated (link%int)) then if (link%int%tag == int_src%tag) link%int => int_target end if end subroutine external_link_reassign @ %def external_link_reassign @ Return true if the link is set +<>= + module function external_link_is_set (link) result (flag) + logical :: flag + type(external_link_t), intent(in) :: link + end function external_link_is_set <>= - function external_link_is_set (link) result (flag) + module function external_link_is_set (link) result (flag) logical :: flag type(external_link_t), intent(in) :: link flag = associated (link%int) end function external_link_is_set @ %def external_link_is_set @ Return the interaction pointer. <>= public :: external_link_get_ptr +<>= + module function external_link_get_ptr (link) result (int) + type(interaction_t), pointer :: int + type(external_link_t), intent(in) :: link + end function external_link_get_ptr <>= - function external_link_get_ptr (link) result (int) + module function external_link_get_ptr (link) result (int) type(interaction_t), pointer :: int type(external_link_t), intent(in) :: link int => link%int end function external_link_get_ptr @ %def external_link_get_ptr @ Return the index within that interaction <>= public :: external_link_get_index +<>= + module function external_link_get_index (link) result (i) + integer :: i + type(external_link_t), intent(in) :: link + end function external_link_get_index <>= - function external_link_get_index (link) result (i) + module function external_link_get_index (link) result (i) integer :: i type(external_link_t), intent(in) :: link i = link%i end function external_link_get_index @ %def external_link_get_index @ Return a pointer to the momentum of the corresponding particle. If there is no association, return a null pointer. +<>= + module function external_link_get_momentum_ptr (link) result (p) + type(vector4_t), pointer :: p + type(external_link_t), intent(in) :: link + end function external_link_get_momentum_ptr <>= - function external_link_get_momentum_ptr (link) result (p) + module function external_link_get_momentum_ptr (link) result (p) type(vector4_t), pointer :: p type(external_link_t), intent(in) :: link if (associated (link%int)) then p => link%int%p(link%i) else p => null () end if end function external_link_get_momentum_ptr @ %def external_link_get_momentum_ptr @ \subsection{Internal relations} In addition to the external links, particles within the interaction have parent-child relations. Here, more than one link is possible, and we set up an array. <>= type :: internal_link_list_t private integer :: length = 0 integer, dimension(:), allocatable :: link contains <> end type internal_link_list_t @ %def internal_link_t internal_link_list_t @ Output, non-advancing. <>= procedure :: write => internal_link_list_write +<>= + module subroutine internal_link_list_write (object, unit) + class(internal_link_list_t), intent(in) :: object + integer, intent(in), optional :: unit + end subroutine internal_link_list_write <>= - subroutine internal_link_list_write (object, unit) + module subroutine internal_link_list_write (object, unit) class(internal_link_list_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) do i = 1, object%length write (u, "(1x,I0)", advance="no") object%link(i) end do end subroutine internal_link_list_write @ %def internal_link_list_write @ Append an item. Start with an array size of 2 and double the size if necessary. Make sure that the indices are stored in ascending order. To this end, shift the existing entries right, starting from the end, as long as they are larger than the new entry. <>= procedure :: append => internal_link_list_append +<>= + module subroutine internal_link_list_append (link_list, link) + class(internal_link_list_t), intent(inout) :: link_list + integer, intent(in) :: link + end subroutine internal_link_list_append <>= - subroutine internal_link_list_append (link_list, link) + module subroutine internal_link_list_append (link_list, link) class(internal_link_list_t), intent(inout) :: link_list integer, intent(in) :: link integer :: l, j integer, dimension(:), allocatable :: tmp l = link_list%length if (allocated (link_list%link)) then if (l == size (link_list%link)) then allocate (tmp (2 * l)) tmp(:l) = link_list%link call move_alloc (from = tmp, to = link_list%link) end if else allocate (link_list%link (2)) end if link_list%link(l+1) = link SHIFT_LINK_IN_PLACE: do j = l, 1, -1 if (link >= link_list%link(j)) then exit SHIFT_LINK_IN_PLACE else link_list%link(j+1) = link_list%link(j) link_list%link(j) = link end if end do SHIFT_LINK_IN_PLACE link_list%length = l + 1 end subroutine internal_link_list_append @ %def internal_link_list_append @ Return true if the link list is nonempty: <>= procedure :: has_entries => internal_link_list_has_entries +<>= + module function internal_link_list_has_entries (link_list) result (flag) + class(internal_link_list_t), intent(in) :: link_list + logical :: flag + end function internal_link_list_has_entries <>= - function internal_link_list_has_entries (link_list) result (flag) + module function internal_link_list_has_entries (link_list) result (flag) class(internal_link_list_t), intent(in) :: link_list logical :: flag flag = link_list%length > 0 end function internal_link_list_has_entries @ %def internal_link_list_has_entries @ Return the list length <>= procedure :: get_length => internal_link_list_get_length +<>= + module function internal_link_list_get_length (link_list) result (length) + class(internal_link_list_t), intent(in) :: link_list + integer :: length + end function internal_link_list_get_length <>= - function internal_link_list_get_length (link_list) result (length) + module function internal_link_list_get_length (link_list) result (length) class(internal_link_list_t), intent(in) :: link_list integer :: length length = link_list%length end function internal_link_list_get_length @ %def internal_link_list_get_length @ Return an entry. <>= procedure :: get_link => internal_link_list_get_link +<>= + module function internal_link_list_get_link (link_list, i) result (link) + class(internal_link_list_t), intent(in) :: link_list + integer, intent(in) :: i + integer :: link + end function internal_link_list_get_link <>= - function internal_link_list_get_link (link_list, i) result (link) + module function internal_link_list_get_link (link_list, i) result (link) class(internal_link_list_t), intent(in) :: link_list integer, intent(in) :: i integer :: link if (i <= link_list%length) then link = link_list%link(i) else call msg_bug ("Internal link list: out of bounds") end if end function internal_link_list_get_link @ %def internal_link_list_get_link @ \subsection{The interaction type} An interaction is an entangled system of particles. Thus, the interaction object consists of two parts: the subevent, and the quantum state which technically is a trie. The subnode levels beyond the trie root node are in correspondence to the subevent, so both should be traversed in parallel. The subevent is implemented as an allocatable array of four-momenta. The first [[n_in]] particles are incoming, [[n_vir]] particles in-between can be kept for bookkeeping, and the last [[n_out]] particles are outgoing. Distinct interactions are linked by their particles: for each particle, we have the possibility of links to corresponding particles in other interactions. Furthermore, for bookkeeping purposes we have a self-link array [[relations]] where the parent-child relations are kept, and a flag array [[resonant]] which is set for an intermediate resonance. Each momentum is associated with masks for flavor, color, and helicity. If a mask entry is set, the associated quantum number is to be ignored for that particle. If any mask has changed, the flag [[update]] is set. We can have particle pairs locked together. If this is the case, the corresponding mask entries are bound to be equal. This is useful for particles that go through the interaction. The interaction tag serves bookkeeping purposes. In particular, it identifies links in printout. <>= public :: interaction_t <>= type :: interaction_t private integer :: tag = 0 type(state_matrix_t) :: state_matrix integer :: n_in = 0 integer :: n_vir = 0 integer :: n_out = 0 integer :: n_tot = 0 logical, dimension(:), allocatable :: p_is_known type(vector4_t), dimension(:), allocatable :: p type(external_link_t), dimension(:), allocatable :: source type(internal_link_list_t), dimension(:), allocatable :: parents type(internal_link_list_t), dimension(:), allocatable :: children logical, dimension(:), allocatable :: resonant type(quantum_numbers_mask_t), dimension(:), allocatable :: mask integer, dimension(:), allocatable :: hel_lock logical :: update_state_matrix = .false. logical :: update_values = .false. type(qn_index_map_t) :: qn_index contains <> end type interaction_t @ %def interaction_particle_p interaction_t @ Initialize the particle array with a fixed size. The first [[n_in]] particles are incoming, the rest outgoing. Masks are optional. There is also an optional tag. The interaction still needs fixing the values, but that is to be done after all branches have been added. Interaction tags are assigned consecutively, using a [[save]]d variable local to this procedure. If desired, we can provide a seed for the interaction tags. Such a seed should be positive. The default seed is one. [[tag=0]] indicates an empty interaction. If [[set_relations]] is set and true, we establish parent-child relations for all incoming and outgoing particles. Virtual particles are skipped; this option is normally used only for interations without virtual particles. <>= procedure :: basic_init => interaction_init +<>= + module subroutine interaction_init & + (int, n_in, n_vir, n_out, & + tag, resonant, mask, hel_lock, set_relations, store_values) + class(interaction_t), intent(out) :: int + integer, intent(in) :: n_in, n_vir, n_out + integer, intent(in), optional :: tag + logical, dimension(:), intent(in), optional :: resonant + type(quantum_numbers_mask_t), dimension(:), intent(in), optional :: mask + integer, dimension(:), intent(in), optional :: hel_lock + logical, intent(in), optional :: set_relations, store_values + end subroutine interaction_init <>= - subroutine interaction_init & + module subroutine interaction_init & (int, n_in, n_vir, n_out, & tag, resonant, mask, hel_lock, set_relations, store_values) class(interaction_t), intent(out) :: int integer, intent(in) :: n_in, n_vir, n_out integer, intent(in), optional :: tag logical, dimension(:), intent(in), optional :: resonant type(quantum_numbers_mask_t), dimension(:), intent(in), optional :: mask integer, dimension(:), intent(in), optional :: hel_lock logical, intent(in), optional :: set_relations, store_values logical :: set_rel integer :: i, j set_rel = .false.; if (present (set_relations)) set_rel = set_relations call interaction_set_tag (int, tag) call int%state_matrix%init (store_values) int%n_in = n_in int%n_vir = n_vir int%n_out = n_out int%n_tot = n_in + n_vir + n_out allocate (int%p_is_known (int%n_tot)) int%p_is_known = .false. allocate (int%p (int%n_tot)) allocate (int%source (int%n_tot)) allocate (int%parents (int%n_tot)) allocate (int%children (int%n_tot)) allocate (int%resonant (int%n_tot)) if (present (resonant)) then int%resonant = resonant else int%resonant = .false. end if allocate (int%mask (int%n_tot)) allocate (int%hel_lock (int%n_tot)) if (present (mask)) then int%mask = mask end if if (present (hel_lock)) then int%hel_lock = hel_lock else int%hel_lock = 0 end if int%update_state_matrix = .false. int%update_values = .true. if (set_rel) then do i = 1, n_in do j = 1, n_out call int%relate (i, n_in + j) end do end do end if end subroutine interaction_init @ %def interaction_init @ <>= generic :: init_qn_index => init_qn_index_trivial, & init_qn_index_involved, & init_qn_index_sf procedure :: init_qn_index_trivial => interaction_init_qn_index_trivial procedure :: init_qn_index_involved => interaction_init_qn_index_involved procedure :: init_qn_index_sf => interaction_init_qn_index_sf +<>= + module subroutine interaction_init_qn_index_trivial (int) + class(interaction_t), intent(inout) :: int + end subroutine interaction_init_qn_index_trivial + module subroutine interaction_init_qn_index_involved (int, qn_flv, n_sub, qn_hel) + class(interaction_t), intent(inout) :: int + type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_flv + integer, intent(in) :: n_sub + type(quantum_numbers_t), dimension(:, :), intent(in), optional :: qn_hel + end subroutine interaction_init_qn_index_involved + module subroutine interaction_init_qn_index_sf (int, qn_flv, n_flv_born, n_flv_real) + class(interaction_t), intent(inout) :: int + integer, intent(in) :: n_flv_born, n_flv_real + type(quantum_numbers_t), dimension(:,:), intent(in) :: qn_flv + end subroutine interaction_init_qn_index_sf <>= - subroutine interaction_init_qn_index_trivial (int) + module subroutine interaction_init_qn_index_trivial (int) class(interaction_t), intent(inout) :: int call int%qn_index%init (int) end subroutine interaction_init_qn_index_trivial - subroutine interaction_init_qn_index_involved (int, qn_flv, n_sub, qn_hel) + module subroutine interaction_init_qn_index_involved (int, qn_flv, n_sub, qn_hel) class(interaction_t), intent(inout) :: int type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_flv integer, intent(in) :: n_sub type(quantum_numbers_t), dimension(:, :), intent(in), optional :: qn_hel call int%qn_index%init (int, qn_flv, n_sub, qn_hel) end subroutine interaction_init_qn_index_involved - subroutine interaction_init_qn_index_sf (int, qn_flv, n_flv_born, n_flv_real) + module subroutine interaction_init_qn_index_sf (int, qn_flv, n_flv_born, n_flv_real) class(interaction_t), intent(inout) :: int integer, intent(in) :: n_flv_born, n_flv_real type(quantum_numbers_t), dimension(:,:), intent(in) :: qn_flv call int%qn_index%init (int, qn_flv, n_flv_born, n_flv_real) end subroutine interaction_init_qn_index_sf @ %def interaction_init_qn_index_trivial @ %def interaction_init_qn_index @ %def interaction_init_qn_index_sf @ <>= procedure :: set_qn_index_helicity_flip => interaction_set_qn_index_helicity_flip +<>= + module subroutine interaction_set_qn_index_helicity_flip (int, yorn) + class(interaction_t), intent(inout) :: int + logical, intent(in) :: yorn + end subroutine interaction_set_qn_index_helicity_flip <>= - subroutine interaction_set_qn_index_helicity_flip (int, yorn) + module subroutine interaction_set_qn_index_helicity_flip (int, yorn) class(interaction_t), intent(inout) :: int logical, intent(in) :: yorn call int%qn_index%set_helicity_flip (yorn) end subroutine interaction_set_qn_index_helicity_flip @ %def interaction_get_qn_index_n_flv @ <>= procedure :: get_qn_index => interaction_get_qn_index procedure :: get_sf_qn_index_born => interaction_get_sf_qn_index_born procedure :: get_sf_qn_index_real => interaction_get_sf_qn_index_real +<>= + module function interaction_get_qn_index (int, i_flv, i_hel, i_sub) result (index) + class(interaction_t), intent(in) :: int + integer :: index + integer, intent(in) :: i_flv + integer, intent(in), optional :: i_hel + integer, intent(in), optional :: i_sub + end function interaction_get_qn_index + module function interaction_get_sf_qn_index_born (int, i_born, i_sub) result (index) + class(interaction_t), intent(in) :: int + integer :: index + integer, intent(in) :: i_born, i_sub + end function interaction_get_sf_qn_index_born + module function interaction_get_sf_qn_index_real (int, i_real, i_sub) result (index) + class(interaction_t), intent(in) :: int + integer :: index + integer, intent(in) :: i_real, i_sub + end function interaction_get_sf_qn_index_real <>= - integer function interaction_get_qn_index (int, i_flv, i_hel, i_sub) result (index) + module function interaction_get_qn_index (int, i_flv, i_hel, i_sub) result (index) class(interaction_t), intent(in) :: int + integer :: index integer, intent(in) :: i_flv integer, intent(in), optional :: i_hel integer, intent(in), optional :: i_sub index = int%qn_index%get_index (i_flv, i_hel, i_sub) end function interaction_get_qn_index - integer function interaction_get_sf_qn_index_born (int, i_born, i_sub) result (index) + module function interaction_get_sf_qn_index_born (int, i_born, i_sub) result (index) class(interaction_t), intent(in) :: int + integer :: index integer, intent(in) :: i_born, i_sub index = int%qn_index%get_sf_index_born (i_born, i_sub) end function interaction_get_sf_qn_index_born - integer function interaction_get_sf_qn_index_real (int, i_real, i_sub) result (index) + module function interaction_get_sf_qn_index_real (int, i_real, i_sub) result (index) class(interaction_t), intent(in) :: int + integer :: index integer, intent(in) :: i_real, i_sub index = int%qn_index%get_sf_index_real (i_real, i_sub) end function interaction_get_sf_qn_index_real @ %def interaction_get_qn_index @ %def interaction_get_sf_qn_index_born @ %def interaction_get_sf_qn_index_real @ <>= procedure :: get_qn_index_n_flv => interaction_get_qn_index_n_flv procedure :: get_qn_index_n_hel => interaction_get_qn_index_n_hel procedure :: get_qn_index_n_sub => interaction_get_qn_index_n_sub +<>= + module function interaction_get_qn_index_n_flv (int) result (index) + class(interaction_t), intent(in) :: int + integer :: index + end function interaction_get_qn_index_n_flv + module function interaction_get_qn_index_n_hel (int) result (index) + class(interaction_t), intent(in) :: int + integer :: index + end function interaction_get_qn_index_n_hel + module function interaction_get_qn_index_n_sub (int) result (index) + class(interaction_t), intent(in) :: int + integer :: index + end function interaction_get_qn_index_n_sub <>= - integer function interaction_get_qn_index_n_flv (int) result (index) + module function interaction_get_qn_index_n_flv (int) result (index) class(interaction_t), intent(in) :: int + integer :: index index = int%qn_index%get_n_flv () end function interaction_get_qn_index_n_flv - integer function interaction_get_qn_index_n_hel (int) result (index) + module function interaction_get_qn_index_n_hel (int) result (index) class(interaction_t), intent(in) :: int + integer :: index index = int%qn_index%get_n_hel () end function interaction_get_qn_index_n_hel - integer function interaction_get_qn_index_n_sub (int) result (index) + module function interaction_get_qn_index_n_sub (int) result (index) class(interaction_t), intent(in) :: int + integer :: index index = int%qn_index%get_n_sub () end function interaction_get_qn_index_n_sub @ %def interaction_get_qn_index_n_flv @ %def interaction_get_qn_index_n_hel @ %def interaction_get_qn_index_n_sub @ Set or create a unique tag for the interaction. Without interaction, reset the tag counter. +<>= + module subroutine interaction_set_tag (int, tag) + type(interaction_t), intent(inout), optional :: int + integer, intent(in), optional :: tag + end subroutine interaction_set_tag <>= - subroutine interaction_set_tag (int, tag) + module subroutine interaction_set_tag (int, tag) type(interaction_t), intent(inout), optional :: int integer, intent(in), optional :: tag integer, save :: stored_tag = 1 if (present (int)) then if (present (tag)) then int%tag = tag else int%tag = stored_tag stored_tag = stored_tag + 1 end if else if (present (tag)) then stored_tag = tag else stored_tag = 1 end if end subroutine interaction_set_tag @ %def interaction_set_tag @ The public interface for the previous procedure only covers the reset functionality. <>= public :: reset_interaction_counter +<>= + module subroutine reset_interaction_counter (tag) + integer, intent(in), optional :: tag + end subroutine reset_interaction_counter <>= - subroutine reset_interaction_counter (tag) + module subroutine reset_interaction_counter (tag) integer, intent(in), optional :: tag call interaction_set_tag (tag=tag) end subroutine reset_interaction_counter @ %def reset_interaction_counter @ Finalizer: The state-matrix object contains pointers. <>= procedure :: final => interaction_final +<>= + module subroutine interaction_final (object) + class(interaction_t), intent(inout) :: object + end subroutine interaction_final <>= - subroutine interaction_final (object) + module subroutine interaction_final (object) class(interaction_t), intent(inout) :: object call object%state_matrix%final () end subroutine interaction_final @ %def interaction_final @ Output. The [[verbose]] option refers to the state matrix output. <>= procedure :: basic_write => interaction_write +<>= + module subroutine interaction_write & + (int, unit, verbose, show_momentum_sum, show_mass, show_state, & + col_verbose, testflag) + class(interaction_t), intent(in) :: int + integer, intent(in), optional :: unit + logical, intent(in), optional :: verbose, show_momentum_sum, show_mass + logical, intent(in), optional :: show_state, col_verbose, testflag + end subroutine interaction_write <>= - subroutine interaction_write & + module subroutine interaction_write & (int, unit, verbose, show_momentum_sum, show_mass, show_state, & col_verbose, testflag) class(interaction_t), intent(in) :: int integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, show_momentum_sum, show_mass logical, intent(in), optional :: show_state, col_verbose, testflag integer :: u integer :: i, index_link type(interaction_t), pointer :: int_link logical :: show_st u = given_output_unit (unit); if (u < 0) return show_st = .true.; if (present (show_state)) show_st = show_state if (int%tag /= 0) then write (u, "(1x,A,I0)") "Interaction: ", int%tag do i = 1, int%n_tot if (i == 1 .and. int%n_in > 0) then write (u, "(1x,A)") "Incoming:" else if (i == int%n_in + 1 .and. int%n_vir > 0) then write (u, "(1x,A)") "Virtual:" else if (i == int%n_in + int%n_vir + 1 .and. int%n_out > 0) then write (u, "(1x,A)") "Outgoing:" end if write (u, "(1x,A,1x,I0)", advance="no") "Particle", i if (allocated (int%resonant)) then if (int%resonant(i)) then write (u, "(A)") "[r]" else write (u, *) end if else write (u, *) end if if (allocated (int%p)) then if (int%p_is_known(i)) then call vector4_write (int%p(i), u, show_mass, testflag) else write (u, "(A)") " [momentum undefined]" end if else write (u, "(A)") " [momentum not allocated]" end if if (allocated (int%mask)) then write (u, "(1x,A)", advance="no") "mask [fch] = " call int%mask(i)%write (u) write (u, *) end if if (int%parents(i)%has_entries () & .or. int%children(i)%has_entries ()) then write (u, "(1x,A)", advance="no") "internal links:" call int%parents(i)%write (u) if (int%parents(i)%has_entries ()) & write (u, "(1x,A)", advance="no") "=>" write (u, "(1x,A)", advance="no") "X" if (int%children(i)%has_entries ()) & write (u, "(1x,A)", advance="no") "=>" call int%children(i)%write (u) write (u, *) end if if (allocated (int%hel_lock)) then if (int%hel_lock(i) /= 0) then write (u, "(1x,A,1x,I0)") "helicity lock:", int%hel_lock(i) end if end if if (external_link_is_set (int%source(i))) then write (u, "(1x,A)", advance="no") "source:" int_link => external_link_get_ptr (int%source(i)) index_link = external_link_get_index (int%source(i)) write (u, "(1x,'(',I0,')',I0)", advance="no") & int_link%tag, index_link write (u, *) end if end do if (present (show_momentum_sum)) then if (allocated (int%p) .and. show_momentum_sum) then write (u, "(1x,A)") "Incoming particles (sum):" call vector4_write & (sum (int%p(1 : int%n_in)), u, show_mass = show_mass) write (u, "(1x,A)") "Outgoing particles (sum):" call vector4_write & (sum (int%p(int%n_in + int%n_vir + 1 : )), & u, show_mass = show_mass) write (u, *) end if end if if (show_st) then call int%write_state_matrix (write_value_list = verbose, & verbose = verbose, unit = unit, col_verbose = col_verbose, & testflag = testflag) end if else write (u, "(1x,A)") "Interaction: [empty]" end if end subroutine interaction_write @ %def interaction_write @ <>= procedure :: write_state_matrix => interaction_write_state_matrix +<>= + module subroutine interaction_write_state_matrix (int, unit, write_value_list, & + verbose, col_verbose, testflag) + class(interaction_t), intent(in) :: int + logical, intent(in), optional :: write_value_list, verbose, col_verbose + logical, intent(in), optional :: testflag + integer, intent(in), optional :: unit + end subroutine interaction_write_state_matrix <>= - subroutine interaction_write_state_matrix (int, unit, write_value_list, & + module subroutine interaction_write_state_matrix (int, unit, write_value_list, & verbose, col_verbose, testflag) class(interaction_t), intent(in) :: int logical, intent(in), optional :: write_value_list, verbose, col_verbose logical, intent(in), optional :: testflag integer, intent(in), optional :: unit call int%state_matrix%write (write_value_list = verbose, & verbose = verbose, unit = unit, col_verbose = col_verbose, & testflag = testflag) end subroutine interaction_write_state_matrix @ %def interaction_write_state_matrix @ Reduce the [[state_matrix]] over the quantum mask. During the reduce procedure the iterator does not conserve the order of the matrix element respective their quantum numbers. Setting the [[keep_order]] results in a reorder state matrix with reintroduced matrix element indices. <>= procedure :: reduce_state_matrix => interaction_reduce_state_matrix +<>= + module subroutine interaction_reduce_state_matrix (int, qn_mask, keep_order) + class(interaction_t), intent(inout) :: int + type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask + logical, optional, intent(in) :: keep_order + end subroutine interaction_reduce_state_matrix <>= - subroutine interaction_reduce_state_matrix (int, qn_mask, keep_order) + module subroutine interaction_reduce_state_matrix (int, qn_mask, keep_order) class(interaction_t), intent(inout) :: int type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask logical, optional, intent(in) :: keep_order type(state_matrix_t) :: state logical :: opt_keep_order opt_keep_order = .false. if (present (keep_order)) opt_keep_order = keep_order call int%state_matrix%reduce (qn_mask, state, keep_me_index = keep_order) int%state_matrix = state if (opt_keep_order) then call int%state_matrix%reorder_me (state) int%state_matrix = state end if end subroutine interaction_reduce_state_matrix @ %def interaction_reduce_state_matrix @ Assignment: We implement this as a deep copy. This applies, in particular, to the state-matrix and internal-link components. Furthermore, the new interaction acquires a new tag. <>= public :: assignment(=) <>= interface assignment(=) module procedure interaction_assign end interface +<>= + module subroutine interaction_assign (int_out, int_in) + type(interaction_t), intent(out) :: int_out + type(interaction_t), intent(in), target :: int_in + end subroutine interaction_assign <>= - subroutine interaction_assign (int_out, int_in) + module subroutine interaction_assign (int_out, int_in) type(interaction_t), intent(out) :: int_out type(interaction_t), intent(in), target :: int_in call interaction_set_tag (int_out) int_out%state_matrix = int_in%state_matrix int_out%n_in = int_in%n_in int_out%n_out = int_in%n_out int_out%n_vir = int_in%n_vir int_out%n_tot = int_in%n_tot if (allocated (int_in%p_is_known)) then allocate (int_out%p_is_known (size (int_in%p_is_known))) int_out%p_is_known = int_in%p_is_known end if if (allocated (int_in%p)) then allocate (int_out%p (size (int_in%p))) int_out%p = int_in%p end if if (allocated (int_in%source)) then allocate (int_out%source (size (int_in%source))) int_out%source = int_in%source end if if (allocated (int_in%parents)) then allocate (int_out%parents (size (int_in%parents))) int_out%parents = int_in%parents end if if (allocated (int_in%children)) then allocate (int_out%children (size (int_in%children))) int_out%children = int_in%children end if if (allocated (int_in%resonant)) then allocate (int_out%resonant (size (int_in%resonant))) int_out%resonant = int_in%resonant end if if (allocated (int_in%mask)) then allocate (int_out%mask (size (int_in%mask))) int_out%mask = int_in%mask end if if (allocated (int_in%hel_lock)) then allocate (int_out%hel_lock (size (int_in%hel_lock))) int_out%hel_lock = int_in%hel_lock end if int_out%update_state_matrix = int_in%update_state_matrix int_out%update_values = int_in%update_values end subroutine interaction_assign @ %def interaction_assign @ \subsection{Methods inherited from the state matrix member} Until F2003 is standard, we cannot implement inheritance directly. Therefore, we need wrappers for ``inherited'' methods. Make a new branch in the state matrix if it does not yet exist. This is not just a wrapper but it introduces the interaction mask: where a quantum number is masked, it is not transferred but set undefined. After this, the value array has to be updated. <>= procedure :: add_state => interaction_add_state +<>= + module subroutine interaction_add_state & + (int, qn, index, value, sum_values, counter_index, ignore_sub_for_qn, me_index) + class(interaction_t), intent(inout) :: int + type(quantum_numbers_t), dimension(:), intent(in) :: qn + integer, intent(in), optional :: index + complex(default), intent(in), optional :: value + logical, intent(in), optional :: sum_values + integer, intent(in), optional :: counter_index + logical, intent(in), optional :: ignore_sub_for_qn + integer, intent(out), optional :: me_index + end subroutine interaction_add_state <>= - subroutine interaction_add_state & + module subroutine interaction_add_state & (int, qn, index, value, sum_values, counter_index, ignore_sub_for_qn, me_index) class(interaction_t), intent(inout) :: int type(quantum_numbers_t), dimension(:), intent(in) :: qn integer, intent(in), optional :: index complex(default), intent(in), optional :: value logical, intent(in), optional :: sum_values integer, intent(in), optional :: counter_index logical, intent(in), optional :: ignore_sub_for_qn integer, intent(out), optional :: me_index type(quantum_numbers_t), dimension(size(qn)) :: qn_tmp qn_tmp = qn call qn_tmp%undefine (int%mask) call int%state_matrix%add_state (qn_tmp, index, value, sum_values, & counter_index, ignore_sub_for_qn, me_index) int%update_values = .true. end subroutine interaction_add_state @ %def interaction_add_state @ <>= procedure :: set_duplicate_flv_zero => interaction_set_duplicate_flv_zero +<>= + module subroutine interaction_set_duplicate_flv_zero (int) + class(interaction_t), intent(inout) :: int + end subroutine interaction_set_duplicate_flv_zero <>= - subroutine interaction_set_duplicate_flv_zero (int) + module subroutine interaction_set_duplicate_flv_zero (int) class(interaction_t), intent(inout) :: int call int%state_matrix%set_duplicate_flv_zero () end subroutine interaction_set_duplicate_flv_zero @ %def interaction_set_duplicate_flv_zero @ Freeze the quantum state: First collapse the quantum state, i.e., remove quantum numbers if any mask has changed, then fix the array of value pointers. <>= procedure :: freeze => interaction_freeze +<>= + module subroutine interaction_freeze (int) + class(interaction_t), intent(inout) :: int + end subroutine interaction_freeze <>= - subroutine interaction_freeze (int) + module subroutine interaction_freeze (int) class(interaction_t), intent(inout) :: int if (int%update_state_matrix) then call int%state_matrix%collapse (int%mask) int%update_state_matrix = .false. int%update_values = .true. end if if (int%update_values) then call int%state_matrix%freeze () int%update_values = .false. end if end subroutine interaction_freeze @ %def interaction_freeze @ Return true if the state matrix is empty. <>= procedure :: is_empty => interaction_is_empty +<>= + pure module function interaction_is_empty (int) result (flag) + logical :: flag + class(interaction_t), intent(in) :: int + end function interaction_is_empty <>= - pure function interaction_is_empty (int) result (flag) + pure module function interaction_is_empty (int) result (flag) logical :: flag class(interaction_t), intent(in) :: int flag = int%state_matrix%is_empty () end function interaction_is_empty @ %def interaction_is_empty @ Get the number of values stored in the state matrix: <>= procedure :: get_n_matrix_elements => & interaction_get_n_matrix_elements +<>= + pure module function interaction_get_n_matrix_elements (int) result (n) + integer :: n + class(interaction_t), intent(in) :: int + end function interaction_get_n_matrix_elements <>= - pure function interaction_get_n_matrix_elements (int) result (n) + pure module function interaction_get_n_matrix_elements (int) result (n) integer :: n class(interaction_t), intent(in) :: int n = int%state_matrix%get_n_matrix_elements () end function interaction_get_n_matrix_elements @ %def interaction_get_n_matrix_elements @ <>= procedure :: get_state_depth => interaction_get_state_depth +<>= + module function interaction_get_state_depth (int) result (n) + integer :: n + class(interaction_t), intent(in) :: int + end function interaction_get_state_depth <>= - function interaction_get_state_depth (int) result (n) + module function interaction_get_state_depth (int) result (n) integer :: n class(interaction_t), intent(in) :: int n = int%state_matrix%get_depth () end function interaction_get_state_depth @ %def interaction_get_state_depth @ <>= procedure :: get_n_in_helicities => interaction_get_n_in_helicities +<>= + module function interaction_get_n_in_helicities (int) result (n_hel) + integer :: n_hel + class(interaction_t), intent(in) :: int + end function interaction_get_n_in_helicities <>= - function interaction_get_n_in_helicities (int) result (n_hel) + module function interaction_get_n_in_helicities (int) result (n_hel) integer :: n_hel class(interaction_t), intent(in) :: int type(interaction_t) :: int_copy type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask type(quantum_numbers_t), dimension(:,:), allocatable :: qn integer :: i allocate (qn_mask (int%n_tot)) do i = 1, int%n_tot if (i <= int%n_in) then call qn_mask(i)%init (.true., .true., .false.) else call qn_mask(i)%init (.true., .true., .true.) end if end do int_copy = int call int_copy%set_mask (qn_mask) call int_copy%freeze () allocate (qn (int_copy%state_matrix%get_n_matrix_elements (), & int_copy%state_matrix%get_depth ())) qn = int_copy%get_quantum_numbers () n_hel = 0 do i = 1, size (qn, dim=1) if (all (qn(:, i)%get_subtraction_index () == 0)) n_hel = n_hel + 1 end do call int_copy%final () deallocate (qn_mask) deallocate (qn) end function interaction_get_n_in_helicities @ %def interaction_get_n_in_helicities @ Get the size of the [[me]]-array of the associated state matrix for debugging purposes <>= procedure :: get_me_size => interaction_get_me_size +<>= + pure module function interaction_get_me_size (int) result (n) + integer :: n + class(interaction_t), intent(in) :: int + end function interaction_get_me_size <>= - pure function interaction_get_me_size (int) result (n) + pure module function interaction_get_me_size (int) result (n) integer :: n class(interaction_t), intent(in) :: int n = int%state_matrix%get_me_size () end function interaction_get_me_size @ %def interaction_get_me_size @ Get the norm of the state matrix (if the norm has been taken out, otherwise this would be unity). <>= procedure :: get_norm => interaction_get_norm +<>= + pure module function interaction_get_norm (int) result (norm) + real(default) :: norm + class(interaction_t), intent(in) :: int + end function interaction_get_norm <>= - pure function interaction_get_norm (int) result (norm) + pure module function interaction_get_norm (int) result (norm) real(default) :: norm class(interaction_t), intent(in) :: int norm = int%state_matrix%get_norm () end function interaction_get_norm @ %def interaction_get_norm @ <>= procedure :: get_n_sub => interaction_get_n_sub +<>= + module function interaction_get_n_sub (int) result (n_sub) + integer :: n_sub + class(interaction_t), intent(in) :: int + end function interaction_get_n_sub <>= - function interaction_get_n_sub (int) result (n_sub) + module function interaction_get_n_sub (int) result (n_sub) integer :: n_sub class(interaction_t), intent(in) :: int n_sub = int%state_matrix%get_n_sub () end function interaction_get_n_sub @ %def interaction_get_n_sub @ Get the quantum number array that corresponds to a given index. <>= generic :: get_quantum_numbers => get_quantum_numbers_single, & get_quantum_numbers_all, & get_quantum_numbers_all_qn_mask procedure :: get_quantum_numbers_single => & interaction_get_quantum_numbers_single procedure :: get_quantum_numbers_all => & interaction_get_quantum_numbers_all procedure :: get_quantum_numbers_all_qn_mask => & interaction_get_quantum_numbers_all_qn_mask +<>= + module function interaction_get_quantum_numbers_single (int, i, by_me_index) result (qn) + type(quantum_numbers_t), dimension(:), allocatable :: qn + class(interaction_t), intent(in), target :: int + integer, intent(in) :: i + logical, intent(in), optional :: by_me_index + end function interaction_get_quantum_numbers_single + module function interaction_get_quantum_numbers_all (int) result (qn) + type(quantum_numbers_t), dimension(:,:), allocatable :: qn + class(interaction_t), intent(in), target :: int + end function interaction_get_quantum_numbers_all + module function interaction_get_quantum_numbers_all_qn_mask (int, qn_mask) & + result (qn) + type(quantum_numbers_t), dimension(:,:), allocatable :: qn + class(interaction_t), intent(in) :: int + type(quantum_numbers_mask_t), intent(in) :: qn_mask + end function interaction_get_quantum_numbers_all_qn_mask <>= - function interaction_get_quantum_numbers_single (int, i, by_me_index) result (qn) + module function interaction_get_quantum_numbers_single (int, i, by_me_index) result (qn) type(quantum_numbers_t), dimension(:), allocatable :: qn class(interaction_t), intent(in), target :: int integer, intent(in) :: i logical, intent(in), optional :: by_me_index allocate (qn (int%state_matrix%get_depth ())) qn = int%state_matrix%get_quantum_number (i, by_me_index) end function interaction_get_quantum_numbers_single - function interaction_get_quantum_numbers_all (int) result (qn) + module function interaction_get_quantum_numbers_all (int) result (qn) type(quantum_numbers_t), dimension(:,:), allocatable :: qn class(interaction_t), intent(in), target :: int integer :: i <> <>= allocate (qn (int%state_matrix%get_depth(), & int%state_matrix%get_n_matrix_elements ())) do i = 1, int%state_matrix%get_n_matrix_elements () qn (:, i) = int%state_matrix%get_quantum_number (i) end do <>= end function interaction_get_quantum_numbers_all - function interaction_get_quantum_numbers_all_qn_mask (int, qn_mask) & + module function interaction_get_quantum_numbers_all_qn_mask (int, qn_mask) & result (qn) type(quantum_numbers_t), dimension(:,:), allocatable :: qn class(interaction_t), intent(in) :: int type(quantum_numbers_mask_t), intent(in) :: qn_mask integer :: n_redundant, n_all, n_me integer :: i type(quantum_numbers_t), dimension(:,:), allocatable :: qn_all <> <>= call int%state_matrix%get_quantum_numbers (qn_all) n_redundant = count (qn_all%are_redundant (qn_mask)) n_all = size (qn_all) !!! Number of matrix elements = survivors / n_particles n_me = (n_all - n_redundant) / int%state_matrix%get_depth () allocate (qn (int%state_matrix%get_depth(), n_me)) do i = 1, n_me if (.not. any (qn_all(i, :)%are_redundant (qn_mask))) & qn (:, i) = qn_all (i, :) end do <>= end function interaction_get_quantum_numbers_all_qn_mask @ %def interaction_get_quantum_numbers_single @ %def interaction_get_quantum_numbers_all @ %def interaction_get_quantum_numbers_all_qn_mask @ @ <>= procedure :: get_quantum_numbers_all_sub => interaction_get_quantum_numbers_all_sub +<>= + module subroutine interaction_get_quantum_numbers_all_sub (int, qn) + class(interaction_t), intent(in) :: int + type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn + end subroutine interaction_get_quantum_numbers_all_sub <>= - subroutine interaction_get_quantum_numbers_all_sub (int, qn) + module subroutine interaction_get_quantum_numbers_all_sub (int, qn) class(interaction_t), intent(in) :: int type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn integer :: i <> end subroutine interaction_get_quantum_numbers_all_sub @ %def interaction_get_quantum_numbers_all @ <>= procedure :: get_flavors => interaction_get_flavors +<>= + module subroutine interaction_get_flavors (int, only_elementary, qn_mask, flv) + class(interaction_t), intent(in), target :: int + logical, intent(in) :: only_elementary + type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask + integer, intent(out), dimension(:,:), allocatable :: flv + end subroutine interaction_get_flavors <>= - subroutine interaction_get_flavors (int, only_elementary, qn_mask, flv) + module subroutine interaction_get_flavors (int, only_elementary, qn_mask, flv) class(interaction_t), intent(in), target :: int logical, intent(in) :: only_elementary type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask integer, intent(out), dimension(:,:), allocatable :: flv call int%state_matrix%get_flavors (only_elementary, qn_mask, flv) end subroutine interaction_get_flavors @ %def interaction_get_flavors @ <>= procedure :: get_quantum_numbers_mask => interaction_get_quantum_numbers_mask +<>= + module subroutine interaction_get_quantum_numbers_mask (int, qn_mask, qn) + class(interaction_t), intent(in) :: int + type(quantum_numbers_mask_t), intent(in) :: qn_mask + type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn + end subroutine interaction_get_quantum_numbers_mask <>= - subroutine interaction_get_quantum_numbers_mask (int, qn_mask, qn) + module subroutine interaction_get_quantum_numbers_mask (int, qn_mask, qn) class(interaction_t), intent(in) :: int type(quantum_numbers_mask_t), intent(in) :: qn_mask type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn integer :: n_redundant, n_all, n_me integer :: i type(quantum_numbers_t), dimension(:,:), allocatable :: qn_all <> end subroutine interaction_get_quantum_numbers_mask @ %def interaction_get_quantum_numbers_mask @ Get the matrix element that corresponds to a set of quantum numbers, a given index, or return the whole array. <>= generic :: get_matrix_element => get_matrix_element_single generic :: get_matrix_element => get_matrix_element_array procedure :: get_matrix_element_single => & interaction_get_matrix_element_single procedure :: get_matrix_element_array => & interaction_get_matrix_element_array +<>= + elemental module function interaction_get_matrix_element_single (int, i) result (me) + complex(default) :: me + class(interaction_t), intent(in) :: int + integer, intent(in) :: i + end function interaction_get_matrix_element_single <>= - elemental function interaction_get_matrix_element_single (int, i) result (me) + elemental module function interaction_get_matrix_element_single (int, i) result (me) complex(default) :: me class(interaction_t), intent(in) :: int integer, intent(in) :: i me = int%state_matrix%get_matrix_element (i) end function interaction_get_matrix_element_single @ %def interaction_get_matrix_element_single +<>= + module function interaction_get_matrix_element_array (int) result (me) + complex(default), dimension(:), allocatable :: me + class(interaction_t), intent(in) :: int + end function interaction_get_matrix_element_array <>= - function interaction_get_matrix_element_array (int) result (me) + module function interaction_get_matrix_element_array (int) result (me) complex(default), dimension(:), allocatable :: me class(interaction_t), intent(in) :: int allocate (me (int%get_n_matrix_elements ())) me = int%state_matrix%get_matrix_element () end function interaction_get_matrix_element_array @ %def interaction_get_matrix_element_array @ Set the complex value(s) stored in the quantum state. <>= generic :: set_matrix_element => interaction_set_matrix_element_qn, & interaction_set_matrix_element_all, & interaction_set_matrix_element_array, & interaction_set_matrix_element_single, & interaction_set_matrix_element_clone procedure :: interaction_set_matrix_element_qn procedure :: interaction_set_matrix_element_all procedure :: interaction_set_matrix_element_array procedure :: interaction_set_matrix_element_single procedure :: interaction_set_matrix_element_clone @ %def interaction_set_matrix_element @ Indirect access via the quantum number array: +<>= + module subroutine interaction_set_matrix_element_qn (int, qn, val) + class(interaction_t), intent(inout) :: int + type(quantum_numbers_t), dimension(:), intent(in) :: qn + complex(default), intent(in) :: val + end subroutine interaction_set_matrix_element_qn <>= - subroutine interaction_set_matrix_element_qn (int, qn, val) + module subroutine interaction_set_matrix_element_qn (int, qn, val) class(interaction_t), intent(inout) :: int type(quantum_numbers_t), dimension(:), intent(in) :: qn complex(default), intent(in) :: val call int%state_matrix%set_matrix_element (qn, val) end subroutine interaction_set_matrix_element_qn @ %def interaction_set_matrix_element @ Set all entries of the matrix-element array to a given value. +<>= + module subroutine interaction_set_matrix_element_all (int, value) + class(interaction_t), intent(inout) :: int + complex(default), intent(in) :: value + end subroutine interaction_set_matrix_element_all <>= - subroutine interaction_set_matrix_element_all (int, value) + module subroutine interaction_set_matrix_element_all (int, value) class(interaction_t), intent(inout) :: int complex(default), intent(in) :: value call int%state_matrix%set_matrix_element (value) end subroutine interaction_set_matrix_element_all @ %def interaction_set_matrix_element_all @ Set the matrix-element array directly. +<>= + module subroutine interaction_set_matrix_element_array (int, value, range) + class(interaction_t), intent(inout) :: int + complex(default), intent(in), dimension(:) :: value + integer, intent(in), dimension(:), optional :: range + end subroutine interaction_set_matrix_element_array + pure module subroutine interaction_set_matrix_element_single (int, i, value) + class(interaction_t), intent(inout) :: int + integer, intent(in) :: i + complex(default), intent(in) :: value + end subroutine interaction_set_matrix_element_single <>= - subroutine interaction_set_matrix_element_array (int, value, range) + module subroutine interaction_set_matrix_element_array (int, value, range) class(interaction_t), intent(inout) :: int complex(default), intent(in), dimension(:) :: value integer, intent(in), dimension(:), optional :: range call int%state_matrix%set_matrix_element (value, range) end subroutine interaction_set_matrix_element_array - pure subroutine interaction_set_matrix_element_single (int, i, value) + pure module subroutine interaction_set_matrix_element_single (int, i, value) class(interaction_t), intent(inout) :: int integer, intent(in) :: i complex(default), intent(in) :: value call int%state_matrix%set_matrix_element (i, value) end subroutine interaction_set_matrix_element_single @ %def interaction_set_matrix_element_array @ %def interaction_set_matrix_element_single @ Clone from another (matching) interaction. +<>= + module subroutine interaction_set_matrix_element_clone (int, int1) + class(interaction_t), intent(inout) :: int + class(interaction_t), intent(in) :: int1 + end subroutine interaction_set_matrix_element_clone <>= - subroutine interaction_set_matrix_element_clone (int, int1) + module subroutine interaction_set_matrix_element_clone (int, int1) class(interaction_t), intent(inout) :: int class(interaction_t), intent(in) :: int1 call int%state_matrix%set_matrix_element (int1%state_matrix) end subroutine interaction_set_matrix_element_clone @ %def interaction_set_matrix_element_clone @ <>= procedure :: set_only_matrix_element => interaction_set_only_matrix_element +<>= + module subroutine interaction_set_only_matrix_element (int, i, value) + class(interaction_t), intent(inout) :: int + integer, intent(in) :: i + complex(default), intent(in) :: value + end subroutine interaction_set_only_matrix_element <>= - subroutine interaction_set_only_matrix_element (int, i, value) + module subroutine interaction_set_only_matrix_element (int, i, value) class(interaction_t), intent(inout) :: int integer, intent(in) :: i complex(default), intent(in) :: value call int%set_matrix_element (cmplx (0, 0, default)) call int%set_matrix_element (i, value) end subroutine interaction_set_only_matrix_element @ %def interaction_set_only_matrix_element @ <>= procedure :: add_to_matrix_element => interaction_add_to_matrix_element +<>= + module subroutine interaction_add_to_matrix_element (int, qn, value, match_only_flavor) + class(interaction_t), intent(inout) :: int + type(quantum_numbers_t), dimension(:), intent(in) :: qn + complex(default), intent(in) :: value + logical, intent(in), optional :: match_only_flavor + end subroutine interaction_add_to_matrix_element <>= - subroutine interaction_add_to_matrix_element (int, qn, value, match_only_flavor) + module subroutine interaction_add_to_matrix_element (int, qn, value, match_only_flavor) class(interaction_t), intent(inout) :: int type(quantum_numbers_t), dimension(:), intent(in) :: qn complex(default), intent(in) :: value logical, intent(in), optional :: match_only_flavor call int%state_matrix%add_to_matrix_element (qn, value, match_only_flavor) end subroutine interaction_add_to_matrix_element @ %def interaction_add_to_matrix_element @ Get the indices of any diagonal matrix elements. <>= procedure :: get_diagonal_entries => interaction_get_diagonal_entries +<>= + module subroutine interaction_get_diagonal_entries (int, i) + class(interaction_t), intent(in) :: int + integer, dimension(:), allocatable, intent(out) :: i + end subroutine interaction_get_diagonal_entries <>= - subroutine interaction_get_diagonal_entries (int, i) + module subroutine interaction_get_diagonal_entries (int, i) class(interaction_t), intent(in) :: int integer, dimension(:), allocatable, intent(out) :: i call int%state_matrix%get_diagonal_entries (i) end subroutine interaction_get_diagonal_entries @ %def interaction_get_diagonal_entries @ Renormalize the state matrix by its trace, if nonzero. The renormalization is reflected in the state-matrix norm. <>= procedure :: normalize_by_trace => interaction_normalize_by_trace +<>= + module subroutine interaction_normalize_by_trace (int) + class(interaction_t), intent(inout) :: int + end subroutine interaction_normalize_by_trace <>= - subroutine interaction_normalize_by_trace (int) + module subroutine interaction_normalize_by_trace (int) class(interaction_t), intent(inout) :: int call int%state_matrix%normalize_by_trace () end subroutine interaction_normalize_by_trace @ %def interaction_normalize_by_trace @ Analogous, but renormalize by maximal (absolute) value. <>= procedure :: normalize_by_max => interaction_normalize_by_max +<>= + module subroutine interaction_normalize_by_max (int) + class(interaction_t), intent(inout) :: int + end subroutine interaction_normalize_by_max <>= - subroutine interaction_normalize_by_max (int) + module subroutine interaction_normalize_by_max (int) class(interaction_t), intent(inout) :: int call int%state_matrix%normalize_by_max () end subroutine interaction_normalize_by_max @ %def interaction_normalize_by_max @ Explicitly set the norm value (of the state matrix). <>= procedure :: set_norm => interaction_set_norm +<>= + module subroutine interaction_set_norm (int, norm) + class(interaction_t), intent(inout) :: int + real(default), intent(in) :: norm + end subroutine interaction_set_norm <>= - subroutine interaction_set_norm (int, norm) + module subroutine interaction_set_norm (int, norm) class(interaction_t), intent(inout) :: int real(default), intent(in) :: norm call int%state_matrix%set_norm (norm) end subroutine interaction_set_norm @ %def interaction_set_norm @ <>= procedure :: set_state_matrix => interaction_set_state_matrix +<>= + module subroutine interaction_set_state_matrix (int, state) + class(interaction_t), intent(inout) :: int + type(state_matrix_t), intent(in) :: state + end subroutine interaction_set_state_matrix <>= - subroutine interaction_set_state_matrix (int, state) + module subroutine interaction_set_state_matrix (int, state) class(interaction_t), intent(inout) :: int type(state_matrix_t), intent(in) :: state int%state_matrix = state end subroutine interaction_set_state_matrix @ %def interaction_set_state_matrix @ Return the maximum absolute value of color indices. <>= procedure :: get_max_color_value => & interaction_get_max_color_value +<>= + module function interaction_get_max_color_value (int) result (cmax) + class(interaction_t), intent(in) :: int + integer :: cmax + end function interaction_get_max_color_value <>= - function interaction_get_max_color_value (int) result (cmax) + module function interaction_get_max_color_value (int) result (cmax) class(interaction_t), intent(in) :: int integer :: cmax cmax = int%state_matrix%get_max_color_value () end function interaction_get_max_color_value @ %def interaction_get_max_color_value @ Factorize the state matrix into single-particle state matrices, the branch selection depending on a (random) value between 0 and 1; optionally also return a correlated state matrix. <>= procedure :: factorize => interaction_factorize +<>= + module subroutine interaction_factorize & + (int, mode, x, ok, single_state, correlated_state, qn_in) + class(interaction_t), intent(in), target :: int + integer, intent(in) :: mode + real(default), intent(in) :: x + logical, intent(out) :: ok + type(state_matrix_t), & + dimension(:), allocatable, intent(out) :: single_state + type(state_matrix_t), intent(out), optional :: correlated_state + type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in + end subroutine interaction_factorize <>= - subroutine interaction_factorize & + module subroutine interaction_factorize & (int, mode, x, ok, single_state, correlated_state, qn_in) class(interaction_t), intent(in), target :: int integer, intent(in) :: mode real(default), intent(in) :: x logical, intent(out) :: ok type(state_matrix_t), & dimension(:), allocatable, intent(out) :: single_state type(state_matrix_t), intent(out), optional :: correlated_state type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in call int%state_matrix%factorize & (mode, x, ok, single_state, correlated_state, qn_in) end subroutine interaction_factorize @ %def interaction_factorize @ Sum all matrix element values <>= procedure :: sum => interaction_sum +<>= + module function interaction_sum (int) result (value) + class(interaction_t), intent(in) :: int + complex(default) :: value + end function interaction_sum <>= - function interaction_sum (int) result (value) + module function interaction_sum (int) result (value) class(interaction_t), intent(in) :: int complex(default) :: value value = int%state_matrix%sum () end function interaction_sum @ %def interaction_sum @ Append new states which are color-contracted versions of the existing states. The matrix element index of each color contraction coincides with the index of its origin, so no new matrix elements are generated. After this operation, no [[freeze]] must be performed anymore. <>= procedure :: add_color_contractions => & interaction_add_color_contractions +<>= + module subroutine interaction_add_color_contractions (int) + class(interaction_t), intent(inout) :: int + end subroutine interaction_add_color_contractions <>= - subroutine interaction_add_color_contractions (int) + module subroutine interaction_add_color_contractions (int) class(interaction_t), intent(inout) :: int call int%state_matrix%add_color_contractions () end subroutine interaction_add_color_contractions @ %def interaction_add_color_contractions @ Multiply matrix elements from two interactions. Choose the elements as given by the integer index arrays, multiply them and store the sum of products in the indicated matrix element. The suffixes mean: c=conjugate first factor; f=include weighting factor. <>= procedure :: evaluate_product => interaction_evaluate_product procedure :: evaluate_product_cf => interaction_evaluate_product_cf procedure :: evaluate_square_c => interaction_evaluate_square_c procedure :: evaluate_sum => interaction_evaluate_sum procedure :: evaluate_me_sum => interaction_evaluate_me_sum +<>= + pure module subroutine interaction_evaluate_product & + (int, i, int1, int2, index1, index2) + class(interaction_t), intent(inout) :: int + integer, intent(in) :: i + type(interaction_t), intent(in) :: int1, int2 + integer, dimension(:), intent(in) :: index1, index2 + end subroutine interaction_evaluate_product + pure module subroutine interaction_evaluate_product_cf & + (int, i, int1, int2, index1, index2, factor) + class(interaction_t), intent(inout) :: int + integer, intent(in) :: i + type(interaction_t), intent(in) :: int1, int2 + integer, dimension(:), intent(in) :: index1, index2 + complex(default), dimension(:), intent(in) :: factor + end subroutine interaction_evaluate_product_cf + pure module subroutine interaction_evaluate_square_c (int, i, int1, index1) + class(interaction_t), intent(inout) :: int + integer, intent(in) :: i + type(interaction_t), intent(in) :: int1 + integer, dimension(:), intent(in) :: index1 + end subroutine interaction_evaluate_square_c + pure module subroutine interaction_evaluate_sum (int, i, int1, index1) + class(interaction_t), intent(inout) :: int + integer, intent(in) :: i + type(interaction_t), intent(in) :: int1 + integer, dimension(:), intent(in) :: index1 + end subroutine interaction_evaluate_sum + pure module subroutine interaction_evaluate_me_sum (int, i, int1, index1) + class(interaction_t), intent(inout) :: int + integer, intent(in) :: i + type(interaction_t), intent(in) :: int1 + integer, dimension(:), intent(in) :: index1 + end subroutine interaction_evaluate_me_sum <>= - pure subroutine interaction_evaluate_product & + pure module subroutine interaction_evaluate_product & (int, i, int1, int2, index1, index2) class(interaction_t), intent(inout) :: int integer, intent(in) :: i type(interaction_t), intent(in) :: int1, int2 integer, dimension(:), intent(in) :: index1, index2 call int%state_matrix%evaluate_product & (i, int1%state_matrix, int2%state_matrix, & index1, index2) end subroutine interaction_evaluate_product - pure subroutine interaction_evaluate_product_cf & + pure module subroutine interaction_evaluate_product_cf & (int, i, int1, int2, index1, index2, factor) class(interaction_t), intent(inout) :: int integer, intent(in) :: i type(interaction_t), intent(in) :: int1, int2 integer, dimension(:), intent(in) :: index1, index2 complex(default), dimension(:), intent(in) :: factor call int%state_matrix%evaluate_product_cf & (i, int1%state_matrix, int2%state_matrix, & index1, index2, factor) end subroutine interaction_evaluate_product_cf - pure subroutine interaction_evaluate_square_c (int, i, int1, index1) + pure module subroutine interaction_evaluate_square_c (int, i, int1, index1) class(interaction_t), intent(inout) :: int integer, intent(in) :: i type(interaction_t), intent(in) :: int1 integer, dimension(:), intent(in) :: index1 call int%state_matrix%evaluate_square_c (i, int1%state_matrix, index1) end subroutine interaction_evaluate_square_c - pure subroutine interaction_evaluate_sum (int, i, int1, index1) + pure module subroutine interaction_evaluate_sum (int, i, int1, index1) class(interaction_t), intent(inout) :: int integer, intent(in) :: i type(interaction_t), intent(in) :: int1 integer, dimension(:), intent(in) :: index1 call int%state_matrix%evaluate_sum (i, int1%state_matrix, index1) end subroutine interaction_evaluate_sum - pure subroutine interaction_evaluate_me_sum (int, i, int1, index1) + pure module subroutine interaction_evaluate_me_sum (int, i, int1, index1) class(interaction_t), intent(inout) :: int integer, intent(in) :: i type(interaction_t), intent(in) :: int1 integer, dimension(:), intent(in) :: index1 call int%state_matrix%evaluate_me_sum (i, int1%state_matrix, index1) end subroutine interaction_evaluate_me_sum @ %def interaction_evaluate_product @ %def interaction_evaluate_product_cf @ %def interaction_evaluate_square_c @ %def interaction_evaluate_sum @ %def interaction_evaluate_me_sum @ Tag quantum numbers of the state matrix as part of the hard process, according to the indices specified in [[tag]]. If no [[tag]] is given, all quantum numbers are tagged as part of the hard process. <>= procedure :: tag_hard_process => interaction_tag_hard_process +<>= + module subroutine interaction_tag_hard_process (int, tag) + class(interaction_t), intent(inout) :: int + integer, dimension(:), intent(in), optional :: tag + end subroutine interaction_tag_hard_process <>= - subroutine interaction_tag_hard_process (int, tag) + module subroutine interaction_tag_hard_process (int, tag) class(interaction_t), intent(inout) :: int integer, dimension(:), intent(in), optional :: tag type(state_matrix_t) :: state call int%state_matrix%tag_hard_process (state, tag) call int%state_matrix%final () int%state_matrix = state end subroutine interaction_tag_hard_process @ %def interaction_tag_hard_process @ Modify hard-interaction flags at the specified particle-position, in-place. <>= procedure :: retag_hard_process => interaction_retag_hard_process +<>= + module subroutine interaction_retag_hard_process (int, i, hard) + class(interaction_t), intent(inout), target :: int + integer, intent(in) :: i + logical, intent(in) :: hard + end subroutine interaction_retag_hard_process <>= - subroutine interaction_retag_hard_process (int, i, hard) + module subroutine interaction_retag_hard_process (int, i, hard) class(interaction_t), intent(inout), target :: int integer, intent(in) :: i logical, intent(in) :: hard type(state_iterator_t) :: it call it%init (int%get_state_matrix_ptr ()) do while (it%is_valid ()) call it%retag_hard_process (i, hard) call it%advance () end do end subroutine interaction_retag_hard_process @ %def interaction_retag_hard_process @ \subsection{Accessing contents} Return the integer tag. <>= procedure :: get_tag => interaction_get_tag +<>= + module function interaction_get_tag (int) result (tag) + class(interaction_t), intent(in) :: int + integer :: tag + end function interaction_get_tag <>= - function interaction_get_tag (int) result (tag) + module function interaction_get_tag (int) result (tag) class(interaction_t), intent(in) :: int integer :: tag tag = int%tag end function interaction_get_tag @ %def interaction_get_tag @ Return the number of particles. <>= procedure :: get_n_tot => interaction_get_n_tot procedure :: get_n_in => interaction_get_n_in procedure :: get_n_vir => interaction_get_n_vir procedure :: get_n_out => interaction_get_n_out +<>= + pure module function interaction_get_n_tot (object) result (n_tot) + class(interaction_t), intent(in) :: object + integer :: n_tot + end function interaction_get_n_tot + pure module function interaction_get_n_in (object) result (n_in) + class(interaction_t), intent(in) :: object + integer :: n_in + end function interaction_get_n_in + pure module function interaction_get_n_vir (object) result (n_vir) + class(interaction_t), intent(in) :: object + integer :: n_vir + end function interaction_get_n_vir + pure module function interaction_get_n_out (object) result (n_out) + class(interaction_t), intent(in) :: object + integer :: n_out + end function interaction_get_n_out <>= - pure function interaction_get_n_tot (object) result (n_tot) + pure module function interaction_get_n_tot (object) result (n_tot) class(interaction_t), intent(in) :: object integer :: n_tot n_tot = object%n_tot end function interaction_get_n_tot - pure function interaction_get_n_in (object) result (n_in) + pure module function interaction_get_n_in (object) result (n_in) class(interaction_t), intent(in) :: object integer :: n_in n_in = object%n_in end function interaction_get_n_in - pure function interaction_get_n_vir (object) result (n_vir) + pure module function interaction_get_n_vir (object) result (n_vir) class(interaction_t), intent(in) :: object integer :: n_vir n_vir = object%n_vir end function interaction_get_n_vir - pure function interaction_get_n_out (object) result (n_out) + pure module function interaction_get_n_out (object) result (n_out) class(interaction_t), intent(in) :: object integer :: n_out n_out = object%n_out end function interaction_get_n_out @ %def interaction_get_n_tot @ %def interaction_get_n_in interaction_get_n_vir interaction_get_n_out @ Return a momentum index. The flags specify whether to keep/drop incoming, virtual, or outgoing momenta. Check for illegal values. +<>= + module function idx (int, i, outgoing) + integer :: idx + type(interaction_t), intent(in) :: int + integer, intent(in) :: i + logical, intent(in), optional :: outgoing + end function idx <>= - function idx (int, i, outgoing) + module function idx (int, i, outgoing) integer :: idx type(interaction_t), intent(in) :: int integer, intent(in) :: i logical, intent(in), optional :: outgoing logical :: in, vir, out if (present (outgoing)) then in = .not. outgoing vir = .false. out = outgoing else in = .true. vir = .true. out = .true. end if idx = 0 if (in) then if (vir) then if (out) then if (i <= int%n_tot) idx = i else if (i <= int%n_in + int%n_vir) idx = i end if else if (out) then if (i <= int%n_in) then idx = i else if (i <= int%n_in + int%n_out) then idx = int%n_vir + i end if else if (i <= int%n_in) idx = i end if else if (vir) then if (out) then if (i <= int%n_vir + int%n_out) idx = int%n_in + i else if (i <= int%n_vir) idx = int%n_in + i end if else if (out) then if (i <= int%n_out) idx = int%n_in + int%n_vir + i end if if (idx == 0) then call int%basic_write () print *, i, in, vir, out call msg_bug (" Momentum index is out of range for this interaction") end if end function idx @ %def idx @ Return all or just a specific four-momentum. <>= generic :: get_momenta => get_momenta_all, get_momenta_idx procedure :: get_momentum => interaction_get_momentum procedure :: get_momenta_all => interaction_get_momenta_all procedure :: get_momenta_idx => interaction_get_momenta_idx +<>= + module function interaction_get_momenta_all (int, outgoing) result (p) + class(interaction_t), intent(in) :: int + type(vector4_t), dimension(:), allocatable :: p + logical, intent(in), optional :: outgoing + end function interaction_get_momenta_all + module function interaction_get_momenta_idx (int, jj) result (p) + class(interaction_t), intent(in) :: int + type(vector4_t), dimension(:), allocatable :: p + integer, dimension(:), intent(in) :: jj + end function interaction_get_momenta_idx + module function interaction_get_momentum (int, i, outgoing) result (p) + class(interaction_t), intent(in) :: int + type(vector4_t) :: p + integer, intent(in) :: i + logical, intent(in), optional :: outgoing + end function interaction_get_momentum <>= - function interaction_get_momenta_all (int, outgoing) result (p) + module function interaction_get_momenta_all (int, outgoing) result (p) class(interaction_t), intent(in) :: int type(vector4_t), dimension(:), allocatable :: p logical, intent(in), optional :: outgoing integer :: i if (present (outgoing)) then if (outgoing) then allocate (p (int%n_out)) else allocate (p (int%n_in)) end if else allocate (p (int%n_tot)) end if do i = 1, size (p) p(i) = int%p(idx (int, i, outgoing)) end do end function interaction_get_momenta_all - function interaction_get_momenta_idx (int, jj) result (p) + module function interaction_get_momenta_idx (int, jj) result (p) class(interaction_t), intent(in) :: int type(vector4_t), dimension(:), allocatable :: p integer, dimension(:), intent(in) :: jj allocate (p (size (jj))) p = int%p(jj) end function interaction_get_momenta_idx - function interaction_get_momentum (int, i, outgoing) result (p) + module function interaction_get_momentum (int, i, outgoing) result (p) class(interaction_t), intent(in) :: int type(vector4_t) :: p integer, intent(in) :: i logical, intent(in), optional :: outgoing p = int%p(idx (int, i, outgoing)) end function interaction_get_momentum @ %def interaction_get_momenta interaction_get_momentum @ Return a shallow copy of the state matrix: <>= procedure :: get_state_matrix_ptr => & interaction_get_state_matrix_ptr +<>= + module function interaction_get_state_matrix_ptr (int) result (state) + class(interaction_t), intent(in), target :: int + type(state_matrix_t), pointer :: state + end function interaction_get_state_matrix_ptr <>= - function interaction_get_state_matrix_ptr (int) result (state) + module function interaction_get_state_matrix_ptr (int) result (state) class(interaction_t), intent(in), target :: int type(state_matrix_t), pointer :: state state => int%state_matrix end function interaction_get_state_matrix_ptr @ %def interaction_get_state_matrix_ptr @ Return the array of resonance flags <>= procedure :: get_resonance_flags => interaction_get_resonance_flags +<>= + module function interaction_get_resonance_flags (int) result (resonant) + class(interaction_t), intent(in) :: int + logical, dimension(size(int%resonant)) :: resonant + end function interaction_get_resonance_flags <>= - function interaction_get_resonance_flags (int) result (resonant) + module function interaction_get_resonance_flags (int) result (resonant) class(interaction_t), intent(in) :: int logical, dimension(size(int%resonant)) :: resonant resonant = int%resonant end function interaction_get_resonance_flags @ %def interaction_get_resonance_flags @ Return the quantum-numbers mask (or part of it) <>= generic :: get_mask => get_mask_all, get_mask_slice procedure :: get_mask_all => interaction_get_mask_all procedure :: get_mask_slice => interaction_get_mask_slice +<>= + module function interaction_get_mask_all (int) result (mask) + class(interaction_t), intent(in) :: int + type(quantum_numbers_mask_t), dimension(size(int%mask)) :: mask + end function interaction_get_mask_all + module function interaction_get_mask_slice (int, index) result (mask) + class(interaction_t), intent(in) :: int + integer, dimension(:), intent(in) :: index + type(quantum_numbers_mask_t), dimension(size(index)) :: mask + end function interaction_get_mask_slice <>= - function interaction_get_mask_all (int) result (mask) + module function interaction_get_mask_all (int) result (mask) class(interaction_t), intent(in) :: int type(quantum_numbers_mask_t), dimension(size(int%mask)) :: mask mask = int%mask end function interaction_get_mask_all - function interaction_get_mask_slice (int, index) result (mask) + module function interaction_get_mask_slice (int, index) result (mask) class(interaction_t), intent(in) :: int integer, dimension(:), intent(in) :: index type(quantum_numbers_mask_t), dimension(size(index)) :: mask mask = int%mask(index) end function interaction_get_mask_slice @ %def interaction_get_mask @ Compute the invariant mass squared of the incoming particles (if any, otherwise outgoing). -<>= - public :: interaction_get_s +<>= + procedure :: get_s => interaction_get_s +<>= + module function interaction_get_s (int) result (s) + real(default) :: s + class(interaction_t), intent(in) :: int + end function interaction_get_s <>= - function interaction_get_s (int) result (s) + module function interaction_get_s (int) result (s) real(default) :: s - type(interaction_t), intent(in) :: int + class(interaction_t), intent(in) :: int if (int%n_in /= 0) then s = sum (int%p(:int%n_in)) ** 2 else s = sum (int%p(int%n_vir + 1 : )) ** 2 end if end function interaction_get_s @ %def interaction_get_s @ Compute the Lorentz transformation that transforms the incoming particles from the center-of-mass frame to the lab frame where they are given. If the c.m. mass squared is negative or zero, return the identity. -<>= - public :: interaction_get_cm_transformation +<>= + procedure :: get_cm_transformation => interaction_get_cm_transformation +<>= + module function interaction_get_cm_transformation (int) result (lt) + type(lorentz_transformation_t) :: lt + class(interaction_t), intent(in) :: int + end function interaction_get_cm_transformation <>= - function interaction_get_cm_transformation (int) result (lt) + module function interaction_get_cm_transformation (int) result (lt) type(lorentz_transformation_t) :: lt - type(interaction_t), intent(in) :: int + class(interaction_t), intent(in) :: int type(vector4_t) :: p_cm real(default) :: s if (int%n_in /= 0) then p_cm = sum (int%p(:int%n_in)) else p_cm = sum (int%p(int%n_vir+1:)) end if s = p_cm ** 2 if (s > 0) then lt = boost (p_cm, sqrt (s)) else lt = identity end if end function interaction_get_cm_transformation @ %def interaction_get_cm_transformation @ Return flavor, momentum, and position of the first outgoing unstable particle present in the interaction. Note that we need not iterate through the state matrix; if there is an unstable particle, it will be present in all state-matrix entries. -<>= - public :: interaction_get_unstable_particle +<>= + procedure :: get_unstable_particle => interaction_get_unstable_particle +<>= + module subroutine interaction_get_unstable_particle (int, flv, p, i) + class(interaction_t), intent(in), target :: int + type(flavor_t), intent(out) :: flv + type(vector4_t), intent(out) :: p + integer, intent(out) :: i + end subroutine interaction_get_unstable_particle <>= - subroutine interaction_get_unstable_particle (int, flv, p, i) - type(interaction_t), intent(in), target :: int + module subroutine interaction_get_unstable_particle (int, flv, p, i) + class(interaction_t), intent(in), target :: int type(flavor_t), intent(out) :: flv type(vector4_t), intent(out) :: p integer, intent(out) :: i type(state_iterator_t) :: it type(flavor_t), dimension(int%n_tot) :: flv_array call it%init (int%state_matrix) flv_array = it%get_flavor () do i = int%n_in + int%n_vir + 1, int%n_tot if (.not. flv_array(i)%is_stable ()) then flv = flv_array(i) p = int%p(i) return end if end do end subroutine interaction_get_unstable_particle @ %def interaction_get_unstable_particle @ Return the complete set of \emph{outgoing} flavors, assuming that the flavor quantum number is not suppressed. -<>= - public :: interaction_get_flv_out +<>= + procedure :: get_flv_out => interaction_get_flv_out +<>= + module subroutine interaction_get_flv_out (int, flv) + class(interaction_t), intent(in), target :: int + type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv + end subroutine interaction_get_flv_out <>= - subroutine interaction_get_flv_out (int, flv) - type(interaction_t), intent(in), target :: int + module subroutine interaction_get_flv_out (int, flv) + class(interaction_t), intent(in), target :: int type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv type(state_iterator_t) :: it type(flavor_t), dimension(:), allocatable :: flv_state integer :: n_in, n_vir, n_out, n_tot, n_state, i n_in = int%get_n_in () n_vir = int%get_n_vir () n_out = int%get_n_out () n_tot = int%get_n_tot () n_state = int%get_n_matrix_elements () allocate (flv (n_out, n_state)) allocate (flv_state (n_tot)) i = 1 call it%init (int%get_state_matrix_ptr ()) do while (it%is_valid ()) flv_state = it%get_flavor () flv(:,i) = flv_state(n_in + n_vir + 1 : ) i = i + 1 call it%advance () end do end subroutine interaction_get_flv_out @ %def interaction_get_flv_out @ Determine the flavor content of the interaction. We analyze the state matrix for this, and we select the outgoing particles of the hard process only for the required mask, which indicates the particles that can appear in any order in a matching event record. We have to assume that any radiated particles (beam remnants) appear at the beginning of the particles marked as outgoing. -<>= - public :: interaction_get_flv_content +<>= + procedure :: get_flv_content => interaction_get_flv_content +<>= + module subroutine interaction_get_flv_content (int, state_flv, n_out_hard) + class(interaction_t), intent(in), target :: int + type(state_flv_content_t), intent(out) :: state_flv + integer, intent(in) :: n_out_hard + end subroutine interaction_get_flv_content <>= - subroutine interaction_get_flv_content (int, state_flv, n_out_hard) - type(interaction_t), intent(in), target :: int + module subroutine interaction_get_flv_content (int, state_flv, n_out_hard) + class(interaction_t), intent(in), target :: int type(state_flv_content_t), intent(out) :: state_flv integer, intent(in) :: n_out_hard logical, dimension(:), allocatable :: mask integer :: n_tot n_tot = int%get_n_tot () allocate (mask (n_tot), source = .false.) mask(n_tot-n_out_hard + 1 : ) = .true. call state_flv%fill (int%get_state_matrix_ptr (), mask) end subroutine interaction_get_flv_content @ %def interaction_get_flv_content @ \subsection{Modifying contents} Set the quantum numbers mask. <>= procedure :: set_mask => interaction_set_mask +<>= + module subroutine interaction_set_mask (int, mask) + class(interaction_t), intent(inout) :: int + type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask + end subroutine interaction_set_mask <>= - subroutine interaction_set_mask (int, mask) + module subroutine interaction_set_mask (int, mask) class(interaction_t), intent(inout) :: int type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask if (size (int%mask) /= size (mask)) & call msg_fatal ("Attempting to set mask with unfitting size!") int%mask = mask int%update_state_matrix = .true. end subroutine interaction_set_mask @ %def interaction_set_mask @ Merge a particular mask entry, respecting a possible helicity lock for this entry. We apply an OR relation, which means that quantum numbers are summed over if either of the two masks requires it. <>= subroutine interaction_merge_mask_entry (int, i, mask) type(interaction_t), intent(inout) :: int integer, intent(in) :: i type(quantum_numbers_mask_t), intent(in) :: mask type(quantum_numbers_mask_t) :: mask_tmp integer :: ii ii = idx (int, i) if (int%mask(ii) .neqv. mask) then int%mask(ii) = int%mask(ii) .or. mask if (int%hel_lock(ii) /= 0) then call mask_tmp%assign (mask, helicity=.true.) int%mask(int%hel_lock(ii)) = int%mask(int%hel_lock(ii)) .or. mask_tmp end if end if int%update_state_matrix = .true. end subroutine interaction_merge_mask_entry @ %def interaction_merge_mask_entry @ Fill the momenta array, do not care about the quantum numbers of particles. <>= procedure :: reset_momenta => interaction_reset_momenta procedure :: set_momenta => interaction_set_momenta procedure :: set_momentum => interaction_set_momentum +<>= + module subroutine interaction_reset_momenta (int) + class(interaction_t), intent(inout) :: int + end subroutine interaction_reset_momenta + module subroutine interaction_set_momenta (int, p, outgoing) + class(interaction_t), intent(inout) :: int + type(vector4_t), dimension(:), intent(in) :: p + logical, intent(in), optional :: outgoing + end subroutine interaction_set_momenta + module subroutine interaction_set_momentum (int, p, i, outgoing) + class(interaction_t), intent(inout) :: int + type(vector4_t), intent(in) :: p + integer, intent(in) :: i + logical, intent(in), optional :: outgoing + end subroutine interaction_set_momentum <>= - subroutine interaction_reset_momenta (int) + module subroutine interaction_reset_momenta (int) class(interaction_t), intent(inout) :: int int%p = vector4_null int%p_is_known = .true. end subroutine interaction_reset_momenta - subroutine interaction_set_momenta (int, p, outgoing) + module subroutine interaction_set_momenta (int, p, outgoing) class(interaction_t), intent(inout) :: int type(vector4_t), dimension(:), intent(in) :: p logical, intent(in), optional :: outgoing integer :: i, index do i = 1, size (p) index = idx (int, i, outgoing) int%p(index) = p(i) int%p_is_known(index) = .true. end do end subroutine interaction_set_momenta - subroutine interaction_set_momentum (int, p, i, outgoing) + module subroutine interaction_set_momentum (int, p, i, outgoing) class(interaction_t), intent(inout) :: int type(vector4_t), intent(in) :: p integer, intent(in) :: i logical, intent(in), optional :: outgoing integer :: index index = idx (int, i, outgoing) int%p(index) = p int%p_is_known(index) = .true. end subroutine interaction_set_momentum @ %def interaction_reset_momenta @ %def interaction_set_momenta interaction_set_momentum @ This more sophisticated version of setting values is used for structure functions, in particular if nontrivial flavor, color, and helicity may be present: set values selectively for the given flavors. If there is more than one flavor, scan the interaction and check for a matching flavor at the specified particle location. If it matches, insert the value that corresponds to this flavor. -<>= - public :: interaction_set_flavored_values +<>= + procedure :: set_flavored_values => interaction_set_flavored_values +<>= + module subroutine interaction_set_flavored_values (int, value, flv_in, pos) + class(interaction_t), intent(inout) :: int + complex(default), dimension(:), intent(in) :: value + type(flavor_t), dimension(:), intent(in) :: flv_in + integer, intent(in) :: pos + end subroutine interaction_set_flavored_values <>= - subroutine interaction_set_flavored_values (int, value, flv_in, pos) - type(interaction_t), intent(inout) :: int + module subroutine interaction_set_flavored_values (int, value, flv_in, pos) + class(interaction_t), intent(inout) :: int complex(default), dimension(:), intent(in) :: value type(flavor_t), dimension(:), intent(in) :: flv_in integer, intent(in) :: pos type(state_iterator_t) :: it type(flavor_t) :: flv integer :: i if (size (value) == 1) then call int%set_matrix_element (value(1)) else call it%init (int%state_matrix) do while (it%is_valid ()) flv = it%get_flavor (pos) SCAN_FLV: do i = 1, size (value) if (flv == flv_in(i)) then call it%set_matrix_element (value(i)) exit SCAN_FLV end if end do SCAN_FLV call it%advance () end do end if end subroutine interaction_set_flavored_values @ %def interaction_set_flavored_values @ \subsection{Handling Linked interactions} Store relations between corresponding particles within one interaction. The first particle is the parent, the second one the child. Links are established in both directions. These relations have no effect on the propagation of momenta etc., they are rather used for mother-daughter relations in event output. <>= procedure :: relate => interaction_relate +<>= + module subroutine interaction_relate (int, i1, i2) + class(interaction_t), intent(inout), target :: int + integer, intent(in) :: i1, i2 + end subroutine interaction_relate <>= - subroutine interaction_relate (int, i1, i2) + module subroutine interaction_relate (int, i1, i2) class(interaction_t), intent(inout), target :: int integer, intent(in) :: i1, i2 if (i1 /= 0 .and. i2 /= 0) then call int%children(i1)%append (i2) call int%parents(i2)%append (i1) end if end subroutine interaction_relate @ %def interaction_relate @ Transfer internal parent-child relations defined within interaction [[int1]] to a new interaction [[int]] where the particle indices are mapped to. Some particles in [[int1]] may have no image in [[int]]. In that case, a child entry maps to zero, and we skip this relation. Also transfer resonance flags. <>= procedure :: transfer_relations => interaction_transfer_relations +<>= + module subroutine interaction_transfer_relations (int1, int2, map) + class(interaction_t), intent(in) :: int1 + class(interaction_t), intent(inout), target :: int2 + integer, dimension(:), intent(in) :: map + end subroutine interaction_transfer_relations <>= - subroutine interaction_transfer_relations (int1, int2, map) + module subroutine interaction_transfer_relations (int1, int2, map) class(interaction_t), intent(in) :: int1 class(interaction_t), intent(inout), target :: int2 integer, dimension(:), intent(in) :: map integer :: i, j, k do i = 1, size (map) do j = 1, int1%parents(i)%get_length () k = int1%parents(i)%get_link (j) call int2%relate (map(k), map(i)) end do if (map(i) /= 0) then int2%resonant(map(i)) = int1%resonant(i) end if end do end subroutine interaction_transfer_relations @ %def interaction_transfer_relations @ Make up internal parent-child relations for the particle(s) that are connected to a new interaction [[int]]. If [[resonant]] is defined and true, the connections are marked as resonant in the result interaction. Also, the children of the resonant connections are untagged if they were tagged with hard-interaction flags previously. <>= procedure :: relate_connections => interaction_relate_connections +<>= + module subroutine interaction_relate_connections & + (int, int_in, connection_index, & + map, map_connections, resonant) + class(interaction_t), intent(inout), target :: int + class(interaction_t), intent(in) :: int_in + integer, dimension(:), intent(in) :: connection_index + integer, dimension(:), intent(in) :: map, map_connections + logical, intent(in), optional :: resonant + end subroutine interaction_relate_connections <>= - subroutine interaction_relate_connections & + module subroutine interaction_relate_connections & (int, int_in, connection_index, & map, map_connections, resonant) class(interaction_t), intent(inout), target :: int class(interaction_t), intent(in) :: int_in integer, dimension(:), intent(in) :: connection_index integer, dimension(:), intent(in) :: map, map_connections logical, intent(in), optional :: resonant logical :: reson integer :: i, j, i2, k2 reson = .false.; if (present (resonant)) reson = resonant do i = 1, size (map_connections) k2 = connection_index(i) do j = 1, int_in%children(k2)%get_length () i2 = int_in%children(k2)%get_link (j) call int%relate (map_connections(i), map(i2)) if (reson) call int%retag_hard_process (map(i2), .false.) end do int%resonant(map_connections(i)) = reson end do end subroutine interaction_relate_connections @ %def interaction_relate_connections. @ Return the number of source/target links of the internal connections of particle [[i]]. -<>= - public :: interaction_get_n_children - public :: interaction_get_n_parents +<>= + procedure :: get_n_children => interaction_get_n_children + procedure :: get_n_parents => interaction_get_n_parents +<>= + module function interaction_get_n_children (int, i) result (n) + integer :: n + class(interaction_t), intent(in) :: int + integer, intent(in) :: i + end function interaction_get_n_children + module function interaction_get_n_parents (int, i) result (n) + integer :: n + class(interaction_t), intent(in) :: int + integer, intent(in) :: i + end function interaction_get_n_parents <>= - function interaction_get_n_children (int, i) result (n) + module function interaction_get_n_children (int, i) result (n) integer :: n - type(interaction_t), intent(in) :: int + class(interaction_t), intent(in) :: int integer, intent(in) :: i n = int%children(i)%get_length () end function interaction_get_n_children - function interaction_get_n_parents (int, i) result (n) + module function interaction_get_n_parents (int, i) result (n) integer :: n - type(interaction_t), intent(in) :: int + class(interaction_t), intent(in) :: int integer, intent(in) :: i n = int%parents(i)%get_length () end function interaction_get_n_parents @ %def interaction_get_n_children interaction_get_n_parents @ Return the source/target links of the internal connections of particle [[i]] as an array. -<>= - public :: interaction_get_children - public :: interaction_get_parents +<>= + procedure :: get_children => interaction_get_children + procedure :: get_parents => interaction_get_parents +<>= + module function interaction_get_children (int, i) result (idx) + integer, dimension(:), allocatable :: idx + class(interaction_t), intent(in) :: int + integer, intent(in) :: i + end function interaction_get_children + module function interaction_get_parents (int, i) result (idx) + integer, dimension(:), allocatable :: idx + class(interaction_t), intent(in) :: int + integer, intent(in) :: i + end function interaction_get_parents <>= - function interaction_get_children (int, i) result (idx) + module function interaction_get_children (int, i) result (idx) integer, dimension(:), allocatable :: idx - type(interaction_t), intent(in) :: int + class(interaction_t), intent(in) :: int integer, intent(in) :: i integer :: k, l l = int%children(i)%get_length () allocate (idx (l)) do k = 1, l idx(k) = int%children(i)%get_link (k) end do end function interaction_get_children - function interaction_get_parents (int, i) result (idx) + module function interaction_get_parents (int, i) result (idx) integer, dimension(:), allocatable :: idx - type(interaction_t), intent(in) :: int + class(interaction_t), intent(in) :: int integer, intent(in) :: i integer :: k, l l = int%parents(i)%get_length () allocate (idx (l)) do k = 1, l idx(k) = int%parents(i)%get_link (k) end do end function interaction_get_parents @ %def interaction_get_children interaction_get_parents @ Add a source link from an interaction to a corresponding particle within another interaction. These links affect the propagation of particles: the two linked particles are considered as the same particle, outgoing and incoming. <>= procedure :: set_source_link => interaction_set_source_link +<>= + module subroutine interaction_set_source_link (int, i, int1, i1) + class(interaction_t), intent(inout) :: int + integer, intent(in) :: i + class(interaction_t), intent(in), target :: int1 + integer, intent(in) :: i1 + end subroutine interaction_set_source_link <>= - subroutine interaction_set_source_link (int, i, int1, i1) + module subroutine interaction_set_source_link (int, i, int1, i1) class(interaction_t), intent(inout) :: int integer, intent(in) :: i class(interaction_t), intent(in), target :: int1 integer, intent(in) :: i1 if (i /= 0) call external_link_set (int%source(i), int1, i1) end subroutine interaction_set_source_link @ %def interaction_set_source_link @ Reassign links to a new interaction (which is an image of the current interaction). <>= public :: interaction_reassign_links +<>= + module subroutine interaction_reassign_links (int, int_src, int_target) + type(interaction_t), intent(inout) :: int + type(interaction_t), intent(in) :: int_src + type(interaction_t), intent(in), target :: int_target + end subroutine interaction_reassign_links <>= - subroutine interaction_reassign_links (int, int_src, int_target) + module subroutine interaction_reassign_links (int, int_src, int_target) type(interaction_t), intent(inout) :: int type(interaction_t), intent(in) :: int_src type(interaction_t), intent(in), target :: int_target integer :: i if (allocated (int%source)) then do i = 1, size (int%source) call external_link_reassign (int%source(i), int_src, int_target) end do end if end subroutine interaction_reassign_links @ %def interaction_reassign_links @ Since links are one-directional, if we want to follow them backwards we have to scan all possibilities. This procedure returns the index of the particle within [[int]] which points to the particle [[i1]] within interaction [[int1]]. If unsuccessful, return zero. <>= public :: interaction_find_link +<>= + module function interaction_find_link (int, int1, i1) result (i) + integer :: i + type(interaction_t), intent(in) :: int, int1 + integer, intent(in) :: i1 + end function interaction_find_link <>= - function interaction_find_link (int, int1, i1) result (i) + module function interaction_find_link (int, int1, i1) result (i) integer :: i type(interaction_t), intent(in) :: int, int1 integer, intent(in) :: i1 type(interaction_t), pointer :: int_tmp do i = 1, int%n_tot int_tmp => external_link_get_ptr (int%source(i)) if (int_tmp%tag == int1%tag) then if (external_link_get_index (int%source(i)) == i1) return end if end do i = 0 end function interaction_find_link @ %def interaction_find_link @ The inverse: return interaction pointer and index for the ultimate source of [[i]] within [[int]]. <>= procedure :: find_source => interaction_find_source +<>= + module subroutine interaction_find_source (int, i, int1, i1) + class(interaction_t), intent(in) :: int + integer, intent(in) :: i + type(interaction_t), intent(out), pointer :: int1 + integer, intent(out) :: i1 + end subroutine interaction_find_source <>= - subroutine interaction_find_source (int, i, int1, i1) + module subroutine interaction_find_source (int, i, int1, i1) class(interaction_t), intent(in) :: int integer, intent(in) :: i type(interaction_t), intent(out), pointer :: int1 integer, intent(out) :: i1 type(external_link_t) :: link link = interaction_get_ultimate_source (int, i) int1 => external_link_get_ptr (link) i1 = external_link_get_index (link) end subroutine interaction_find_source @ %def interaction_find_source @ Follow source links recursively to return the ultimate source of a particle. +<>= + module function interaction_get_ultimate_source (int, i) result (link) + type(external_link_t) :: link + type(interaction_t), intent(in) :: int + integer, intent(in) :: i + end function interaction_get_ultimate_source <>= - function interaction_get_ultimate_source (int, i) result (link) + module function interaction_get_ultimate_source (int, i) result (link) type(external_link_t) :: link type(interaction_t), intent(in) :: int integer, intent(in) :: i type(interaction_t), pointer :: int_src integer :: i_src link = int%source(i) if (external_link_is_set (link)) then do int_src => external_link_get_ptr (link) i_src = external_link_get_index (link) if (external_link_is_set (int_src%source(i_src))) then link = int_src%source(i_src) else exit end if end do end if end function interaction_get_ultimate_source @ %def interaction_get_ultimate_source @ Update mask entries by merging them with corresponding masks in interactions linked to the current one. The mask determines quantum numbers which are summed over. Note that both the mask of the current interaction and the mask of the linked interaction are updated (side effect!). This ensures that both agree for the linked particle. -<>= - public :: interaction_exchange_mask +<>= + procedure :: exchange_mask => interaction_exchange_mask +<>= + module subroutine interaction_exchange_mask (int) + class(interaction_t), intent(inout) :: int + end subroutine interaction_exchange_mask <>= - subroutine interaction_exchange_mask (int) - type(interaction_t), intent(inout) :: int + module subroutine interaction_exchange_mask (int) + class(interaction_t), intent(inout) :: int integer :: i, index_link type(interaction_t), pointer :: int_link do i = 1, int%n_tot if (external_link_is_set (int%source(i))) then int_link => external_link_get_ptr (int%source(i)) index_link = external_link_get_index (int%source(i)) call interaction_merge_mask_entry & (int, i, int_link%mask(index_link)) call interaction_merge_mask_entry & (int_link, index_link, int%mask(i)) end if end do call int%freeze () end subroutine interaction_exchange_mask @ %def interaction_exchange_mask @ Copy momenta from interactions linked to the current one. <>= procedure :: receive_momenta => interaction_receive_momenta +<>= + module subroutine interaction_receive_momenta (int) + class(interaction_t), intent(inout) :: int + end subroutine interaction_receive_momenta <>= - subroutine interaction_receive_momenta (int) + module subroutine interaction_receive_momenta (int) class(interaction_t), intent(inout) :: int integer :: i, index_link type(interaction_t), pointer :: int_link do i = 1, int%n_tot if (external_link_is_set (int%source(i))) then int_link => external_link_get_ptr (int%source(i)) index_link = external_link_get_index (int%source(i)) call int%set_momentum (int_link%p(index_link), i) end if end do end subroutine interaction_receive_momenta @ %def interaction_receive_momenta @ The inverse operation: Copy momenta back to the interactions linked to the current one. -<>= - public :: interaction_send_momenta +<>= + procedure :: send_momenta => interaction_send_momenta +<>= + module subroutine interaction_send_momenta (int) + class(interaction_t), intent(in) :: int + end subroutine interaction_send_momenta <>= - subroutine interaction_send_momenta (int) - type(interaction_t), intent(in) :: int + module subroutine interaction_send_momenta (int) + class(interaction_t), intent(in) :: int integer :: i, index_link type(interaction_t), pointer :: int_link do i = 1, int%n_tot if (external_link_is_set (int%source(i))) then int_link => external_link_get_ptr (int%source(i)) index_link = external_link_get_index (int%source(i)) call int_link%set_momentum (int%p(i), index_link) end if end do end subroutine interaction_send_momenta @ %def interaction_send_momenta @ For numerical comparisons: pacify all momenta in an interaction. -<>= - public :: interaction_pacify_momenta +<>= + procedure :: pacify_momenta => interaction_pacify_momenta +<>= + module subroutine interaction_pacify_momenta (int, acc) + class(interaction_t), intent(inout) :: int + real(default), intent(in) :: acc + end subroutine interaction_pacify_momenta <>= - subroutine interaction_pacify_momenta (int, acc) - type(interaction_t), intent(inout) :: int + module subroutine interaction_pacify_momenta (int, acc) + class(interaction_t), intent(inout) :: int real(default), intent(in) :: acc integer :: i do i = 1, int%n_tot call pacify (int%p(i), acc) end do end subroutine interaction_pacify_momenta @ %def interaction_pacify_momenta -@ For each subtraction entry starting from [[SUB = 0]], we duplicate the original state matrix entries as is. +@ For each subtraction entry starting from [[SUB = 0]], we duplicate +the original state matrix entries as is. <>= procedure :: declare_subtraction => interaction_declare_subtraction +<>= + module subroutine interaction_declare_subtraction (int, n_sub) + class(interaction_t), intent(inout), target :: int + integer, intent(in) :: n_sub + end subroutine interaction_declare_subtraction <>= - subroutine interaction_declare_subtraction (int, n_sub) + module subroutine interaction_declare_subtraction (int, n_sub) class(interaction_t), intent(inout), target :: int integer, intent(in) :: n_sub integer :: i_sub type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:), allocatable :: qn type(state_matrix_t) :: state_matrix call state_matrix%init (store_values = .true.) allocate (qn (int%get_state_depth ())) do i_sub = 0, n_sub call it%init (int%state_matrix) do while (it%is_valid ()) qn = it%get_quantum_numbers () call qn%set_subtraction_index (i_sub) call state_matrix%add_state (qn, value = it%get_matrix_element ()) call it%advance () end do end do call state_matrix%freeze () call state_matrix%set_n_sub () call int%state_matrix%final () int%state_matrix = state_matrix end subroutine interaction_declare_subtraction @ %def interaction_declare_subtraction @ \subsection{Recovering connections} When creating an evaluator for two interactions, we have to know by which particles they are connected. The connection indices can be determined if we have two linked interactions. We assume that [[int1]] is the source and [[int2]] the target, so the connections of interest are stored within [[int2]]. A connection is found if either the source is [[int1]], or the (ultimate) source of a particle within [[int2]] coincides with the (ultimate) source of a particle within [[int1]]. The result is an array of index pairs. To make things simple, we scan the interaction twice, once for counting hits, then allocate the array, then scan again and store the connections. The connections are scanned for [[int2]], which has sources in [[int1]]. It may happen that the order of connections is interchanged (crossed). We require the indices in [[int1]] to be sorted, so we reorder both index arrays correspondingly before returning them. (After this, the indices in [[int2]] may be out of order.) <>= public :: find_connections +<>= + module subroutine find_connections (int1, int2, n, connection_index) + class(interaction_t), intent(in) :: int1, int2 + integer, intent(out) :: n + integer, dimension(:,:), intent(out), allocatable :: connection_index + integer, dimension(:,:), allocatable :: conn_index_tmp + integer, dimension(:), allocatable :: ordering + end subroutine find_connections <>= - subroutine find_connections (int1, int2, n, connection_index) + module subroutine find_connections (int1, int2, n, connection_index) class(interaction_t), intent(in) :: int1, int2 integer, intent(out) :: n integer, dimension(:,:), intent(out), allocatable :: connection_index integer, dimension(:,:), allocatable :: conn_index_tmp integer, dimension(:), allocatable :: ordering integer :: i, j, k type(external_link_t) :: link1, link2 type(interaction_t), pointer :: int_link1, int_link2 n = 0 do i = 1, size (int2%source) link2 = interaction_get_ultimate_source (int2, i) if (external_link_is_set (link2)) then int_link2 => external_link_get_ptr (link2) if (int_link2%tag == int1%tag) then n = n + 1 else k = external_link_get_index (link2) do j = 1, size (int1%source) link1 = interaction_get_ultimate_source (int1, j) if (external_link_is_set (link1)) then int_link1 => external_link_get_ptr (link1) if (int_link1%tag == int_link2%tag) then if (external_link_get_index (link1) == k) & n = n + 1 end if end if end do end if end if end do allocate (conn_index_tmp (n, 2)) n = 0 do i = 1, size (int2%source) link2 = interaction_get_ultimate_source (int2, i) if (external_link_is_set (link2)) then int_link2 => external_link_get_ptr (link2) if (int_link2%tag == int1%tag) then n = n + 1 conn_index_tmp(n,1) = external_link_get_index (int2%source(i)) conn_index_tmp(n,2) = i else k = external_link_get_index (link2) do j = 1, size (int1%source) link1 = interaction_get_ultimate_source (int1, j) if (external_link_is_set (link1)) then int_link1 => external_link_get_ptr (link1) if (int_link1%tag == int_link2%tag) then if (external_link_get_index (link1) == k) then n = n + 1 conn_index_tmp(n,1) = j conn_index_tmp(n,2) = i end if end if end if end do end if end if end do allocate (connection_index (n, 2)) if (n > 1) then allocate (ordering (n)) ordering = order (conn_index_tmp(:,1)) connection_index = conn_index_tmp(ordering,:) else connection_index = conn_index_tmp end if end subroutine find_connections @ %def find_connections @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[interactions_ut.f90]]>>= <> module interactions_ut use unit_tests use interactions_uti <> <> contains <> end module interactions_ut @ %def interactions_ut @ <<[[interactions_uti.f90]]>>= <> module interactions_uti <> use lorentz use flavors use colors use helicities use quantum_numbers use state_matrices use interactions <> <> contains <> end module interactions_uti @ %def interactions_ut @ API: driver for the unit tests below. <>= public :: interaction_test <>= subroutine interaction_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine interaction_test @ %def interaction_test @ Generate an interaction of a polarized virtual photon and a colored quark which may be either up or down. Remove the quark polarization. Generate another interaction for the quark radiating a photon and link this to the first interation. The radiation ignores polarization; transfer this information to the first interaction to simplify it. Then, transfer the momentum to the radiating quark and perform a splitting. <>= call test (interaction_1, "interaction_1", & "check interaction setup", & u, results) <>= public :: interaction_1 <>= subroutine interaction_1 (u) integer, intent(in) :: u type(interaction_t), target :: int, rad type(vector4_t), dimension(3) :: p type(quantum_numbers_mask_t), dimension(3) :: mask p(2) = vector4_moving (500._default, 500._default, 1) p(3) = vector4_moving (500._default,-500._default, 1) p(1) = p(2) + p(3) write (u, "(A)") "* Test output: interaction" write (u, "(A)") "* Purpose: check routines for interactions" write (u, "(A)") call int%basic_init (1, 0, 2, set_relations=.true., & store_values = .true. ) call int_set (int, 1, -1, 1, 1, & cmplx (0.3_default, 0.1_default, kind=default)) call int_set (int, 1, -1,-1, 1, & cmplx (0.5_default,-0.7_default, kind=default)) call int_set (int, 1, 1, 1, 1, & cmplx (0.1_default, 0._default, kind=default)) call int_set (int, -1, 1, -1, 2, & cmplx (0.4_default, -0.1_default, kind=default)) call int_set (int, 1, 1, 1, 2, & cmplx (0.2_default, 0._default, kind=default)) call int%freeze () call int%set_momenta (p) mask = quantum_numbers_mask (.false.,.false., [.true.,.true.,.true.]) call rad%basic_init (1, 0, 2, & mask=mask, set_relations=.true., store_values = .true.) call rad_set (1) call rad_set (2) call rad%set_source_link (1, int, 2) - call interaction_exchange_mask (rad) + call rad%exchange_mask () call rad%receive_momenta () p(1) = rad%get_momentum (1) p(2) = 0.4_default * p(1) p(3) = p(1) - p(2) call rad%set_momenta (p(2:3), outgoing=.true.) call int%freeze () call rad%freeze () call rad%set_matrix_element & (cmplx (0._default, 0._default, kind=default)) call int%basic_write (u) write (u, "(A)") call rad%basic_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call int%final () call rad%final () write (u, "(A)") write (u, "(A)") "* Test interaction_1: successful." contains subroutine int_set (int, h1, h2, hq, q, val) type(interaction_t), target, intent(inout) :: int integer, intent(in) :: h1, h2, hq, q type(flavor_t), dimension(3) :: flv type(color_t), dimension(3) :: col type(helicity_t), dimension(3) :: hel type(quantum_numbers_t), dimension(3) :: qn complex(default), intent(in) :: val call flv%init ([21, q, -q]) call col(2)%init_col_acl (5, 0) call col(3)%init_col_acl (0, 5) call hel%init ([h1, hq, -hq], [h2, hq, -hq]) call qn%init (flv, col, hel) call int%add_state (qn) call int%set_matrix_element (val) end subroutine int_set subroutine rad_set (q) integer, intent(in) :: q type(flavor_t), dimension(3) :: flv type(quantum_numbers_t), dimension(3) :: qn call flv%init ([ q, q, 21 ]) call qn%init (flv) call rad%add_state (qn) end subroutine rad_set end subroutine interaction_1 @ %def interaction_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Matrix element evaluation} The [[evaluator_t]] type is an extension of the [[interaction_t]] type. It represents either a density matrix as the square of a transition matrix element, or the product of two density matrices. Usually, some quantum numbers are summed over in the result. The [[interaction_t]] subobject represents a multi-particle interaction with incoming, virtual, and outgoing particles and the associated (not necessarily diagonal) density matrix of quantum state. When the evaluator is initialized, this interaction is constructed from the input interaction(s). In addition, the initialization process sets up a multiplication table. For each matrix element of the result, it states which matrix elements are to be taken from the input interaction(s), multiplied (optionally, with an additional weight factor) and summed over. Eventually, to a processes we associate a chain of evaluators which are to be evaluated sequentially. The physical event and its matrix element value(s) can be extracted from the last evaluator in such a chain. Evaluators are constructed only once (as long as this is possible) during an initialization step. Then, for each event, momenta are computed and transferred among evaluators using the links within the interaction subobject. The multiplication tables enable fast evaluation of the result without looking at quantum numbers anymore. <<[[evaluators.f90]]>>= <> module evaluators <> <> - use io_units - use format_defs, only: FMT_19 - use physics_defs, only: n_beams_rescaled - use diagnostics - use lorentz use flavors use colors use helicities use quantum_numbers use state_matrices use interactions <> <> <> <> <> + interface +<> + end interface + +end module evaluators +@ %def evaluators +@ +<<[[evaluators_sub.f90]]>>= +<> + +submodule (evaluators) evaluators_s + + use io_units + use format_defs, only: FMT_19 + use physics_defs, only: n_beams_rescaled + use diagnostics + use lorentz + + implicit none + contains <> -end module evaluators -@ %def evaluators +end submodule evaluators_s + +@ %def evaluators_s @ \subsection{Array of pairings} The evaluator contains an array of [[pairing_array]] objects. This makes up the multiplication table. Each pairing array contains two lists of matrix element indices and a list of numerical factors. The matrix element indices correspond to the input interactions. The corresponding matrix elements are to be multiplied and optionally multiplied by a factor. The results are summed over to yield one specific matrix element of the result evaluator. <>= type :: pairing_array_t integer, dimension(:), allocatable :: i1, i2 complex(default), dimension(:), allocatable :: factor end type pairing_array_t @ %def pairing_array_t +<>= + elemental module subroutine pairing_array_init (pa, n, has_i2, has_factor) + type(pairing_array_t), intent(out) :: pa + integer, intent(in) :: n + logical, intent(in) :: has_i2, has_factor + end subroutine pairing_array_init <>= - elemental subroutine pairing_array_init (pa, n, has_i2, has_factor) + elemental module subroutine pairing_array_init (pa, n, has_i2, has_factor) type(pairing_array_t), intent(out) :: pa integer, intent(in) :: n logical, intent(in) :: has_i2, has_factor allocate (pa%i1 (n)) if (has_i2) allocate (pa%i2 (n)) if (has_factor) allocate (pa%factor (n)) end subroutine pairing_array_init @ %def pairing_array_init @ <>= public :: pairing_array_write +<>= + module subroutine pairing_array_write (pa, unit) + type(pairing_array_t), intent(in) :: pa + integer, intent(in), optional :: unit + end subroutine pairing_array_write <>= - subroutine pairing_array_write (pa, unit) + module subroutine pairing_array_write (pa, unit) type(pairing_array_t), intent(in) :: pa integer, intent(in), optional :: unit integer :: i, u u = given_output_unit (unit); if (u < 0) return write (u, "(A)", advance = "no") "[" if (allocated (pa%i1)) then write (u, "(I0,A)", advance = "no") pa%i1, "," else write (u, "(A)", advance = "no") "x," end if if (allocated (pa%i2)) then write (u, "(I0,A)", advance = "no") pa%i1, "," else write (u, "(A)", advance = "no") "x," end if write (u, "(A)", advance = "no") "]" if (allocated (pa%factor)) then write (u, "(A,F5.4,A,F5.4,A)") ";(", & real(pa%factor), ",", aimag(pa%factor), ")]" else write (u, "(A)") "" end if end subroutine pairing_array_write @ %def pairing_array_write @ \subsection{The evaluator type} Possible variants of evaluators: <>= integer, parameter :: & EVAL_UNDEFINED = 0, & EVAL_PRODUCT = 1, & EVAL_SQUARED_FLOWS = 2, & EVAL_SQUARE_WITH_COLOR_FACTORS = 3, & EVAL_COLOR_CONTRACTION = 4, & EVAL_IDENTITY = 5, & EVAL_QN_SUM = 6 @ %def EVAL_PRODUCT EVAL_SQUARED_FLOWS EVAL_SQUARE_WITH_COLOR_FACTORS @ %def EVAL_COLOR_CONTRACTION EVAL_QN_SUM @ The evaluator type contains the result interaction and an array of pairing lists, one for each matrix element in the result interaction. <>= public :: evaluator_t <>= type, extends (interaction_t) :: evaluator_t private integer :: type = EVAL_UNDEFINED class(interaction_t), pointer :: int_in1 => null () class(interaction_t), pointer :: int_in2 => null () type(pairing_array_t), dimension(:), allocatable :: pairing_array contains <> end type evaluator_t @ %def evaluator_t @ Output. <>= procedure :: write => evaluator_write +<>= + module subroutine evaluator_write (eval, unit, & + verbose, show_momentum_sum, show_mass, show_state, show_table, & + col_verbose, testflag) + class(evaluator_t), intent(in) :: eval + integer, intent(in), optional :: unit + logical, intent(in), optional :: verbose, show_momentum_sum, show_mass + logical, intent(in), optional :: show_state, show_table, col_verbose + logical, intent(in), optional :: testflag + end subroutine evaluator_write <>= - subroutine evaluator_write (eval, unit, & + module subroutine evaluator_write (eval, unit, & verbose, show_momentum_sum, show_mass, show_state, show_table, & col_verbose, testflag) class(evaluator_t), intent(in) :: eval integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, show_momentum_sum, show_mass logical, intent(in), optional :: show_state, show_table, col_verbose logical, intent(in), optional :: testflag logical :: conjugate, square, show_tab integer :: u u = given_output_unit (unit); if (u < 0) return show_tab = .true.; if (present (show_table)) show_tab = .false. call eval%basic_write & (unit, verbose, show_momentum_sum, show_mass, & show_state, col_verbose, testflag) if (show_tab) then write (u, "(1x,A)") "Matrix-element multiplication" write (u, "(2x,A)", advance="no") "Input interaction 1:" if (associated (eval%int_in1)) then write (u, "(1x,I0)") eval%int_in1%get_tag () else write (u, "(A)") " [undefined]" end if write (u, "(2x,A)", advance="no") "Input interaction 2:" if (associated (eval%int_in2)) then write (u, "(1x,I0)") eval%int_in2%get_tag () else write (u, "(A)") " [undefined]" end if select case (eval%type) case (EVAL_SQUARED_FLOWS, EVAL_SQUARE_WITH_COLOR_FACTORS) conjugate = .true. square = .true. case (EVAL_IDENTITY) write (u, "(1X,A)") "Identity evaluator, pairing array unused" return case default conjugate = .false. square = .false. end select call eval%write_pairing_array (conjugate, square, u) end if end subroutine evaluator_write @ %def evaluator_write @ <>= procedure :: write_pairing_array => evaluator_write_pairing_array +<>= + module subroutine evaluator_write_pairing_array (eval, conjugate, square, unit) + class(evaluator_t), intent(in) :: eval + logical, intent(in) :: conjugate, square + integer, intent(in), optional :: unit + end subroutine evaluator_write_pairing_array <>= - subroutine evaluator_write_pairing_array (eval, conjugate, square, unit) + module subroutine evaluator_write_pairing_array (eval, conjugate, square, unit) class(evaluator_t), intent(in) :: eval logical, intent(in) :: conjugate, square integer, intent(in), optional :: unit integer :: u, i, j u = given_output_unit (unit); if (u < 0) return if (allocated (eval%pairing_array)) then do i = 1, size (eval%pairing_array) write (u, "(2x,A,I0,A)") "ME(", i, ") = " do j = 1, size (eval%pairing_array(i)%i1) write (u, "(4x,A)", advance="no") "+" if (allocated (eval%pairing_array(i)%i2)) then write (u, "(1x,A,I0,A)", advance="no") & "ME1(", eval%pairing_array(i)%i1(j), ")" if (conjugate) then write (u, "(A)", advance="no") "* x" else write (u, "(A)", advance="no") " x" end if write (u, "(1x,A,I0,A)", advance="no") & "ME2(", eval%pairing_array(i)%i2(j), ")" else if (square) then write (u, "(1x,A)", advance="no") "|" write (u, "(A,I0,A)", advance="no") & "ME1(", eval%pairing_array(i)%i1(j), ")" write (u, "(A)", advance="no") "|^2" else write (u, "(1x,A,I0,A)", advance="no") & "ME1(", eval%pairing_array(i)%i1(j), ")" end if if (allocated (eval%pairing_array(i)%factor)) then write (u, "(1x,A)", advance="no") "x" write (u, "(1x,'('," // FMT_19 // ",','," // FMT_19 // & ",')')") eval%pairing_array(i)%factor(j) else write (u, *) end if end do end do end if end subroutine evaluator_write_pairing_array @ %def evaluator_write_pairing_array @ Assignment: Deep copy of the interaction component. <>= public :: assignment(=) <>= interface assignment(=) module procedure evaluator_assign end interface +<>= + module subroutine evaluator_assign (eval_out, eval_in) + type(evaluator_t), intent(out) :: eval_out + type(evaluator_t), intent(in) :: eval_in + end subroutine evaluator_assign <>= - subroutine evaluator_assign (eval_out, eval_in) + module subroutine evaluator_assign (eval_out, eval_in) type(evaluator_t), intent(out) :: eval_out type(evaluator_t), intent(in) :: eval_in eval_out%type = eval_in%type eval_out%int_in1 => eval_in%int_in1 eval_out%int_in2 => eval_in%int_in2 eval_out%interaction_t = eval_in%interaction_t if (allocated (eval_in%pairing_array)) then allocate (eval_out%pairing_array (size (eval_in%pairing_array))) eval_out%pairing_array = eval_in%pairing_array end if end subroutine evaluator_assign @ %def evaluator_assign @ \subsection{Auxiliary structures for evaluator creation} Creating an evaluator that properly handles all quantum numbers requires some bookkeeping. In this section, we define several auxiliary types and methods that organize and simplify this task. More structures are defined within the specific initializers (as local types and internal subroutines). These types are currently implemented in a partial object-oriented way: We define some basic methods for initialization etc.\ here, but the evaluator routines below do access their internals as well. This simplifies some things such as index addressing using array slices, at the expense of losing some clarity. \subsubsection{Index mapping} Index mapping are abundant when constructing an evaluator. To have arrays of index mappings, we define this: <>= type :: index_map_t integer, dimension(:), allocatable :: entry end type index_map_t @ %def index_map_t +<>= + elemental module subroutine index_map_init (map, n) + type(index_map_t), intent(out) :: map + integer, intent(in) :: n + end subroutine index_map_init <>= - elemental subroutine index_map_init (map, n) + elemental module subroutine index_map_init (map, n) type(index_map_t), intent(out) :: map integer, intent(in) :: n allocate (map%entry (n)) map%entry = 0 end subroutine index_map_init @ %def index_map_init <>= function index_map_exists (map) result (flag) logical :: flag type(index_map_t), intent(in) :: map flag = allocated (map%entry) end function index_map_exists @ %def index_map_exists <>= interface size module procedure index_map_size end interface @ %def size +<>= + module function index_map_size (map) result (s) + integer :: s + type(index_map_t), intent(in) :: map + end function index_map_size <>= - function index_map_size (map) result (s) + module function index_map_size (map) result (s) integer :: s type(index_map_t), intent(in) :: map if (allocated (map%entry)) then s = size (map%entry) else s = 0 end if end function index_map_size @ %def index_map_size <>= interface assignment(=) module procedure index_map_assign_int module procedure index_map_assign_array end interface @ %def = +<>= + elemental module subroutine index_map_assign_int (map, ival) + type(index_map_t), intent(inout) :: map + integer, intent(in) :: ival + end subroutine index_map_assign_int + module subroutine index_map_assign_array (map, array) + type(index_map_t), intent(inout) :: map + integer, dimension(:), intent(in) :: array + end subroutine index_map_assign_array <>= - elemental subroutine index_map_assign_int (map, ival) + elemental module subroutine index_map_assign_int (map, ival) type(index_map_t), intent(inout) :: map integer, intent(in) :: ival map%entry = ival end subroutine index_map_assign_int - subroutine index_map_assign_array (map, array) + module subroutine index_map_assign_array (map, array) type(index_map_t), intent(inout) :: map integer, dimension(:), intent(in) :: array map%entry = array end subroutine index_map_assign_array @ %def index_map_assign_int index_map_assign_array +<>= + elemental module subroutine index_map_set_entry (map, i, ival) + type(index_map_t), intent(inout) :: map + integer, intent(in) :: i + integer, intent(in) :: ival + end subroutine index_map_set_entry <>= - elemental subroutine index_map_set_entry (map, i, ival) + elemental module subroutine index_map_set_entry (map, i, ival) type(index_map_t), intent(inout) :: map integer, intent(in) :: i integer, intent(in) :: ival map%entry(i) = ival end subroutine index_map_set_entry @ %def index_map_set_entry +<>= + elemental module function index_map_get_entry (map, i) result (ival) + integer :: ival + type(index_map_t), intent(in) :: map + integer, intent(in) :: i + end function index_map_get_entry <>= - elemental function index_map_get_entry (map, i) result (ival) + elemental module function index_map_get_entry (map, i) result (ival) integer :: ival type(index_map_t), intent(in) :: map integer, intent(in) :: i ival = map%entry(i) end function index_map_get_entry @ %def index_map_get_entry @ \subsubsection{Index mapping (two-dimensional)} This is a variant with a square matrix instead of an array. <>= type :: index_map2_t integer :: s = 0 integer, dimension(:,:), allocatable :: entry end type index_map2_t @ %def index_map2_t <>= elemental subroutine index_map2_init (map, n) type(index_map2_t), intent(out) :: map integer, intent(in) :: n map%s = n allocate (map%entry (n, n)) end subroutine index_map2_init @ %def index_map2_init <>= function index_map2_exists (map) result (flag) logical :: flag type(index_map2_t), intent(in) :: map flag = allocated (map%entry) end function index_map2_exists @ %def index_map2_exists <>= interface size module procedure index_map2_size end interface @ %def size +<>= + module function index_map2_size (map) result (s) + integer :: s + type(index_map2_t), intent(in) :: map + end function index_map2_size <>= - function index_map2_size (map) result (s) + module function index_map2_size (map) result (s) integer :: s type(index_map2_t), intent(in) :: map s = map%s end function index_map2_size @ %def index_map2_size <>= interface assignment(=) module procedure index_map2_assign_int end interface @ %def = +<>= + elemental module subroutine index_map2_assign_int (map, ival) + type(index_map2_t), intent(inout) :: map + integer, intent(in) :: ival + end subroutine index_map2_assign_int <>= - elemental subroutine index_map2_assign_int (map, ival) + elemental module subroutine index_map2_assign_int (map, ival) type(index_map2_t), intent(inout) :: map integer, intent(in) :: ival map%entry = ival end subroutine index_map2_assign_int @ %def index_map2_assign_int <>= elemental subroutine index_map2_set_entry (map, i, j, ival) type(index_map2_t), intent(inout) :: map integer, intent(in) :: i, j integer, intent(in) :: ival map%entry(i,j) = ival end subroutine index_map2_set_entry @ %def index_map2_set_entry <>= elemental function index_map2_get_entry (map, i, j) result (ival) integer :: ival type(index_map2_t), intent(in) :: map integer, intent(in) :: i, j ival = map%entry(i,j) end function index_map2_get_entry @ %def index_map2_get_entry @ \subsubsection{Auxiliary structures: particle mask} This is a simple container of a logical array. <>= type :: prt_mask_t logical, dimension(:), allocatable :: entry end type prt_mask_t @ %def prt_mask_t <>= subroutine prt_mask_init (mask, n) type(prt_mask_t), intent(out) :: mask integer, intent(in) :: n allocate (mask%entry (n)) end subroutine prt_mask_init @ %def prt_mask_init <>= interface size module procedure prt_mask_size end interface @ %def size +<>= + module function prt_mask_size (mask) result (s) + integer :: s + type(prt_mask_t), intent(in) :: mask + end function prt_mask_size <>= - function prt_mask_size (mask) result (s) + module function prt_mask_size (mask) result (s) integer :: s type(prt_mask_t), intent(in) :: mask s = size (mask%entry) end function prt_mask_size @ %def prt_mask_size @ \subsubsection{Quantum number containers} Trivial transparent containers: <>= type :: qn_list_t type(quantum_numbers_t), dimension(:,:), allocatable :: qn end type qn_list_t type :: qn_mask_array_t type(quantum_numbers_mask_t), dimension(:), allocatable :: mask end type qn_mask_array_t @ %def qn_list_t qn_mask_array_t @ \subsubsection{Auxiliary structures: connection entries} This type is used as intermediate storage when computing the product of two evaluators or the square of an evaluator. The quantum-number array [[qn]] corresponds to the particles common to both interactions, but irrelevant quantum numbers (color) masked out. The index arrays [[index_in]] determine the entries in the input interactions that contribute to this connection. [[n_index]] is the size of these arrays, and [[count]] is used while filling the entries. Finally, the quantum-number arrays [[qn_in_list]] are the actual entries in the input interaction that contribute. In the product case, they exclude the connected quantum numbers. Each evaluator has its own [[connection_table]] which contains an array of [[connection_entry]] objects, but also has stuff that specifically applies to the evaluator type. Hence, we do not generalize the [[connection_table_t]] type. The filling procedure [[connection_entry_add_state]] is specific to the various evaluator types. <>= type :: connection_entry_t type(quantum_numbers_t), dimension(:), allocatable :: qn_conn integer, dimension(:), allocatable :: n_index integer, dimension(:), allocatable :: count type(index_map_t), dimension(:), allocatable :: index_in type(qn_list_t), dimension(:), allocatable :: qn_in_list end type connection_entry_t @ %def connection_entry_t <>= subroutine connection_entry_init & (entry, n_count, n_map, qn_conn, count, n_rest) type(connection_entry_t), intent(out) :: entry integer, intent(in) :: n_count, n_map type(quantum_numbers_t), dimension(:), intent(in) :: qn_conn integer, dimension(n_count), intent(in) :: count integer, dimension(n_count), intent(in) :: n_rest integer :: i allocate (entry%qn_conn (size (qn_conn))) allocate (entry%n_index (n_count)) allocate (entry%count (n_count)) allocate (entry%index_in (n_map)) allocate (entry%qn_in_list (n_count)) entry%qn_conn = qn_conn entry%n_index = count entry%count = 0 if (size (entry%index_in) == size (count)) then call index_map_init (entry%index_in, count) else call index_map_init (entry%index_in, count(1)) end if do i = 1, n_count allocate (entry%qn_in_list(i)%qn (n_rest(i), count(i))) end do end subroutine connection_entry_init @ %def connection_entry_init <>= subroutine connection_entry_write (entry, unit) type(connection_entry_t), intent(in) :: entry integer, intent(in), optional :: unit integer :: i, j integer :: u u = given_output_unit (unit) call quantum_numbers_write (entry%qn_conn, unit) write (u, *) do i = 1, size (entry%n_index) write (u, *) "Input interaction", i do j = 1, entry%n_index(i) if (size (entry%n_index) == size (entry%index_in)) then write (u, "(2x,I0,4x,I0,2x)", advance = "no") & j, index_map_get_entry (entry%index_in(i), j) else write (u, "(2x,I0,4x,I0,2x,I0,2x)", advance = "no") & j, index_map_get_entry (entry%index_in(1), j), & index_map_get_entry (entry%index_in(2), j) end if call quantum_numbers_write (entry%qn_in_list(i)%qn(:,j), unit) write (u, *) end do end do end subroutine connection_entry_write @ %def connection_entry_write +@ These are the different connection tables for the three different +cases of evaluators for matrix elements, squared diagonal and +non-diagonal matrix elements, respectively. +<>= + type :: connection_table_t + integer :: n_conn = 0 + integer, dimension(2) :: n_rest = 0 + integer :: n_tot = 0 + integer :: n_me_conn = 0 + type(state_matrix_t) :: state + type(index_map_t), dimension(:), allocatable :: index_conn + type(connection_entry_t), dimension(:), allocatable :: entry + type(index_map_t) :: index_result + end type connection_table_t + + type :: connection_table_diag_t + integer :: n_tot = 0 + integer :: n_me_conn = 0 + type(state_matrix_t) :: state + type(index_map_t) :: index_conn + type(connection_entry_t), dimension(:), allocatable :: entry + type(index_map_t) :: index_result + end type connection_table_diag_t + + type :: connection_table_nondiag_t + integer :: n_tot = 0 + integer :: n_me_conn = 0 + type(state_matrix_t) :: state + type(index_map2_t) :: index_conn + type(connection_entry_t), dimension(:), allocatable :: entry + type(index_map_t) :: index_result + end type connection_table_nondiag_t + +@ %def connection_table_t +@ %def connection_table_diag_t @ \subsubsection{Color handling} For managing color-factor computation, we introduce this local type. The [[index]] is the index in the color table that corresponds to a given matrix element index in the input interaction. The [[col]] array stores the color assignments in rows. The [[factor]] array associates a complex number with each pair of arrays in the color table. The [[factor_is_known]] array reveals whether a given factor is known already or still has to be computed. <>= type :: color_table_t integer, dimension(:), allocatable :: index type(color_t), dimension(:,:), allocatable :: col logical, dimension(:,:), allocatable :: factor_is_known complex(default), dimension(:,:), allocatable :: factor end type color_table_t @ %def color_table_t @ This is the initializer. We extract the color states from the given state matrices, establish index mappings between the two states (implemented by the array [[me_index]]), make an array of color states, and initialize the color-factor table. The latter is two-dimensional (includes interference) and not yet filled. <>= subroutine color_table_init (color_table, state, n_tot) type(color_table_t), intent(out) :: color_table type(state_matrix_t), intent(in) :: state integer, intent(in) :: n_tot type(state_iterator_t) :: it type(quantum_numbers_t), dimension(:), allocatable :: qn type(state_matrix_t) :: state_col integer :: index, n_col_state allocate (color_table%index (state%get_n_matrix_elements ())) color_table%index = 0 allocate (qn (n_tot)) call state_col%init () call it%init (state) do while (it%is_valid ()) index = it%get_me_index () call qn%init (col = it%get_color ()) call state_col%add_state (qn, me_index = color_table%index(index)) call it%advance () end do n_col_state = state_col%get_n_matrix_elements () allocate (color_table%col (n_tot, n_col_state)) call it%init (state_col) do while (it%is_valid ()) index = it%get_me_index () color_table%col(:,index) = it%get_color () call it%advance () end do call state_col%final () allocate (color_table%factor_is_known (n_col_state, n_col_state)) allocate (color_table%factor (n_col_state, n_col_state)) color_table%factor_is_known = .false. end subroutine color_table_init @ %def color_table_init @ Output (debugging use): <>= subroutine color_table_write (color_table, unit) type(color_table_t), intent(in) :: color_table integer, intent(in), optional :: unit integer :: i, j integer :: u u = given_output_unit (unit) write (u, *) "Color table:" if (allocated (color_table%index)) then write (u, *) " Index mapping state => color table:" do i = 1, size (color_table%index) write (u, "(3x,I0,2x,I0,2x)") i, color_table%index(i) end do write (u, *) " Color table:" do i = 1, size (color_table%col, 2) write (u, "(3x,I0,2x)", advance = "no") i call color_write (color_table%col(:,i), unit) write (u, *) end do write (u, *) " Defined color factors:" do i = 1, size (color_table%factor, 1) do j = 1, size (color_table%factor, 2) if (color_table%factor_is_known(i,j)) then write (u, *) i, j, color_table%factor(i,j) end if end do end do end if end subroutine color_table_write @ %def color_table_write @ This subroutine sets color factors, based on information from the hard matrix element: the list of pairs of color-flow indices (in the basis of the matrix element code), the list of corresponding factors, and the list of mappings from the matrix element index in the input interaction to the color-flow index in the hard matrix element object. We first determine the mapping of color-flow indices from the hard matrix element code to the current color table. The mapping could be nontrivial because the latter is derived from iterating over a state matrix, which may return states in non-canonical order. The translation table can be determined because we have, for the complete state matrix, both the mapping to the hard interaction (the input [[col_index_hi]]) and the mapping to the current color table (the component [[color_table%index]]). Once this mapping is known, we scan the list of index pairs [[color_flow_index]] and translate them to valid color-table index pairs. For this pair, the color factor is set using the corresponding entry in the list [[col_factor]]. <>= subroutine color_table_set_color_factors (color_table, & col_flow_index, col_factor, col_index_hi) type(color_table_t), intent(inout) :: color_table integer, dimension(:,:), intent(in) :: col_flow_index complex(default), dimension(:), intent(in) :: col_factor integer, dimension(:), intent(in) :: col_index_hi integer, dimension(:), allocatable :: hi_to_ct integer :: n_cflow integer :: hi_index, me_index, ct_index, cf_index integer, dimension(2) :: hi_index_pair, ct_index_pair n_cflow = size (col_index_hi) if (size (color_table%index) /= n_cflow) & call msg_bug ("Mismatch between hard matrix element and color table") allocate (hi_to_ct (n_cflow)) do me_index = 1, size (color_table%index) ct_index = color_table%index(me_index) hi_index = col_index_hi(me_index) hi_to_ct(hi_index) = ct_index end do do cf_index = 1, size (col_flow_index, 2) hi_index_pair = col_flow_index(:,cf_index) ct_index_pair = hi_to_ct(hi_index_pair) color_table%factor(ct_index_pair(1), ct_index_pair(2)) = & col_factor(cf_index) color_table%factor_is_known(ct_index_pair(1), ct_index_pair(2)) = .true. end do end subroutine color_table_set_color_factors @ %def color_table_set_color_factors @ This function returns a color factor, given two indices which point to the matrix elements of the initial state matrix. Internally, we can map them to the corresponding indices in the color table. As a side effect, we store the color factor in the color table for later lookup. (I.e., this function is impure.) <>= function color_table_get_color_factor (color_table, index1, index2, nc) & result (factor) real(default) :: factor type(color_table_t), intent(inout) :: color_table integer, intent(in) :: index1, index2 integer, intent(in), optional :: nc integer :: i1, i2 i1 = color_table%index(index1) i2 = color_table%index(index2) if (color_table%factor_is_known(i1,i2)) then factor = real(color_table%factor(i1,i2), kind=default) else factor = compute_color_factor & (color_table%col(:,i1), color_table%col(:,i2), nc) color_table%factor(i1,i2) = factor color_table%factor_is_known(i1,i2) = .true. end if end function color_table_get_color_factor @ %def color_table_get_color_factor @ \subsection{Creating an evaluator: Matrix multiplication} The evaluator for matrix multiplication is the most complicated variant. The initializer takes two input interactions and constructs the result evaluator, which consists of the interaction and the multiplication table for the product (or convolution) of the two. Normally, the input interactions are connected by one or more common particles (e.g., decay, structure function convolution). In the result interaction, quantum numbers of the connections can be summed over. This is determined by the [[qn_mask_conn]] argument. The [[qn_mask_rest]] argument is its analog for the other particles within the result interaction. (E.g., for the trace of the state matrix, all quantum numbers are summed over.) Finally, the [[connections_are_resonant]] argument tells whether the connecting particles should be marked as resonant in the final event record. If true, this also implies that the second interaction is not the hard process, so any corresponding tags should be removed from the outgoing particles. This applies to decays. The algorithm consists of the following steps: \begin{enumerate} \item [[find_connections]]: Find the particles which are connected, i.e., common to both input interactions. Either they are directly linked, or both are linked to a common source. \item [[compute_index_bounds_and_mappings]]: Compute the mappings of particle indices from the input interactions to the result interaction. There is a separate mapping for the connected particles. \item [[accumulate_connected_states]]: Create an auxiliary state matrix which lists the possible quantum numbers for the connected particles. When building this matrix, count the number of times each assignment is contained in any of the input states and, for each of the input states, record the index of the matrix element within the new state matrix. For the connected particles, reassign color indices such that no color state is present twice in different color-index assignment. Note that helicity assignments of the connected state can be (and will be) off-diagonal, so no spin correlations are lost in decays. Do this for both input interactions. \item [[allocate_connection_entries]]: Allocate a table of connections. Each table row corresponds to one state in the auxiliary matrix, and to multiple states of the input interactions. It collects all states of the unconnected particles in the two input interactions that are associated with the particular state (quantum-number assignment) of the connected particles. \item [[fill_connection_table]]: Fill the table of connections by scanning both input interactions. When copying states, reassign color indices for the unconnected particles such that they match between all involved particle sets (interaction 1, interaction 2, and connected particles). \item [[make_product_interaction]]: Scan the table of connections we have just built. For each entry, construct all possible pairs of states of the unconnected particles and combine them with the specific connected-particle state. This is a possible quantum-number assignment of the result interaction. Now mask all quantum numbers that should be summed over, and append this to the result state matrix. Record the matrix element index of the result. We now have the result interaction. \item [[make_pairing_array]]: First allocate the pairing array with the number of entries of the result interaction. Then scan the table of connections again. For each entry, record the indices of the matrix elements which have to be multiplied and summed over in order to compute this particular matrix element. This makes up the multiplication table. \item [[record_links]]: Transfer all source pointers from the input interactions to the result interaction. Do the same for the internal parent-child relations and resonance assignments. For the connected particles, make up appropriate additional parent-child relations. This allows for fetching momenta from other interactions when a new event is filled, and to reconstruct the event history when the event is analyzed. \end{enumerate} After all this is done, for each event, we just have to evaluate the pairing arrays (multiplication tables) in order to compute the result matrix elements in their proper positions. The quantum-number assignments remain fixed from now on. <>= procedure :: init_product => evaluator_init_product +<>= + module subroutine evaluator_init_product & + (eval, int_in1, int_in2, qn_mask_conn, qn_filter_conn, qn_mask_rest, & + connections_are_resonant, ignore_sub_for_qn) + class(evaluator_t), intent(out), target :: eval + class(interaction_t), intent(in), target :: int_in1, int_in2 + type(quantum_numbers_mask_t), intent(in) :: qn_mask_conn + type(quantum_numbers_t), intent(in), optional :: qn_filter_conn + type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_rest + logical, intent(in), optional :: connections_are_resonant + logical, intent(in), optional :: ignore_sub_for_qn + end subroutine evaluator_init_product <>= - subroutine evaluator_init_product & + module subroutine evaluator_init_product & (eval, int_in1, int_in2, qn_mask_conn, qn_filter_conn, qn_mask_rest, & connections_are_resonant, ignore_sub_for_qn) class(evaluator_t), intent(out), target :: eval class(interaction_t), intent(in), target :: int_in1, int_in2 type(quantum_numbers_mask_t), intent(in) :: qn_mask_conn type(quantum_numbers_t), intent(in), optional :: qn_filter_conn type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_rest logical, intent(in), optional :: connections_are_resonant logical, intent(in), optional :: ignore_sub_for_qn type(qn_mask_array_t), dimension(2) :: qn_mask_in type(state_matrix_t), pointer :: state_in1, state_in2 - - type :: connection_table_t - integer :: n_conn = 0 - integer, dimension(2) :: n_rest = 0 - integer :: n_tot = 0 - integer :: n_me_conn = 0 - type(state_matrix_t) :: state - type(index_map_t), dimension(:), allocatable :: index_conn - type(connection_entry_t), dimension(:), allocatable :: entry - type(index_map_t) :: index_result - end type connection_table_t type(connection_table_t) :: connection_table integer :: n_in, n_vir, n_out, n_tot integer, dimension(2) :: n_rest integer :: n_conn integer, dimension(:,:), allocatable :: connection_index type(index_map_t), dimension(2) :: prt_map_in type(index_map_t) :: prt_map_conn type(prt_mask_t), dimension(2) :: prt_is_connected type(quantum_numbers_mask_t), dimension(:), allocatable :: & qn_mask_conn_initial, int_in1_mask, int_in2_mask integer :: i eval%type = EVAL_PRODUCT eval%int_in1 => int_in1 eval%int_in2 => int_in2 state_in1 => int_in1%get_state_matrix_ptr () state_in2 => int_in2%get_state_matrix_ptr () call find_connections (int_in1, int_in2, n_conn, connection_index) if (n_conn == 0) then call msg_message ("First interaction:") call int_in1%basic_write (col_verbose=.true.) call msg_message ("Second interaction:") call int_in2%basic_write (col_verbose=.true.) call msg_fatal ("Evaluator product: no connections found between factors") end if call compute_index_bounds_and_mappings & (int_in1, int_in2, n_conn, & n_in, n_vir, n_out, n_tot, & n_rest, prt_map_in, prt_map_conn) call prt_mask_init (prt_is_connected(1), int_in1%get_n_tot ()) call prt_mask_init (prt_is_connected(2), int_in2%get_n_tot ()) do i = 1, 2 prt_is_connected(i)%entry = .true. prt_is_connected(i)%entry(connection_index(:,i)) = .false. end do allocate (qn_mask_conn_initial (n_conn), & int_in1_mask (n_conn), int_in2_mask (n_conn)) int_in1_mask = int_in1%get_mask (connection_index(:,1)) int_in2_mask = int_in2%get_mask (connection_index(:,2)) do i = 1, n_conn qn_mask_conn_initial(i) = int_in1_mask(i) .or. int_in2_mask(i) end do allocate (qn_mask_in(1)%mask (int_in1%get_n_tot ())) allocate (qn_mask_in(2)%mask (int_in2%get_n_tot ())) qn_mask_in(1)%mask = int_in1%get_mask () qn_mask_in(2)%mask = int_in2%get_mask () call connection_table_init (connection_table, & state_in1, state_in2, & qn_mask_conn_initial, & n_conn, connection_index, n_rest, & qn_filter_conn, ignore_sub_for_qn) call connection_table_fill (connection_table, & state_in1, state_in2, & connection_index, prt_is_connected) call make_product_interaction (eval%interaction_t, & n_in, n_vir, n_out, & connection_table, & prt_map_in, prt_is_connected, & qn_mask_in, qn_mask_conn_initial, & qn_mask_conn, qn_filter_conn, qn_mask_rest) call make_pairing_array (eval%pairing_array, & eval%get_n_matrix_elements (), & connection_table) call record_links (eval%interaction_t, & int_in1, int_in2, connection_index, prt_map_in, prt_map_conn, & prt_is_connected, connections_are_resonant) call connection_table_final (connection_table) if (eval%get_n_matrix_elements () == 0) then print *, "Evaluator product" print *, "First interaction" call int_in1%basic_write (col_verbose=.true.) print * print *, "Second interaction" call int_in2%basic_write (col_verbose=.true.) print * call msg_fatal ("Product of density matrices is empty", & [var_str (" --------------------------------------------"), & var_str ("This happens when two density matrices are convoluted "), & var_str ("but the processes they belong to (e.g., production "), & var_str ("and decay) do not match. This could happen if the "), & var_str ("beam specification does not match the hard "), & var_str ("process. Or it may indicate a WHIZARD bug.")]) end if contains subroutine compute_index_bounds_and_mappings & (int1, int2, n_conn, & n_in, n_vir, n_out, n_tot, & n_rest, prt_map_in, prt_map_conn) class(interaction_t), intent(in) :: int1, int2 integer, intent(in) :: n_conn integer, intent(out) :: n_in, n_vir, n_out, n_tot integer, dimension(2), intent(out) :: n_rest type(index_map_t), dimension(2), intent(out) :: prt_map_in type(index_map_t), intent(out) :: prt_map_conn integer, dimension(:), allocatable :: index integer :: n_in1, n_vir1, n_out1 integer :: n_in2, n_vir2, n_out2 integer :: k n_in1 = int1%get_n_in () n_vir1 = int1%get_n_vir () n_out1 = int1%get_n_out () - n_conn n_rest(1) = n_in1 + n_vir1 + n_out1 n_in2 = int2%get_n_in () - n_conn n_vir2 = int2%get_n_vir () n_out2 = int2%get_n_out () n_rest(2) = n_in2 + n_vir2 + n_out2 n_in = n_in1 + n_in2 n_vir = n_vir1 + n_vir2 + n_conn n_out = n_out1 + n_out2 n_tot = n_in + n_vir + n_out call index_map_init (prt_map_in, n_rest) call index_map_init (prt_map_conn, n_conn) allocate (index (n_tot)) index = [ (i, i = 1, n_tot) ] prt_map_in(1)%entry(1 : n_in1) = index( 1 : n_in1) k = n_in1 prt_map_in(2)%entry(1 : n_in2) = index(k + 1 : k + n_in2) k = k + n_in2 prt_map_in(1)%entry(n_in1 + 1 : n_in1 + n_vir1) = index(k + 1 : k + n_vir1) k = k + n_vir1 prt_map_in(2)%entry(n_in2 + 1 : n_in2 + n_vir2) = index(k + 1 : k + n_vir2) k = k + n_vir2 prt_map_conn%entry = index(k + 1 : k + n_conn) k = k + n_conn prt_map_in(1)%entry(n_in1 + n_vir1 + 1 : n_rest(1)) = index(k + 1 : k + n_out1) k = k + n_out1 prt_map_in(2)%entry(n_in2 + n_vir2 + 1 : n_rest(2)) = index(k + 1 : k + n_out2) end subroutine compute_index_bounds_and_mappings subroutine connection_table_init & (connection_table, state_in1, state_in2, qn_mask_conn, & n_conn, connection_index, n_rest, & qn_filter_conn, ignore_sub_for_qn_in) type(connection_table_t), intent(out) :: connection_table type(state_matrix_t), intent(in), target :: state_in1, state_in2 type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_conn integer, intent(in) :: n_conn integer, dimension(:,:), intent(in) :: connection_index integer, dimension(2), intent(in) :: n_rest type(quantum_numbers_t), intent(in), optional :: qn_filter_conn logical, intent(in), optional :: ignore_sub_for_qn_in integer, dimension(2) :: n_me_in type(state_iterator_t) :: it type(quantum_numbers_t), dimension(n_conn) :: qn integer :: i, me_index_in, me_index_conn, n_me_conn integer, dimension(2) :: me_count logical :: ignore_sub_for_qn, has_sub_qn integer :: i_beam_sub connection_table%n_conn = n_conn connection_table%n_rest = n_rest n_me_in(1) = state_in1%get_n_matrix_elements () n_me_in(2) = state_in2%get_n_matrix_elements () allocate (connection_table%index_conn (2)) call index_map_init (connection_table%index_conn, n_me_in) - connection_table%index_conn = 0 call connection_table%state%init (n_counters = 2) do i = 1, 2 select case (i) case (1); call it%init (state_in1) case (2); call it%init (state_in2) end select do while (it%is_valid ()) qn = it%get_quantum_numbers (connection_index(:,i)) call qn%undefine (qn_mask_conn) if (present (qn_filter_conn)) then if (.not. all (qn .match. qn_filter_conn)) then call it%advance (); cycle end if end if call quantum_numbers_canonicalize_color (qn) me_index_in = it%get_me_index () ignore_sub_for_qn = .false.; if (present (ignore_sub_for_qn_in)) ignore_sub_for_qn = ignore_sub_for_qn_in has_sub_qn = .false. do i_beam_sub = 1, n_beams_rescaled has_sub_qn = has_sub_qn .or. any (qn%get_sub () == i_beam_sub) end do call connection_table%state%add_state (qn, & counter_index = i, & ignore_sub_for_qn = .not. (ignore_sub_for_qn .and. has_sub_qn), & me_index = me_index_conn) call index_map_set_entry (connection_table%index_conn(i), & me_index_in, me_index_conn) call it%advance () end do end do n_me_conn = connection_table%state%get_n_matrix_elements () connection_table%n_me_conn = n_me_conn allocate (connection_table%entry (n_me_conn)) call it%init (connection_table%state) do while (it%is_valid ()) i = it%get_me_index () me_count = it%get_me_count () call connection_entry_init (connection_table%entry(i), 2, 2, & it%get_quantum_numbers (), me_count, n_rest) call it%advance () end do end subroutine connection_table_init subroutine connection_table_final (connection_table) type(connection_table_t), intent(inout) :: connection_table call connection_table%state%final () end subroutine connection_table_final subroutine connection_table_write (connection_table, unit) type(connection_table_t), intent(in) :: connection_table integer, intent(in), optional :: unit integer :: i, j integer :: u u = given_output_unit (unit) write (u, *) "Connection table:" call connection_table%state%write (unit) if (allocated (connection_table%index_conn)) then write (u, *) " Index mapping input => connection table:" do i = 1, size (connection_table%index_conn) write (u, *) " Input state", i do j = 1, size (connection_table%index_conn(i)) write (u, *) j, & index_map_get_entry (connection_table%index_conn(i), j) end do end do end if if (allocated (connection_table%entry)) then write (u, *) " Connection table contents:" do i = 1, size (connection_table%entry) call connection_entry_write (connection_table%entry(i), unit) end do end if if (index_map_exists (connection_table%index_result)) then write (u, *) " Index mapping connection table => output:" do i = 1, size (connection_table%index_result) write (u, *) i, & index_map_get_entry (connection_table%index_result, i) end do end if end subroutine connection_table_write subroutine connection_table_fill & (connection_table, state_in1, state_in2, & connection_index, prt_is_connected) type(connection_table_t), intent(inout) :: connection_table type(state_matrix_t), intent(in), target :: state_in1, state_in2 integer, dimension(:,:), intent(in) :: connection_index type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected type(state_iterator_t) :: it integer :: index_in, index_conn integer :: color_offset integer :: n_result_entries integer :: i, k color_offset = connection_table%state%get_max_color_value () do i = 1, 2 select case (i) case (1); call it%init (state_in1) case (2); call it%init (state_in2) end select do while (it%is_valid ()) index_in = it%get_me_index () index_conn = index_map_get_entry & (connection_table%index_conn(i), index_in) if (index_conn /= 0) then call connection_entry_add_state & (connection_table%entry(index_conn), i, & index_in, it%get_quantum_numbers (), & connection_index(:,i), prt_is_connected(i), & color_offset) end if call it%advance () end do color_offset = color_offset + state_in1%get_max_color_value () end do n_result_entries = 0 do k = 1, size (connection_table%entry) n_result_entries = & n_result_entries + product (connection_table%entry(k)%n_index) end do call index_map_init (connection_table%index_result, n_result_entries) end subroutine connection_table_fill subroutine connection_entry_add_state & (entry, i, index_in, qn_in, connection_index, prt_is_connected, & color_offset) type(connection_entry_t), intent(inout) :: entry integer, intent(in) :: i integer, intent(in) :: index_in type(quantum_numbers_t), dimension(:), intent(in) :: qn_in integer, dimension(:), intent(in) :: connection_index type(prt_mask_t), intent(in) :: prt_is_connected integer, intent(in) :: color_offset integer :: c integer, dimension(:,:), allocatable :: color_map entry%count(i) = entry%count(i) + 1 c = entry%count(i) call make_color_map (color_map, & qn_in(connection_index), entry%qn_conn) call index_map_set_entry (entry%index_in(i), c, index_in) entry%qn_in_list(i)%qn(:,c) = pack (qn_in, prt_is_connected%entry) call quantum_numbers_translate_color & (entry%qn_in_list(i)%qn(:,c), color_map, color_offset) end subroutine connection_entry_add_state subroutine make_product_interaction (int, & n_in, n_vir, n_out, & connection_table, & prt_map_in, prt_is_connected, & qn_mask_in, qn_mask_conn_initial, & qn_mask_conn, qn_filter_conn, qn_mask_rest) type(interaction_t), intent(out), target :: int integer, intent(in) :: n_in, n_vir, n_out type(connection_table_t), intent(inout), target :: connection_table type(index_map_t), dimension(2), intent(in) :: prt_map_in type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected type(qn_mask_array_t), dimension(2), intent(in) :: qn_mask_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: & qn_mask_conn_initial type(quantum_numbers_mask_t), intent(in) :: qn_mask_conn type(quantum_numbers_t), intent(in), optional :: qn_filter_conn type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_rest type(index_map_t), dimension(2) :: prt_index_in type(index_map_t) :: prt_index_conn integer :: n_tot, n_conn integer, dimension(2) :: n_rest integer :: i, j, k, m type(quantum_numbers_t), dimension(:), allocatable :: qn type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask type(connection_entry_t), pointer :: entry integer :: result_index n_conn = connection_table%n_conn n_rest = connection_table%n_rest n_tot = sum (n_rest) + n_conn allocate (qn (n_tot), qn_mask (n_tot)) do i = 1, 2 call index_map_init (prt_index_in(i), n_rest(i)) - prt_index_in(i) = & + prt_index_in(i)%entry = & prt_map_in(i)%entry ([ (j, j = 1, n_rest(i)) ]) end do call index_map_init (prt_index_conn, n_conn) - prt_index_conn = prt_map_conn%entry ([ (j, j = 1, n_conn) ]) + prt_index_conn%entry = prt_map_conn%entry ([ (j, j = 1, n_conn) ]) do i = 1, 2 if (present (qn_mask_rest)) then qn_mask(prt_index_in(i)%entry) = & pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry) & .or. qn_mask_rest else qn_mask(prt_index_in(i)%entry) = & pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry) end if end do qn_mask(prt_index_conn%entry) = qn_mask_conn_initial .or. qn_mask_conn call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask = qn_mask) m = 1 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) qn(prt_index_conn%entry) = & quantum_numbers_undefined (entry%qn_conn, qn_mask_conn) if (present (qn_filter_conn)) then if (.not. all (qn(prt_index_conn%entry) .match. qn_filter_conn)) & cycle end if do j = 1, entry%n_index(1) qn(prt_index_in(1)%entry) = entry%qn_in_list(1)%qn(:,j) do k = 1, entry%n_index(2) qn(prt_index_in(2)%entry) = entry%qn_in_list(2)%qn(:,k) call int%add_state (qn, me_index = result_index) call index_map_set_entry & (connection_table%index_result, m, result_index) m = m + 1 end do end do end do call int%freeze () end subroutine make_product_interaction subroutine make_pairing_array (pa, n_matrix_elements, connection_table) type(pairing_array_t), dimension(:), intent(out), allocatable :: pa integer, intent(in) :: n_matrix_elements type(connection_table_t), intent(in), target :: connection_table type(connection_entry_t), pointer :: entry integer, dimension(:), allocatable :: n_entries integer :: i, j, k, m, r allocate (pa (n_matrix_elements)) allocate (n_entries (n_matrix_elements)) n_entries = 0 do m = 1, size (connection_table%index_result) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 end do call pairing_array_init & (pa, n_entries, has_i2=.true., has_factor=.false.) m = 1 n_entries = 0 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) do j = 1, entry%n_index(1) do k = 1, entry%n_index(2) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 pa(r)%i1(n_entries(r)) = & index_map_get_entry (entry%index_in(1), j) pa(r)%i2(n_entries(r)) = & index_map_get_entry (entry%index_in(2), k) m = m + 1 end do end do end do end subroutine make_pairing_array subroutine record_links (int, & int_in1, int_in2, connection_index, prt_map_in, prt_map_conn, & prt_is_connected, connections_are_resonant) class(interaction_t), intent(inout) :: int class(interaction_t), intent(in), target :: int_in1, int_in2 integer, dimension(:,:), intent(in) :: connection_index type(index_map_t), dimension(2), intent(in) :: prt_map_in type(index_map_t), intent(in) :: prt_map_conn type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected logical, intent(in), optional :: connections_are_resonant type(index_map_t), dimension(2) :: prt_map_all integer :: i, j, k, ival call index_map_init (prt_map_all(1), size (prt_is_connected(1))) k = 0 j = 0 do i = 1, size (prt_is_connected(1)) if (prt_is_connected(1)%entry(i)) then j = j + 1 ival = index_map_get_entry (prt_map_in(1), j) call index_map_set_entry (prt_map_all(1), i, ival) else k = k + 1 ival = index_map_get_entry (prt_map_conn, k) call index_map_set_entry (prt_map_all(1), i, ival) end if call int%set_source_link (ival, int_in1, i) end do call int_in1%transfer_relations (int, prt_map_all(1)%entry) call index_map_init (prt_map_all(2), size (prt_is_connected(2))) j = 0 do i = 1, size (prt_is_connected(2)) if (prt_is_connected(2)%entry(i)) then j = j + 1 ival = index_map_get_entry (prt_map_in(2), j) call index_map_set_entry (prt_map_all(2), i, ival) call int%set_source_link (ival, int_in2, i) else call index_map_set_entry (prt_map_all(2), i, 0) end if end do call int_in2%transfer_relations (int, prt_map_all(2)%entry) call int%relate_connections & (int_in2, connection_index(:,2), prt_map_all(2)%entry, & prt_map_conn%entry, connections_are_resonant) end subroutine record_links end subroutine evaluator_init_product @ %def evaluator_init_product @ \subsection{Creating an evaluator: square} The generic initializer for an evaluator that squares a matrix element. Depending on the provided mask, we select the appropriate specific initializer for either diagonal or non-diagonal helicity density matrices. <>= procedure :: init_square => evaluator_init_square +<>= + module subroutine evaluator_init_square (eval, int_in, qn_mask, & + col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) + class(evaluator_t), intent(out), target :: eval + class(interaction_t), intent(in), target :: int_in + type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask + integer, dimension(:,:), intent(in), optional :: col_flow_index + complex(default), dimension(:), intent(in), optional :: col_factor + integer, dimension(:), intent(in), optional :: col_index_hi + logical, intent(in), optional :: expand_color_flows + integer, intent(in), optional :: nc + end subroutine evaluator_init_square <>= - subroutine evaluator_init_square (eval, int_in, qn_mask, & + module subroutine evaluator_init_square (eval, int_in, qn_mask, & col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) class(evaluator_t), intent(out), target :: eval class(interaction_t), intent(in), target :: int_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask integer, dimension(:,:), intent(in), optional :: col_flow_index complex(default), dimension(:), intent(in), optional :: col_factor integer, dimension(:), intent(in), optional :: col_index_hi logical, intent(in), optional :: expand_color_flows integer, intent(in), optional :: nc if (all (qn_mask%diagonal_helicity ())) then call eval%init_square_diag (int_in, qn_mask, & col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) else call eval%init_square_nondiag (int_in, qn_mask, & col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) end if end subroutine evaluator_init_square @ %def evaluator_init_square @ \subsubsection{Color-summed squared matrix (diagonal helicities)} The initializer for an evaluator that squares a matrix element, including color factors. The mask must be such that off-diagonal matrix elements are excluded. If [[color_flows]] is set, the evaluator keeps color-flow entries separate and drops all interfering color structures. The color factors are set to unity in this case. There is only one input interaction. The quantum-number mask is an array, one entry for each particle, so they can be treated individually. For academic purposes, we allow for the number of colors being different from three (but 3 is the default). The algorithm is analogous to multiplication, with a few notable differences: \begin{enumerate} \item The connected particles are known, the correspondence is one-to-one. All particles are connected, and the mapping of indices is trivial, which simplifies the following steps. \item [[accumulate_connected_states]]: The matrix of connected states encompasses all particles, but color indices are removed. However, ghost states are still kept separate from physical color states. No color-index reassignment is necessary. \item The table of connections contains single index and quantum-number arrays instead of pairs of them. They are paired with themselves in all possible ways. \item [[make_squared_interaction]]: Now apply the predefined quantum-numbers mask, which usually collects all color states (physical and ghosts), and possibly a helicity sum. \item [[make_pairing_array]]: For each pair of input states, compute the color factor (including a potential ghost-parity sign) and store this in the pairing array together with the matrix-element indices for multiplication. \item [[record_links]]: This is again trivial due to the one-to-one correspondence. \end{enumerate} <>= procedure :: init_square_diag => evaluator_init_square_diag +<>= + module subroutine evaluator_init_square_diag (eval, int_in, qn_mask, & + col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) + class(evaluator_t), intent(out), target :: eval + class(interaction_t), intent(in), target :: int_in + type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask + integer, dimension(:,:), intent(in), optional :: col_flow_index + complex(default), dimension(:), intent(in), optional :: col_factor + integer, dimension(:), intent(in), optional :: col_index_hi + logical, intent(in), optional :: expand_color_flows + integer, intent(in), optional :: nc + end subroutine evaluator_init_square_diag <>= - subroutine evaluator_init_square_diag (eval, int_in, qn_mask, & + module subroutine evaluator_init_square_diag (eval, int_in, qn_mask, & col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) class(evaluator_t), intent(out), target :: eval class(interaction_t), intent(in), target :: int_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask integer, dimension(:,:), intent(in), optional :: col_flow_index complex(default), dimension(:), intent(in), optional :: col_factor integer, dimension(:), intent(in), optional :: col_index_hi logical, intent(in), optional :: expand_color_flows integer, intent(in), optional :: nc integer :: n_in, n_vir, n_out, n_tot type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask_initial type(state_matrix_t), pointer :: state_in - - type :: connection_table_t - integer :: n_tot = 0 - integer :: n_me_conn = 0 - type(state_matrix_t) :: state - type(index_map_t) :: index_conn - type(connection_entry_t), dimension(:), allocatable :: entry - type(index_map_t) :: index_result - end type connection_table_t - type(connection_table_t) :: connection_table + type(connection_table_diag_t) :: connection_table logical :: sum_colors type(color_table_t) :: color_table if (present (expand_color_flows)) then sum_colors = .not. expand_color_flows else sum_colors = .true. end if if (sum_colors) then eval%type = EVAL_SQUARE_WITH_COLOR_FACTORS else eval%type = EVAL_SQUARED_FLOWS end if eval%int_in1 => int_in n_in = int_in%get_n_in () n_vir = int_in%get_n_vir () n_out = int_in%get_n_out () n_tot = int_in%get_n_tot () state_in => int_in%get_state_matrix_ptr () allocate (qn_mask_initial (n_tot)) qn_mask_initial = int_in%get_mask () call qn_mask_initial%set_color (sum_colors, mask_cg=.false.) if (sum_colors) then call color_table_init (color_table, state_in, n_tot) if (present (col_flow_index) .and. present (col_factor) & .and. present (col_index_hi)) then call color_table_set_color_factors & (color_table, col_flow_index, col_factor, col_index_hi) end if end if call connection_table_init (connection_table, state_in, & qn_mask_initial, qn_mask, n_tot) call connection_table_fill (connection_table, state_in) call make_squared_interaction (eval%interaction_t, & n_in, n_vir, n_out, n_tot, & connection_table, sum_colors, qn_mask_initial .or. qn_mask) call make_pairing_array (eval%pairing_array, & eval%get_n_matrix_elements (), & connection_table, sum_colors, color_table, n_in, n_tot, nc) call record_links (eval, int_in, n_tot) call connection_table_final (connection_table) contains subroutine connection_table_init & (connection_table, state_in, qn_mask_in, qn_mask, n_tot) - type(connection_table_t), intent(out) :: connection_table + type(connection_table_diag_t), intent(out) :: connection_table type(state_matrix_t), intent(in), target :: state_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask integer, intent(in) :: n_tot type(quantum_numbers_t), dimension(n_tot) :: qn type(state_iterator_t) :: it integer :: i, n_me_in, me_index_in integer :: me_index_conn, n_me_conn integer, dimension(1) :: me_count logical :: qn_passed connection_table%n_tot = n_tot n_me_in = state_in%get_n_matrix_elements () call index_map_init (connection_table%index_conn, n_me_in) - connection_table%index_conn = 0 call connection_table%state%init (n_counters=1) call it%init (state_in) do while (it%is_valid ()) qn = it%get_quantum_numbers () if (all (quantum_numbers_are_physical (qn, qn_mask))) then call qn%undefine (qn_mask_in) qn_passed = .true. if (qn_passed) then me_index_in = it%get_me_index () call connection_table%state%add_state (qn, & counter_index = 1, me_index = me_index_conn) call index_map_set_entry (connection_table%index_conn, & me_index_in, me_index_conn) end if end if call it%advance () end do n_me_conn = connection_table%state%get_n_matrix_elements () connection_table%n_me_conn = n_me_conn allocate (connection_table%entry (n_me_conn)) call it%init (connection_table%state) do while (it%is_valid ()) i = it%get_me_index () me_count = it%get_me_count () call connection_entry_init (connection_table%entry(i), 1, 2, & it%get_quantum_numbers (), me_count, [n_tot]) call it%advance () end do end subroutine connection_table_init subroutine connection_table_final (connection_table) - type(connection_table_t), intent(inout) :: connection_table + type(connection_table_diag_t), intent(inout) :: connection_table call connection_table%state%final () end subroutine connection_table_final subroutine connection_table_write (connection_table, unit) - type(connection_table_t), intent(in) :: connection_table + type(connection_table_diag_t), intent(in) :: connection_table integer, intent(in), optional :: unit integer :: i integer :: u u = given_output_unit (unit) write (u, *) "Connection table:" call connection_table%state%write (unit) if (index_map_exists (connection_table%index_conn)) then write (u, *) " Index mapping input => connection table:" do i = 1, size (connection_table%index_conn) write (u, *) i, & index_map_get_entry (connection_table%index_conn, i) end do end if if (allocated (connection_table%entry)) then write (u, *) " Connection table contents" do i = 1, size (connection_table%entry) call connection_entry_write (connection_table%entry(i), unit) end do end if if (index_map_exists (connection_table%index_result)) then write (u, *) " Index mapping connection table => output" do i = 1, size (connection_table%index_result) write (u, *) i, & index_map_get_entry (connection_table%index_result, i) end do end if end subroutine connection_table_write subroutine connection_table_fill (connection_table, state) - type(connection_table_t), intent(inout) :: connection_table + type(connection_table_diag_t), intent(inout) :: connection_table type(state_matrix_t), intent(in), target :: state integer :: index_in, index_conn, n_result_entries type(state_iterator_t) :: it integer :: k call it%init (state) do while (it%is_valid ()) index_in = it%get_me_index () index_conn = & index_map_get_entry (connection_table%index_conn, index_in) if (index_conn /= 0) then call connection_entry_add_state & (connection_table%entry(index_conn), & index_in, it%get_quantum_numbers ()) end if call it%advance () end do n_result_entries = 0 do k = 1, size (connection_table%entry) n_result_entries = & n_result_entries + connection_table%entry(k)%n_index(1) ** 2 end do call index_map_init (connection_table%index_result, n_result_entries) - connection_table%index_result = 0 end subroutine connection_table_fill subroutine connection_entry_add_state (entry, index_in, qn_in) type(connection_entry_t), intent(inout) :: entry integer, intent(in) :: index_in type(quantum_numbers_t), dimension(:), intent(in) :: qn_in integer :: c entry%count = entry%count + 1 c = entry%count(1) call index_map_set_entry (entry%index_in(1), c, index_in) entry%qn_in_list(1)%qn(:,c) = qn_in end subroutine connection_entry_add_state subroutine make_squared_interaction (int, & n_in, n_vir, n_out, n_tot, & connection_table, sum_colors, qn_mask) type(interaction_t), intent(out), target :: int integer, intent(in) :: n_in, n_vir, n_out, n_tot - type(connection_table_t), intent(inout), target :: connection_table + type(connection_table_diag_t), intent(inout), target :: connection_table logical, intent(in) :: sum_colors type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask type(connection_entry_t), pointer :: entry integer :: result_index, n_contrib integer :: i, m type(quantum_numbers_t), dimension(n_tot) :: qn call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask=qn_mask) m = 0 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) qn = quantum_numbers_undefined (entry%qn_conn, qn_mask) if (.not. sum_colors) call qn(1:n_in)%invert_color () call int%add_state (qn, me_index = result_index) n_contrib = entry%n_index(1) ** 2 connection_table%index_result%entry(m+1:m+n_contrib) = result_index m = m + n_contrib end do call int%freeze () end subroutine make_squared_interaction subroutine make_pairing_array (pa, & n_matrix_elements, connection_table, sum_colors, color_table, & n_in, n_tot, nc) type(pairing_array_t), dimension(:), intent(out), allocatable :: pa integer, intent(in) :: n_matrix_elements - type(connection_table_t), intent(in), target :: connection_table + type(connection_table_diag_t), intent(in), target :: connection_table logical, intent(in) :: sum_colors type(color_table_t), intent(inout) :: color_table type(connection_entry_t), pointer :: entry integer, intent(in) :: n_in, n_tot integer, intent(in), optional :: nc integer, dimension(:), allocatable :: n_entries integer :: i, k, l, ks, ls, m, r integer :: color_multiplicity_in allocate (pa (n_matrix_elements)) allocate (n_entries (n_matrix_elements)) n_entries = 0 do m = 1, size (connection_table%index_result) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 end do call pairing_array_init & (pa, n_entries, has_i2 = sum_colors, has_factor = sum_colors) m = 1 n_entries = 0 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) do k = 1, entry%n_index(1) if (sum_colors) then color_multiplicity_in = product (abs & (entry%qn_in_list(1)%qn(:n_in, k)%get_color_type ())) do l = 1, entry%n_index(1) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 ks = index_map_get_entry (entry%index_in(1), k) ls = index_map_get_entry (entry%index_in(1), l) pa(r)%i1(n_entries(r)) = ks pa(r)%i2(n_entries(r)) = ls pa(r)%factor(n_entries(r)) = & color_table_get_color_factor (color_table, ks, ls, nc) & / color_multiplicity_in m = m + 1 end do else r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 ks = index_map_get_entry (entry%index_in(1), k) pa(r)%i1(n_entries(r)) = ks m = m + 1 end if end do end do end subroutine make_pairing_array subroutine record_links (int, int_in, n_tot) class(interaction_t), intent(inout) :: int class(interaction_t), intent(in), target :: int_in integer, intent(in) :: n_tot integer, dimension(n_tot) :: map integer :: i do i = 1, n_tot call int%set_source_link (i, int_in, i) end do map = [ (i, i = 1, n_tot) ] call int_in%transfer_relations (int, map) end subroutine record_links end subroutine evaluator_init_square_diag @ %def evaluator_init_square_diag @ \subsubsection{Color-summed squared matrix (support nodiagonal helicities)} The initializer for an evaluator that squares a matrix element, including color factors. Unless requested otherwise by the quantum-number mask, the result contains off-diagonal matrix elements. (The input interaction must be diagonal since it represents an amplitude, not a density matrix.) There is only one input interaction. The quantum-number mask is an array, one entry for each particle, so they can be treated individually. For academic purposes, we allow for the number of colors being different from three (but 3 is the default). The algorithm is analogous to the previous one, with some additional complications due to the necessity to loop over two helicity indices. <>= procedure :: init_square_nondiag => evaluator_init_square_nondiag +<>= + module subroutine evaluator_init_square_nondiag (eval, int_in, qn_mask, & + col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) + class(evaluator_t), intent(out), target :: eval + class(interaction_t), intent(in), target :: int_in + type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask + integer, dimension(:,:), intent(in), optional :: col_flow_index + complex(default), dimension(:), intent(in), optional :: col_factor + integer, dimension(:), intent(in), optional :: col_index_hi + logical, intent(in), optional :: expand_color_flows + integer, intent(in), optional :: nc + end subroutine evaluator_init_square_nondiag <>= - subroutine evaluator_init_square_nondiag (eval, int_in, qn_mask, & + module subroutine evaluator_init_square_nondiag (eval, int_in, qn_mask, & col_flow_index, col_factor, col_index_hi, expand_color_flows, nc) class(evaluator_t), intent(out), target :: eval class(interaction_t), intent(in), target :: int_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask integer, dimension(:,:), intent(in), optional :: col_flow_index complex(default), dimension(:), intent(in), optional :: col_factor integer, dimension(:), intent(in), optional :: col_index_hi logical, intent(in), optional :: expand_color_flows integer, intent(in), optional :: nc integer :: n_in, n_vir, n_out, n_tot type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask_initial type(state_matrix_t), pointer :: state_in - - type :: connection_table_t - integer :: n_tot = 0 - integer :: n_me_conn = 0 - type(state_matrix_t) :: state - type(index_map2_t) :: index_conn - type(connection_entry_t), dimension(:), allocatable :: entry - type(index_map_t) :: index_result - end type connection_table_t - type(connection_table_t) :: connection_table + type(connection_table_nondiag_t) :: connection_table logical :: sum_colors type(color_table_t) :: color_table if (present (expand_color_flows)) then sum_colors = .not. expand_color_flows else sum_colors = .true. end if if (sum_colors) then eval%type = EVAL_SQUARE_WITH_COLOR_FACTORS else eval%type = EVAL_SQUARED_FLOWS end if eval%int_in1 => int_in n_in = int_in%get_n_in () n_vir = int_in%get_n_vir () n_out = int_in%get_n_out () n_tot = int_in%get_n_tot () state_in => int_in%get_state_matrix_ptr () allocate (qn_mask_initial (n_tot)) qn_mask_initial = int_in%get_mask () call qn_mask_initial%set_color (sum_colors, mask_cg=.false.) if (sum_colors) then call color_table_init (color_table, state_in, n_tot) if (present (col_flow_index) .and. present (col_factor) & .and. present (col_index_hi)) then call color_table_set_color_factors & (color_table, col_flow_index, col_factor, col_index_hi) end if end if call connection_table_init (connection_table, state_in, & qn_mask_initial, qn_mask, n_tot) call connection_table_fill (connection_table, state_in) call make_squared_interaction (eval%interaction_t, & n_in, n_vir, n_out, n_tot, & connection_table, sum_colors, qn_mask_initial .or. qn_mask) call make_pairing_array (eval%pairing_array, & eval%get_n_matrix_elements (), & connection_table, sum_colors, color_table, n_in, n_tot, nc) call record_links (eval, int_in, n_tot) call connection_table_final (connection_table) contains subroutine connection_table_init & (connection_table, state_in, qn_mask_in, qn_mask, n_tot) - type(connection_table_t), intent(out) :: connection_table + type(connection_table_nondiag_t), intent(out) :: connection_table type(state_matrix_t), intent(in), target :: state_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask integer, intent(in) :: n_tot type(quantum_numbers_t), dimension(n_tot) :: qn1, qn2, qn type(state_iterator_t) :: it1, it2, it integer :: i, n_me_in, me_index_in1, me_index_in2 integer :: me_index_conn, n_me_conn integer, dimension(1) :: me_count logical :: qn_passed connection_table%n_tot = n_tot n_me_in = state_in%get_n_matrix_elements () call index_map2_init (connection_table%index_conn, n_me_in) connection_table%index_conn = 0 call connection_table%state%init (n_counters=1) call it1%init (state_in) do while (it1%is_valid ()) qn1 = it1%get_quantum_numbers () me_index_in1 = it1%get_me_index () call it2%init (state_in) do while (it2%is_valid ()) qn2 = it2%get_quantum_numbers () if (all (quantum_numbers_are_compatible (qn1, qn2, qn_mask))) then qn = qn1 .merge. qn2 call qn%undefine (qn_mask_in) qn_passed = .true. if (qn_passed) then me_index_in2 = it2%get_me_index () call connection_table%state%add_state (qn, & counter_index = 1, me_index = me_index_conn) call index_map2_set_entry (connection_table%index_conn, & me_index_in1, me_index_in2, me_index_conn) end if end if call it2%advance () end do call it1%advance () end do n_me_conn = connection_table%state%get_n_matrix_elements () connection_table%n_me_conn = n_me_conn allocate (connection_table%entry (n_me_conn)) call it%init (connection_table%state) do while (it%is_valid ()) i = it%get_me_index () me_count = it%get_me_count () call connection_entry_init (connection_table%entry(i), 1, 2, & it%get_quantum_numbers (), me_count, [n_tot]) call it%advance () end do end subroutine connection_table_init subroutine connection_table_final (connection_table) - type(connection_table_t), intent(inout) :: connection_table + type(connection_table_nondiag_t), intent(inout) :: connection_table call connection_table%state%final () end subroutine connection_table_final subroutine connection_table_write (connection_table, unit) - type(connection_table_t), intent(in) :: connection_table + type(connection_table_nondiag_t), intent(in) :: connection_table integer, intent(in), optional :: unit integer :: i, j integer :: u u = given_output_unit (unit) write (u, *) "Connection table:" call connection_table%state%write (unit) if (index_map2_exists (connection_table%index_conn)) then write (u, *) " Index mapping input => connection table:" do i = 1, size (connection_table%index_conn) do j = 1, size (connection_table%index_conn) write (u, *) i, j, & index_map2_get_entry (connection_table%index_conn, i, j) end do end do end if if (allocated (connection_table%entry)) then write (u, *) " Connection table contents" do i = 1, size (connection_table%entry) call connection_entry_write (connection_table%entry(i), unit) end do end if if (index_map_exists (connection_table%index_result)) then write (u, *) " Index mapping connection table => output" do i = 1, size (connection_table%index_result) write (u, *) i, & index_map_get_entry (connection_table%index_result, i) end do end if end subroutine connection_table_write subroutine connection_table_fill (connection_table, state) - type(connection_table_t), intent(inout), target :: connection_table + type(connection_table_nondiag_t), intent(inout), target :: connection_table type(state_matrix_t), intent(in), target :: state integer :: index1_in, index2_in, index_conn, n_result_entries type(state_iterator_t) :: it1, it2 integer :: k call it1%init (state) do while (it1%is_valid ()) index1_in = it1%get_me_index () call it2%init (state) do while (it2%is_valid ()) index2_in = it2%get_me_index () index_conn = index_map2_get_entry & (connection_table%index_conn, index1_in, index2_in) if (index_conn /= 0) then call connection_entry_add_state & (connection_table%entry(index_conn), & index1_in, index2_in, & it1%get_quantum_numbers () & .merge. & it2%get_quantum_numbers ()) end if call it2%advance () end do call it1%advance () end do n_result_entries = 0 do k = 1, size (connection_table%entry) n_result_entries = & n_result_entries + connection_table%entry(k)%n_index(1) end do call index_map_init (connection_table%index_result, n_result_entries) - connection_table%index_result = 0 end subroutine connection_table_fill subroutine connection_entry_add_state (entry, index1_in, index2_in, qn_in) type(connection_entry_t), intent(inout) :: entry integer, intent(in) :: index1_in, index2_in type(quantum_numbers_t), dimension(:), intent(in) :: qn_in integer :: c entry%count = entry%count + 1 c = entry%count(1) call index_map_set_entry (entry%index_in(1), c, index1_in) call index_map_set_entry (entry%index_in(2), c, index2_in) entry%qn_in_list(1)%qn(:,c) = qn_in end subroutine connection_entry_add_state subroutine make_squared_interaction (int, & n_in, n_vir, n_out, n_tot, & connection_table, sum_colors, qn_mask) type(interaction_t), intent(out), target :: int integer, intent(in) :: n_in, n_vir, n_out, n_tot - type(connection_table_t), intent(inout), target :: connection_table + type(connection_table_nondiag_t), intent(inout), target :: connection_table logical, intent(in) :: sum_colors type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask type(connection_entry_t), pointer :: entry integer :: result_index integer :: i, k, m type(quantum_numbers_t), dimension(n_tot) :: qn call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask=qn_mask) m = 0 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) do k = 1, size (entry%qn_in_list(1)%qn, 2) qn = quantum_numbers_undefined & (entry%qn_in_list(1)%qn(:,k), qn_mask) if (.not. sum_colors) call qn(1:n_in)%invert_color () call int%add_state (qn, me_index = result_index) call index_map_set_entry (connection_table%index_result, m + 1, & result_index) m = m + 1 end do end do call int%freeze () end subroutine make_squared_interaction subroutine make_pairing_array (pa, & n_matrix_elements, connection_table, sum_colors, color_table, & n_in, n_tot, nc) type(pairing_array_t), dimension(:), intent(out), allocatable :: pa integer, intent(in) :: n_matrix_elements - type(connection_table_t), intent(in), target :: connection_table + type(connection_table_nondiag_t), intent(in), target :: connection_table logical, intent(in) :: sum_colors type(color_table_t), intent(inout) :: color_table type(connection_entry_t), pointer :: entry integer, intent(in) :: n_in, n_tot integer, intent(in), optional :: nc integer, dimension(:), allocatable :: n_entries integer :: i, k, k1s, k2s, m, r integer :: color_multiplicity_in allocate (pa (n_matrix_elements)) allocate (n_entries (n_matrix_elements)) n_entries = 0 do m = 1, size (connection_table%index_result) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 end do call pairing_array_init & (pa, n_entries, has_i2 = sum_colors, has_factor = sum_colors) m = 1 n_entries = 0 do i = 1, connection_table%n_me_conn entry => connection_table%entry(i) do k = 1, entry%n_index(1) r = index_map_get_entry (connection_table%index_result, m) n_entries(r) = n_entries(r) + 1 if (sum_colors) then k1s = index_map_get_entry (entry%index_in(1), k) k2s = index_map_get_entry (entry%index_in(2), k) pa(r)%i1(n_entries(r)) = k1s pa(r)%i2(n_entries(r)) = k2s color_multiplicity_in = product (abs & (entry%qn_in_list(1)%qn(:n_in, k)%get_color_type ())) pa(r)%factor(n_entries(r)) = & color_table_get_color_factor (color_table, k1s, k2s, nc) & / color_multiplicity_in else k1s = index_map_get_entry (entry%index_in(1), k) pa(r)%i1(n_entries(r)) = k1s end if m = m + 1 end do end do end subroutine make_pairing_array subroutine record_links (int, int_in, n_tot) class(interaction_t), intent(inout) :: int class(interaction_t), intent(in), target :: int_in integer, intent(in) :: n_tot integer, dimension(n_tot) :: map integer :: i do i = 1, n_tot call int%set_source_link (i, int_in, i) end do map = [ (i, i = 1, n_tot) ] call int_in%transfer_relations (int, map) end subroutine record_links end subroutine evaluator_init_square_nondiag @ %def evaluator_init_square_nondiag @ \subsubsection{Copy with additional contracted color states} This evaluator involves no square or multiplication, its matrix elements are just copies of the (single) input interaction. However, the state matrix of the interaction contains additional states that have color indices contracted. This is used for copies of the beam or structure-function interactions that need to match the hard interaction also in the case where its color indices coincide. <>= procedure :: init_color_contractions => evaluator_init_color_contractions +<>= + module subroutine evaluator_init_color_contractions (eval, int_in) + class(evaluator_t), intent(out), target :: eval + type(interaction_t), intent(in), target :: int_in + end subroutine evaluator_init_color_contractions <>= - subroutine evaluator_init_color_contractions (eval, int_in) + module subroutine evaluator_init_color_contractions (eval, int_in) class(evaluator_t), intent(out), target :: eval type(interaction_t), intent(in), target :: int_in integer :: n_in, n_vir, n_out, n_tot type(state_matrix_t) :: state_with_contractions integer, dimension(:), allocatable :: me_index integer, dimension(:), allocatable :: result_index eval%type = EVAL_COLOR_CONTRACTION eval%int_in1 => int_in n_in = int_in%get_n_in () n_vir = int_in%get_n_vir () n_out = int_in%get_n_out () n_tot = int_in%get_n_tot () state_with_contractions = int_in%get_state_matrix_ptr () call state_with_contractions%add_color_contractions () call make_contracted_interaction (eval%interaction_t, & me_index, result_index, & n_in, n_vir, n_out, n_tot, & state_with_contractions, int_in%get_mask ()) call make_pairing_array (eval%pairing_array, me_index, result_index) call record_links (eval, int_in, n_tot) call state_with_contractions%final () contains subroutine make_contracted_interaction (int, & me_index, result_index, & n_in, n_vir, n_out, n_tot, state, qn_mask) type(interaction_t), intent(out), target :: int integer, dimension(:), intent(out), allocatable :: me_index integer, dimension(:), intent(out), allocatable :: result_index integer, intent(in) :: n_in, n_vir, n_out, n_tot type(state_matrix_t), intent(in) :: state type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask type(state_iterator_t) :: it integer :: n_me, i type(quantum_numbers_t), dimension(n_tot) :: qn call int%basic_init (n_in, n_vir, n_out, mask=qn_mask) n_me = state%get_n_leaves () allocate (me_index (n_me)) allocate (result_index (n_me)) call it%init (state) i = 0 do while (it%is_valid ()) i = i + 1 me_index(i) = it%get_me_index () qn = it%get_quantum_numbers () call int%add_state (qn, me_index = result_index(i)) call it%advance () end do call int%freeze () end subroutine make_contracted_interaction subroutine make_pairing_array (pa, me_index, result_index) type(pairing_array_t), dimension(:), intent(out), allocatable :: pa integer, dimension(:), intent(in) :: me_index, result_index integer, dimension(:), allocatable :: n_entries integer :: n_matrix_elements, r, i, k !!! The result indices of the appended color contracted states !!! start counting from 1 again. For the pairing array, we currently !!! only take the first part of ascending indices into account !!! excluding the color contracted states. n_matrix_elements = size (me_index) k = 0 do i = 1, n_matrix_elements r = result_index(i) if (r < i) exit k = r end do allocate (pa (k)) allocate (n_entries (k)) n_entries = 1 call pairing_array_init & (pa, n_entries, has_i2=.false., has_factor=.false.) do i = 1, k r = result_index(i) pa(r)%i1(1) = me_index(i) end do end subroutine make_pairing_array subroutine record_links (int, int_in, n_tot) class(interaction_t), intent(inout) :: int class(interaction_t), intent(in), target :: int_in integer, intent(in) :: n_tot integer, dimension(n_tot) :: map integer :: i do i = 1, n_tot call int%set_source_link (i, int_in, i) end do map = [ (i, i = 1, n_tot) ] call int_in%transfer_relations (int, map) end subroutine record_links end subroutine evaluator_init_color_contractions @ %def evaluator_init_color_contractions @ \subsubsection{Auxiliary procedure for initialization} This will become a standard procedure in F2008. The result is true if the number of true values in the mask is odd. We use the function for determining the ghost parity of a quantum-number array. [tho:] It's not used anymore and [[mod (count (mask), 2) == 1]] is a cooler implementation anyway. <<(UNUSED) Evaluators: procedures>>= function parity (mask) logical :: parity logical, dimension(:) :: mask integer :: i parity = .false. do i = 1, size (mask) if (mask(i)) parity = .not. parity end do end function parity @ %def parity @ Reassign external source links from one to another. <>= public :: evaluator_reassign_links <>= interface evaluator_reassign_links module procedure evaluator_reassign_links_eval module procedure evaluator_reassign_links_int end interface +<>= + module subroutine evaluator_reassign_links_eval (eval, eval_src, eval_target) + type(evaluator_t), intent(inout) :: eval + type(evaluator_t), intent(in) :: eval_src + type(evaluator_t), intent(in), target :: eval_target + end subroutine evaluator_reassign_links_eval + module subroutine evaluator_reassign_links_int (eval, int_src, int_target) + type(evaluator_t), intent(inout) :: eval + type(interaction_t), intent(in) :: int_src + type(interaction_t), intent(in), target :: int_target + end subroutine evaluator_reassign_links_int <>= - subroutine evaluator_reassign_links_eval (eval, eval_src, eval_target) + module subroutine evaluator_reassign_links_eval (eval, eval_src, eval_target) type(evaluator_t), intent(inout) :: eval type(evaluator_t), intent(in) :: eval_src type(evaluator_t), intent(in), target :: eval_target if (associated (eval%int_in1)) then if (eval%int_in1%get_tag () == eval_src%get_tag ()) then eval%int_in1 => eval_target%interaction_t end if end if if (associated (eval%int_in2)) then if (eval%int_in2%get_tag () == eval_src%get_tag ()) then eval%int_in2 => eval_target%interaction_t end if end if call interaction_reassign_links & (eval%interaction_t, eval_src%interaction_t, & eval_target%interaction_t) end subroutine evaluator_reassign_links_eval - subroutine evaluator_reassign_links_int (eval, int_src, int_target) + module subroutine evaluator_reassign_links_int (eval, int_src, int_target) type(evaluator_t), intent(inout) :: eval type(interaction_t), intent(in) :: int_src type(interaction_t), intent(in), target :: int_target if (associated (eval%int_in1)) then if (eval%int_in1%get_tag () == int_src%get_tag ()) then eval%int_in1 => int_target end if end if if (associated (eval%int_in2)) then if (eval%int_in2%get_tag () == int_src%get_tag ()) then eval%int_in2 => int_target end if end if call interaction_reassign_links (eval%interaction_t, int_src, int_target) end subroutine evaluator_reassign_links_int @ %def evaluator_reassign_links -@ Return flavor, momentum, and position of the first unstable particle -present in the interaction. -<>= - public :: evaluator_get_unstable_particle -<>= - subroutine evaluator_get_unstable_particle (eval, flv, p, i) - type(evaluator_t), intent(in) :: eval - type(flavor_t), intent(out) :: flv - type(vector4_t), intent(out) :: p - integer, intent(out) :: i - call interaction_get_unstable_particle (eval%interaction_t, flv, p, i) - end subroutine evaluator_get_unstable_particle - -@ %def evaluator_get_unstable_particle @ <>= public :: evaluator_get_int_in_ptr +<>= + module function evaluator_get_int_in_ptr (eval, i) result (int_in) + class(interaction_t), pointer :: int_in + type(evaluator_t), intent(in), target :: eval + integer, intent(in) :: i + end function evaluator_get_int_in_ptr <>= - function evaluator_get_int_in_ptr (eval, i) result (int_in) + module function evaluator_get_int_in_ptr (eval, i) result (int_in) class(interaction_t), pointer :: int_in type(evaluator_t), intent(in), target :: eval integer, intent(in) :: i if (i == 1) then int_in => eval%int_in1 else if (i == 2) then int_in => eval%int_in2 else int_in => null () end if end function evaluator_get_int_in_ptr @ %def evaluator_get_int_in_ptr @ \subsection{Creating an evaluator: identity} The identity evaluator creates a copy of the first input evaluator; the second input is not used. All particles link back to the input evaluatorand the internal relations are copied. As evaluation does take a shortcut by cloning the matrix elements, the pairing array is not used and does not have to be set up. <>= procedure :: init_identity => evaluator_init_identity +<>= + module subroutine evaluator_init_identity (eval, int) + class(evaluator_t), intent(out), target :: eval + class(interaction_t), intent(in), target :: int + end subroutine evaluator_init_identity <>= - subroutine evaluator_init_identity (eval, int) + module subroutine evaluator_init_identity (eval, int) class(evaluator_t), intent(out), target :: eval class(interaction_t), intent(in), target :: int integer :: n_in, n_out, n_vir, n_tot integer :: i integer, dimension(:), allocatable :: map type(state_matrix_t), pointer :: state type(state_iterator_t) :: it eval%type = EVAL_IDENTITY eval%int_in1 => int nullify (eval%int_in2) n_in = int%get_n_in () n_out = int%get_n_out () n_vir = int%get_n_vir () n_tot = int%get_n_tot () call eval%interaction_t%basic_init (n_in, n_vir, n_out, & mask = int%get_mask (), & resonant = int%get_resonance_flags ()) do i = 1, n_tot call eval%set_source_link (i, int, i) end do allocate (map(n_tot)) map = [(i, i = 1, n_tot)] call int%transfer_relations (eval, map) state => int%get_state_matrix_ptr () call it%init (state) do while (it%is_valid ()) call eval%add_state (it%get_quantum_numbers (), & it%get_me_index ()) call it%advance () end do call eval%freeze () end subroutine evaluator_init_identity @ %def evaluator_init_identity @ \subsection {Creating an evaluator: quantum number sum} This evaluator operates on the diagonal of a density matrix and sums over the quantum numbers specified by the mask. The optional argument [[drop]] allows to drop a particle from the resulting density matrix. The handling of virtuals is not completely sane, especially in connection with dropping particles. When summing over matrix element entries, we keep the separation into entries and normalization (in the corresponding evaluation routine below). <>= procedure :: init_qn_sum => evaluator_init_qn_sum +<>= + module subroutine evaluator_init_qn_sum (eval, int, qn_mask, drop) + class(evaluator_t), intent(out), target :: eval + class(interaction_t), target, intent(in) :: int + type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask + logical, intent(in), optional, dimension(:) :: drop + end subroutine evaluator_init_qn_sum <>= - subroutine evaluator_init_qn_sum (eval, int, qn_mask, drop) + module subroutine evaluator_init_qn_sum (eval, int, qn_mask, drop) class(evaluator_t), intent(out), target :: eval class(interaction_t), target, intent(in) :: int type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask logical, intent(in), optional, dimension(:) :: drop type(state_iterator_t) :: it_old, it_new integer, dimension(:), allocatable :: pairing_size, pairing_target, i_new integer, dimension(:), allocatable :: map integer :: n_in, n_out, n_vir, n_tot, n_me_old, n_me_new integer :: i, j type(state_matrix_t), pointer :: state_new, state_old type(quantum_numbers_t), dimension(:), allocatable :: qn logical :: matched logical, dimension(size (qn_mask)) :: dropped integer :: ndropped integer, dimension(:), allocatable :: inotdropped type(quantum_numbers_mask_t), dimension(:), allocatable :: mask logical, dimension(:), allocatable :: resonant eval%type = EVAL_QN_SUM eval%int_in1 => int nullify (eval%int_in2) if (present (drop)) then dropped = drop else dropped = .false. end if ndropped = count (dropped) n_in = int%get_n_in () n_out = int%get_n_out () - ndropped n_vir = int%get_n_vir () n_tot = int%get_n_tot () - ndropped allocate (inotdropped (n_tot)) i = 1 do j = 1, n_tot + ndropped if (dropped (j)) cycle inotdropped(i) = j i = i + 1 end do allocate (mask(n_tot + ndropped)) mask = int%get_mask () allocate (resonant(n_tot + ndropped)) resonant = int%get_resonance_flags () call eval%interaction_t%basic_init (n_in, n_vir, n_out, & mask = mask(inotdropped) .or. qn_mask(inotdropped), & resonant = resonant(inotdropped)) i = 1 do j = 1, n_tot + ndropped if (dropped(j)) cycle call eval%set_source_link (i, int, j) i = i + 1 end do allocate (map(n_tot + ndropped)) i = 1 do j = 1, n_tot + ndropped if (dropped (j)) then map(j) = 0 else map(j) = i i = i + 1 end if end do call int%transfer_relations (eval, map) n_me_old = int%get_n_matrix_elements () allocate (pairing_size (n_me_old), source = 0) allocate (pairing_target (n_me_old), source = 0) pairing_size = 0 state_old => int%get_state_matrix_ptr () state_new => eval%get_state_matrix_ptr () call it_old%init (state_old) allocate (qn(n_tot + ndropped)) do while (it_old%is_valid ()) qn = it_old%get_quantum_numbers () if (.not. all (qn%are_diagonal ())) then call it_old%advance () cycle end if matched = .false. call it_new%init (state_new) if (eval%get_n_matrix_elements () > 0) then do while (it_new%is_valid ()) if (all (qn(inotdropped) .match. & it_new%get_quantum_numbers ())) & then matched = .true. i = it_new%get_me_index () exit end if call it_new%advance () end do end if if (.not. matched) then call eval%add_state (qn(inotdropped)) i = eval%get_n_matrix_elements () end if pairing_size(i) = pairing_size(i) + 1 pairing_target(it_old%get_me_index ()) = i call it_old%advance () end do call eval%freeze () n_me_new = eval%get_n_matrix_elements () allocate (eval%pairing_array (n_me_new)) do i = 1, n_me_new call pairing_array_init (eval%pairing_array(i), & pairing_size(i), .false., .false.) end do allocate (i_new (n_me_new), source = 0) do i = 1, n_me_old j = pairing_target(i) if (j > 0) then i_new(j) = i_new(j) + 1 eval%pairing_array(j)%i1(i_new(j)) = i end if end do end subroutine evaluator_init_qn_sum @ %def evaluator_init_qn_sum @ \subsection{Evaluation} When the input interactions (which are pointed to in the pairings stored within the evaluator) are filled with values, we can activate the evaluator, i.e., calculate the result values which are stored in the interaction. The evaluation of matrix elements can be done in parallel. A [[forall]] construct is not appropriate, however. We would need [[do concurrent]] here. Nevertheless, the evaluation functions are marked as [[pure]]. <>= procedure :: evaluate => evaluator_evaluate +<>= + module subroutine evaluator_evaluate (eval) + class(evaluator_t), intent(inout), target :: eval + end subroutine evaluator_evaluate <>= - subroutine evaluator_evaluate (eval) + module subroutine evaluator_evaluate (eval) class(evaluator_t), intent(inout), target :: eval integer :: i select case (eval%type) case (EVAL_PRODUCT) do i = 1, size(eval%pairing_array) call eval%evaluate_product (i, & eval%int_in1, eval%int_in2, & eval%pairing_array(i)%i1, eval%pairing_array(i)%i2) if (debug2_active (D_QFT)) then print *, 'eval%pairing_array(i)%i1, eval%pairing_array(i)%i2 = ', & eval%pairing_array(i)%i1, eval%pairing_array(i)%i2 print *, 'MEs = ', & eval%int_in1%get_matrix_element (eval%pairing_array(i)%i1), & eval%int_in2%get_matrix_element (eval%pairing_array(i)%i2) end if end do case (EVAL_SQUARE_WITH_COLOR_FACTORS) do i = 1, size(eval%pairing_array) call eval%evaluate_product_cf (i, & eval%int_in1, eval%int_in1, & eval%pairing_array(i)%i1, eval%pairing_array(i)%i2, & eval%pairing_array(i)%factor) end do case (EVAL_SQUARED_FLOWS) do i = 1, size(eval%pairing_array) call eval%evaluate_square_c (i, & eval%int_in1, & eval%pairing_array(i)%i1) end do case (EVAL_COLOR_CONTRACTION) do i = 1, size(eval%pairing_array) call eval%evaluate_sum (i, & eval%int_in1, & eval%pairing_array(i)%i1) end do case (EVAL_IDENTITY) call eval%set_matrix_element (eval%int_in1) case (EVAL_QN_SUM) do i = 1, size (eval%pairing_array) call eval%evaluate_me_sum (i, & eval%int_in1, eval%pairing_array(i)%i1) call eval%set_norm (eval%int_in1%get_norm ()) end do end select end subroutine evaluator_evaluate @ %def evaluator_evaluate @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[evaluators_ut.f90]]>>= <> module evaluators_ut use unit_tests use evaluators_uti <> <> contains <> end module evaluators_ut @ %def evaluators_ut @ <<[[evaluators_uti.f90]]>>= <> module evaluators_uti <> use lorentz use flavors use colors use helicities use quantum_numbers use interactions use model_data use evaluators <> <> contains <> end module evaluators_uti @ %def evaluators_ut @ API: driver for the unit tests below. <>= public :: evaluator_test <>= subroutine evaluator_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine evaluator_test @ %def evaluator_test @ Test: Create two interactions. The interactions are twofold connected. The first connection has a helicity index that is kept, the second connection has a helicity index that is summed over. Concatenate the interactions in an evaluator, which thus contains a result interaction. Fill the input interactions with values, activate the evaluator and print the result. <>= call test (evaluator_1, "evaluator_1", & "check evaluators (1)", & u, results) <>= public :: evaluator_1 <>= subroutine evaluator_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(interaction_t), target :: int_qqtt, int_tbw, int1, int2 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 integer :: f, c, h1, h2, h3 type(vector4_t), dimension(4) :: p type(vector4_t), dimension(2) :: q type(quantum_numbers_mask_t) :: qn_mask_conn type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask2 type(evaluator_t), target :: eval, eval2, eval3 call model%init_sm_test () write (u, "(A)") "*** Evaluator for matrix product" write (u, "(A)") "*** Construct interaction for qq -> tt" write (u, "(A)") call int_qqtt%basic_init (2, 0, 2, set_relations=.true.) allocate (flv (4), col (4), hel (4), qn (4)) allocate (qn_mask2 (4)) do c = 1, 2 select case (c) case (1) call col%init_col_acl ([1, 0, 1, 0], [0, 2, 0, 2]) case (2) call col%init_col_acl ([1, 0, 2, 0], [0, 1, 0, 2]) end select do f = 1, 2 call flv%init ([f, -f, 6, -6], model) do h1 = -1, 1, 2 call hel(3)%init (h1) do h2 = -1, 1, 2 call hel(4)%init (h2) call qn%init (flv, col, hel) call int_qqtt%add_state (qn) end do end do end do end do call int_qqtt%freeze () deallocate (flv, col, hel, qn) write (u, "(A)") "*** Construct interaction for t -> bW" call int_tbw%basic_init (1, 0, 2, set_relations=.true.) allocate (flv (3), col (3), hel (3), qn (3)) call flv%init ([6, 5, 24], model) call col%init_col_acl ([1, 1, 0], [0, 0, 0]) do h1 = -1, 1, 2 call hel(1)%init (h1) do h2 = -1, 1, 2 call hel(2)%init (h2) do h3 = -1, 1 call hel(3)%init (h3) call qn%init (flv, col, hel) call int_tbw%add_state (qn) end do end do end do call int_tbw%freeze () deallocate (flv, col, hel, qn) write (u, "(A)") "*** Link interactions" call int_tbw%set_source_link (1, int_qqtt, 3) qn_mask_conn = quantum_numbers_mask (.false.,.false.,.true.) write (u, "(A)") write (u, "(A)") "*** Show input" call int_qqtt%basic_write (unit = u) write (u, "(A)") call int_tbw%basic_write (unit = u) write (u, "(A)") write (u, "(A)") "*** Evaluate product" call eval%init_product (int_qqtt, int_tbw, qn_mask_conn) call eval%write (unit = u) call int1%basic_init (2, 0, 2, set_relations=.true.) call int2%basic_init (1, 0, 2, set_relations=.true.) p(1) = vector4_moving (1000._default, 1000._default, 3) p(2) = vector4_moving (200._default, 200._default, 2) p(3) = vector4_moving (100._default, 200._default, 1) p(4) = p(1) - p(2) - p(3) call int1%set_momenta (p) q(1) = vector4_moving (50._default,-50._default, 3) q(2) = p(2) + p(4) - q(1) call int2%set_momenta (q, outgoing=.true.) call int1%set_matrix_element ([(2._default,0._default), & (4._default,1._default), (-3._default,0._default)]) call int2%set_matrix_element ([(-3._default,0._default), & (0._default,1._default), (1._default,2._default)]) call eval%receive_momenta () call eval%evaluate () call int1%basic_write (unit = u) write (u, "(A)") call int2%basic_write (unit = u) write (u, "(A)") call eval%write (unit = u) write (u, "(A)") call int1%final () call int2%final () call eval%final () write (u, "(A)") write (u, "(A)") "*** Evaluator for matrix square" allocate (flv(4), col(4), qn(4)) call int1%basic_init (2, 0, 2, set_relations=.true.) call flv%init ([1, -1, 21, 21], model) call col(1)%init ([1]) call col(2)%init ([-2]) call col(3)%init ([2, -3]) call col(4)%init ([3, -1]) call qn%init (flv, col) call int1%add_state (qn) call col(3)%init ([3, -1]) call col(4)%init ([2, -3]) call qn%init (flv, col) call int1%add_state (qn) call col(3)%init ([2, -1]) call col(4)%init (.true.) call qn%init (flv, col) call int1%add_state (qn) call int1%freeze () ! [qn_mask2 not set since default is false] call eval%init_square (int1, qn_mask2, nc=3) call eval2%init_square_nondiag (int1, qn_mask2) qn_mask2 = quantum_numbers_mask (.false., .true., .true.) call eval3%init_square_diag (eval, qn_mask2) call int1%set_matrix_element & ([(2._default,0._default), & (4._default,1._default), (-3._default,0._default)]) call int1%set_momenta (p) call int1%basic_write (unit = u) write (u, "(A)") call eval%receive_momenta () call eval%evaluate () call eval%write (unit = u) write (u, "(A)") call eval2%receive_momenta () call eval2%evaluate () call eval2%write (unit = u) write (u, "(A)") call eval3%receive_momenta () call eval3%evaluate () call eval3%write (unit = u) call int1%final () call eval%final () call eval2%final () call eval3%final () call model%final () end subroutine evaluator_1 @ %def evaluator_1 @ <>= call test (evaluator_2, "evaluator_2", & "check evaluators (2)", & u, results) <>= public :: evaluator_2 <>= subroutine evaluator_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(interaction_t), target :: int integer :: h1, h2, h3, h4 type(helicity_t), dimension(4) :: hel type(color_t), dimension(4) :: col type(flavor_t), dimension(4) :: flv type(quantum_numbers_t), dimension(4) :: qn type(vector4_t), dimension(4) :: p type(evaluator_t) :: eval integer :: i call model%init_sm_test () write (u, "(A)") "*** Creating interaction for e+ e- -> W+ W-" write (u, "(A)") call flv%init ([11, -11, 24, -24], model) do i = 1, 4 call col(i)%init () end do call int%basic_init (2, 0, 2, set_relations=.true.) do h1 = -1, 1, 2 call hel(1)%init (h1) do h2 = -1, 1, 2 call hel(2)%init (h2) do h3 = -1, 1 call hel(3)%init (h3) do h4 = -1, 1 call hel(4)%init (h4) call qn%init (flv, col, hel) call int%add_state (qn) end do end do end do end do call int%freeze () call int%set_matrix_element & ([(cmplx (i, kind=default), i = 1, 36)]) p(1) = vector4_moving (1000._default, 1000._default, 3) p(2) = vector4_moving (1000._default, -1000._default, 3) p(3) = vector4_moving (1000._default, & sqrt (1E6_default - 80._default**2), 3) p(4) = p(1) + p(2) - p(3) call int%set_momenta (p) write (u, "(A)") "*** Setting up evaluator" write (u, "(A)") call eval%init_identity (int) write (u, "(A)") "*** Transferring momenta and evaluating" write (u, "(A)") call eval%receive_momenta () call eval%evaluate () write (u, "(A)") "*******************************************************" write (u, "(A)") " Interaction dump" write (u, "(A)") "*******************************************************" call int%basic_write (unit = u) write (u, "(A)") write (u, "(A)") "*******************************************************" write (u, "(A)") " Evaluator dump" write (u, "(A)") "*******************************************************" call eval%write (unit = u) write (u, "(A)") write (u, "(A)") "*** cleaning up" call int%final () call eval%final () call model%final () end subroutine evaluator_2 @ %def evaluator_2 @ <>= call test (evaluator_3, "evaluator_3", & "check evaluators (3)", & u, results) <>= public :: evaluator_3 <>= subroutine evaluator_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(interaction_t), target :: int integer :: h1, h2, h3, h4 type(helicity_t), dimension(4) :: hel type(color_t), dimension(4) :: col type(flavor_t), dimension(4) :: flv1, flv2 type(quantum_numbers_t), dimension(4) :: qn type(vector4_t), dimension(4) :: p type(evaluator_t) :: eval1, eval2, eval3 type(quantum_numbers_mask_t), dimension(4) :: qn_mask integer :: i call model%init_sm_test () write (u, "(A)") "*** Creating interaction for e+/mu+ e-/mu- -> W+ W-" call flv1%init ([11, -11, 24, -24], model) call flv2%init ([13, -13, 24, -24], model) do i = 1, 4 call col (i)%init () end do call int%basic_init (2, 0, 2, set_relations=.true.) do h1 = -1, 1, 2 call hel(1)%init (h1) do h2 = -1, 1, 2 call hel(2)%init (h2) do h3 = -1, 1 call hel(3)%init (h3) do h4 = -1, 1 call hel(4)%init (h4) call qn%init (flv1, col, hel) call int%add_state (qn) call qn%init (flv2, col, hel) call int%add_state (qn) end do end do end do end do call int%freeze () call int%set_matrix_element & ([(cmplx (1, kind=default), i = 1, 72)]) p(1) = vector4_moving (1000._default, 1000._default, 3) p(2) = vector4_moving (1000._default, -1000._default, 3) p(3) = vector4_moving (1000._default, & sqrt (1E6_default - 80._default**2), 3) p(4) = p(1) + p(2) - p(3) call int%set_momenta (p) write (u, "(A)") "*** Setting up evaluators" call qn_mask%init (.false., .true., .true.) call eval1%init_qn_sum (int, qn_mask) call qn_mask%init (.true., .true., .true.) call eval2%init_qn_sum (int, qn_mask) call qn_mask%init (.false., .true., .false.) call eval3%init_qn_sum (int, qn_mask, & [.false., .false., .false., .true.]) write (u, "(A)") "*** Transferring momenta and evaluating" call eval1%receive_momenta () call eval1%evaluate () call eval2%receive_momenta () call eval2%evaluate () call eval3%receive_momenta () call eval3%evaluate () write (u, "(A)") "*******************************************************" write (u, "(A)") " Interaction dump" write (u, "(A)") "*******************************************************" call int%basic_write (unit = u) write (u, "(A)") write (u, "(A)") "*******************************************************" write (u, "(A)") " Evaluator dump --- spin sum" write (u, "(A)") "*******************************************************" call eval1%write (unit = u) call eval1%basic_write (unit = u) write (u, "(A)") "*******************************************************" write (u, "(A)") " Evaluator dump --- spin / flavor sum" write (u, "(A)") "*******************************************************" call eval2%write (unit = u) call eval2%basic_write (unit = u) write (u, "(A)") "*******************************************************" write (u, "(A)") " Evaluator dump --- flavor sum, drop last W" write (u, "(A)") "*******************************************************" call eval3%write (unit = u) call eval3%basic_write (unit = u) write (u, "(A)") write (u, "(A)") "*** cleaning up" call int%final () call eval1%final () call eval2%final () call eval3%final () call model%final () end subroutine evaluator_3 @ %def evaluator_3 @ This test evaluates a product with different quantum-number masks and filters for the linked entry. <>= call test (evaluator_4, "evaluator_4", & "check evaluator product with filter", & u, results) <>= public :: evaluator_4 <>= subroutine evaluator_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(interaction_t), target :: int1, int2 integer :: h1, h2, h3 type(helicity_t), dimension(3) :: hel type(color_t), dimension(3) :: col type(flavor_t), dimension(2) :: flv1, flv2 type(flavor_t), dimension(3) :: flv3, flv4 type(quantum_numbers_t), dimension(3) :: qn type(evaluator_t) :: eval1, eval2, eval3, eval4 type(quantum_numbers_mask_t) :: qn_mask type(flavor_t) :: flv_filter type(helicity_t) :: hel_filter type(color_t) :: col_filter type(quantum_numbers_t) :: qn_filter integer :: i write (u, "(A)") "* Test output: evaluator_4" write (u, "(A)") "* Purpose: test evaluator products & &with mask and filter" write (u, "(A)") call model%init_sm_test () write (u, "(A)") "* Creating interaction for e- -> W+/Z" write (u, "(A)") call flv1%init ([11, 24], model) call flv2%init ([11, 23], model) do i = 1, 3 call col(i)%init () end do call int1%basic_init (1, 0, 1, set_relations=.true.) do h1 = -1, 1, 2 call hel(1)%init (h1) do h2 = -1, 1 call hel(2)%init (h2) call qn(:2)%init (flv1, col(:2), hel(:2)) call int1%add_state (qn(:2)) call qn(:2)%init (flv2, col(:2), hel(:2)) call int1%add_state (qn(:2)) end do end do call int1%freeze () call int1%basic_write (u) write (u, "(A)") write (u, "(A)") "* Creating interaction for W+/Z -> u ubar/dbar" write (u, "(A)") call flv3%init ([24, 2, -1], model) call flv4%init ([23, 2, -2], model) call int2%basic_init (1, 0, 2, set_relations=.true.) do h1 = -1, 1 call hel(1)%init (h1) do h2 = -1, 1, 2 call hel(2)%init (h2) do h3 = -1, 1, 2 call hel(3)%init (h3) call qn(:3)%init (flv3, col(:3), hel(:3)) call int2%add_state (qn(:3)) call qn(:3)%init (flv4, col(:3), hel(:3)) call int2%add_state (qn(:3)) end do end do end do call int2%freeze () call int2%set_source_link (1, int1, 2) call int2%basic_write (u) write (u, "(A)") write (u, "(A)") "* Product evaluator" write (u, "(A)") call qn_mask%init (.false., .false., .false.) call eval1%init_product (int1, int2, qn_mask_conn = qn_mask) call eval1%write (u) write (u, "(A)") write (u, "(A)") "* Product evaluator with helicity mask" write (u, "(A)") call qn_mask%init (.false., .false., .true.) call eval2%init_product (int1, int2, qn_mask_conn = qn_mask) call eval2%write (u) write (u, "(A)") write (u, "(A)") "* Product with flavor filter and helicity mask" write (u, "(A)") call qn_mask%init (.false., .false., .true.) call flv_filter%init (24, model) call hel_filter%init () call col_filter%init () call qn_filter%init (flv_filter, col_filter, hel_filter) call eval3%init_product (int1, int2, & qn_mask_conn = qn_mask, qn_filter_conn = qn_filter) call eval3%write (u) write (u, "(A)") write (u, "(A)") "* Product with helicity filter and mask" write (u, "(A)") call qn_mask%init (.false., .false., .true.) call flv_filter%init () call hel_filter%init (0) call col_filter%init () call qn_filter%init (flv_filter, col_filter, hel_filter) call eval4%init_product (int1, int2, & qn_mask_conn = qn_mask, qn_filter_conn = qn_filter) call eval4%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eval1%final () call eval2%final () call eval3%final () call eval4%final () call int1%final () call int2%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: evaluator_4" end subroutine evaluator_4 @ %def evaluator_4 Index: trunk/src/process_integration/process_integration.nw =================================================================== --- trunk/src/process_integration/process_integration.nw (revision 8778) +++ trunk/src/process_integration/process_integration.nw (revision 8779) @@ -1,19795 +1,19794 @@ % -*- 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 will not 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 expr%set_pdg_beam (f_beam%get_pdg ()) call expr%set_pdg_incoming (f_in%get_pdg ()) call expr%set_pdg_outgoing (f_out%get_pdg ()) call expr%set_p2_beam (f_beam%get_mass () ** 2) call expr%set_p2_incoming (f_in%get_mass () ** 2) call expr%set_p2_outgoing (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 (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 (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 (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 (- int%get_momenta (j_beam)) call subevt%set_p_incoming (- int%get_momenta (j_in)) call subevt%set_p_outgoing (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 (- lt * int%get_momenta (j_beam)) call subevt%set_p_incoming (- lt * int%get_momenta (j_in)) call subevt%set_p_outgoing (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 = expr%get_sqrts_hat () 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), allocatable, intent(out) :: fac_scale real(default), allocatable, 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 (expr%has_fac_scale) then call expr%fac_scale%evaluate () if (expr%fac_scale%is_known ()) then if (.not. allocated (fac_scale)) then allocate (fac_scale, source = expr%fac_scale%get_real ()) else fac_scale = expr%fac_scale%get_real () end if else call msg_error ("Evaluate factorization scale expression: & &result undefined") end if end if if (expr%has_ren_scale) then call expr%ren_scale%evaluate () if (expr%ren_scale%is_known ()) then if (.not. allocated (ren_scale)) then allocate (ren_scale, source = expr%ren_scale%get_real ()) else ren_scale = expr%ren_scale%get_real () end if else call msg_error ("Evaluate renormalization scale expression: & &result undefined") end if 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 = expr%get_sqrts_hat () expr%n_in = expr%get_n_in () expr%n_out = expr%get_n_out () 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. 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 are 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 for 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 @ Set up 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 @ Set up 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} Set up 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. If an extended structure function is required [[requires_extended_sf]], we have to not consider [[sub]] as a quantum number. <>= procedure :: setup_connected_trace => connected_state_setup_connected_trace <>= subroutine connected_state_setup_connected_trace & (state, isolated, int, resonant, undo_helicities, & keep_fs_flavors, requires_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 :: requires_extended_sf type(quantum_numbers_mask_t) :: mask type(interaction_t), pointer :: src_int, beam_int logical :: reduce, fs_flv_flag if (debug_on) 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_for_qn = requires_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 @ Set up 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 @ Set up 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. For fixed-order NLO differential distribution, we are interested at the partonic level, no parton showering takes place as this would demand for a proper matching. So, the flows in the [[connected_state]] are not needed, and the color part will be masked for the interaction coming from the [[sf_chain]]. The squared matrix elements coming from the OLP provider at the moment do not come with flows anyhow. This needs to be revised once the matching to the shower is completed. <>= procedure :: setup_connected_flows => connected_state_setup_connected_flows <>= subroutine connected_state_setup_connected_flows & (state, isolated, int, resonant, qn_filter_conn, mask_color) 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, mask_color type(quantum_numbers_t), intent(in), optional :: qn_filter_conn type(quantum_numbers_mask_t) :: mask type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_sf type(interaction_t), pointer :: src_int logical :: mask_c mask_c = .false. if (present (mask_color)) mask_c = mask_color 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 if (mask_c) then allocate (mask_sf (src_int%get_n_tot ())) mask_sf = quantum_numbers_mask (.false., .true., .false.) call src_int%reduce_state_matrix (mask_sf, keep_order = .true.) end if 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) + call state%matrix%get_flv_content (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) + call state%trace%send_momenta () 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, weight real(default), intent(out), allocatable :: fac_scale, ren_scale 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 !!! Do not 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} The process-component manager [[pcm]] is the master component of the [[process_t]] object. It serves two purposes: \begin{enumerate} \item It holds configuration data which allow us to centrally manage the components, terms, etc.\ of the process object. \item It implements the methods that realize the algorithm for constructing the process object and computing an integral. This algorithm makes use of the data stored within [[pcm]]. \end{enumerate} To this end, the object is abstract and polymorphic. The two extensions that we support, implement (a) default tree-level calculation, optionally including a sum over sub-processes with different particle content, or (b) the FKS-NLO subtraction algorithm for QCD-corrected processes. In both cases, the type extensions may hold suitable further data. Data included in the base type: The number of components determines the [[component_selected]] array. [[i_phs_config]] is a lookup table that holds the PHS configuration index for a given component index. [[i_core]] is a lookup table that holds the core-entry index for a given component index. [[i_mci]] is a lookup table that holds the integrator (MCI) 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_workspace), deferred :: allocate_workspace <>= abstract interface subroutine pcm_allocate_workspace (pcm, work) import class(pcm_t), intent(in) :: pcm class(pcm_workspace_t), intent(inout), allocatable :: work end subroutine pcm_allocate_workspace end interface @ %def pcm_allocate_workspace @ <>= 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(inout) :: 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 workspace} This object deals with the actual (squared) matrix element values. It holds any central data that are generated and/or used when calculating a particular phase-space point. Since phase-space points are associated with an integrator, we expect the instances of this type to correspond to MCI instances. <>= public :: pcm_workspace_t <>= type, abstract :: pcm_workspace_t ! class(pcm_t), pointer :: config => null () logical :: bad_point = .false. contains <> end type pcm_workspace_t @ %def pcm_workspace_t @ <>= procedure(pcm_work_final), deferred :: final <>= abstract interface subroutine pcm_work_final (pcm_work) import class(pcm_workspace_t), intent(inout) :: pcm_work end subroutine pcm_work_final end interface @ %def pcm_work_final @ <>= procedure(pcm_work_is_nlo), deferred :: is_nlo <>= abstract interface function pcm_work_is_nlo (pcm_work) result (is_nlo) import logical :: is_nlo class(pcm_workspace_t), intent(inout) :: pcm_work end function pcm_work_is_nlo end interface @ %def pcm_work_is_nlo @ <>= procedure :: link_config => pcm_work_link_config <>= subroutine pcm_work_link_config (pcm_work, config) class(pcm_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in), target :: config pcm_work%config => config end subroutine pcm_work_link_config @ %def pcm_work_link_config @ <>= procedure :: is_valid => pcm_work_is_valid <>= function pcm_work_is_valid (pcm_work) result (valid) logical :: valid class(pcm_workspace_t), intent(in) :: pcm_work valid = .not. pcm_work%bad_point end function pcm_work_is_valid @ %def pcm_work_is_valid @ <>= procedure :: set_bad_point => pcm_work_set_bad_point <>= pure subroutine pcm_work_set_bad_point (pcm_work, bad_point) class(pcm_workspace_t), intent(inout) :: pcm_work logical, intent(in) :: bad_point pcm_work%bad_point = pcm_work%bad_point .or. bad_point end subroutine pcm_work_set_bad_point @ %def pcm_work_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 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} NOTE: The description below represents the intended structure after refactoring and disentangling the FKS-NLO vs. LO algorithm dependencies. A [[process]] object is the internal representation of integration-run methods and data, as they are controlled by the user via a Sindarin script. The process object provides access to matrix elements (the actual ``process'' definitions that the user has provided before), it defines the separation into individually integrable components, and it manages phase-space construction, the actual integration over phase space, and the accumulation of results. As a workspace for individual sampling calls, we introduce an associated [[process_instance]] object type elsewhere. The [[process]] object contains data that either define the configuration or accumulate results from a complete integration pass. After successful phase-space integration, subsequent event generation is not actually represented by the [[process]] object. However, any event generation refers to an existing [[process]] object which represents a specific integration pass, and it uses a fresh [[process_instance]] workspace for calculations. 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 [[meta]] object describes the process globally. All contents become fixed when the object is initialized. Similarly, the [[env]] component captures the (Sindarin) environment at the point where the process object is initialized. The [[config]] object holds physical and technical configuration data that are collected and derived from the environment during process initialization, and which are common to all process components. The [[pcm]] object (process-component manager) is polymorphic. This is an object which holds data which represent the process-object structure and breakdown, and it contains the methods that implement the algorithm of managing this structure, accumulating partial results, and finally collecting the pieces. Depending on the generic process type, the contents of [[pcm]] do vary. In particular, there is some base-type data content and a simple (default) extension which is designed for traditional \oMega\ matrix elements and tree-level integration, possibly with several sub-processes to sum over. The second extension is designed for the FKS phase-space and subtraction algorithm for NLO QCD, which interfaces external one-loop providers. The [[component]] subobjects are, first of all, interfaces to the original process-component definitions that have been provided by the user, which the program has already taken to produce matrix-element code and interfaces. The management of those components is deferred by [[pcm]], which contains the information that defines the role of each component. In particular, in the default (LO) version, process components correspond to distinct particle combinations which have been included in the original process definition. In the FKS-NLO version, the breakdown of a NLO process into Born, real, virtual, etc.\ components determines the setup. The [[phs_config]] subobjects hold data that allow and implement the construction of phase-space configurations. The type [[process_phs_config_t]] is a wrapper type around the concrete polymorphic [[phs_config_t]] object type, which manages phase-space construction, including some bookkeeping required for setting up multi-channel integration. In the LO case, we expect a separate entry for each independent sub-process. For the FKS-NLO algorithm, we expect several entries: a default-type entry which implements the underlying Born phase space, and additional entries which enable the construction of various real-radiation and subtraction kinematics configurations. A [[core_entry]] is the interface to existing matrix-element and interaction code. Depending on the process and its components, there may be various distinct matrix elements to compute. The [[mci_entry]] objects configure distinct MC input parameter sets and their associated (multi-channel) integrators. The [[rng_factory]] object is a single objects which constructs individual random-number generators for various tasks, in a uniform and well-defined way. The [[beam_config]] object describes the incoming particles, either the decay mother or the scattering beams. It also contains the spectrum- and structure-function setup, which has to interact with the phase-space and integrator facilities. The [[term]] subobjects break down the process in its smallest parts which appear in the calculation. For LO processes, the correspondence between terms and components is one-to-one. The FKS-NLO algorithm requires not just separation of Born, real, and virtual components but also subtraction terms, and a decomposition of the real phase space into singular regions. The general idea is that the integration results of distinct sets of terms are summed over to provide the results of individual components. This is also controlled by the [[pcm]] subobject. The [[process_status]] object is a bookkeeping device that allows us to query the status of an ongoing calculation. The [[process_results]] object collects the integration results for external use, including integration history information. <>= 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 wk 2018: The default could be to show everything, and we should have separate switches for all major parts. Currently, there are only a few. <>= ! generic :: write (formatted) => write_formatted procedure :: write_formatted => process_write_formatted <>= subroutine process_write_formatted (dtv, unit, iotype, v_list, iostat, iomsg) class(process_t), intent(in) :: dtv integer, intent(in) :: unit character(*), intent(in) :: iotype integer, dimension(:), intent(in) :: v_list integer, intent(out) :: iostat character(*), intent(inout) :: iomsg integer :: u logical :: screen logical :: var_list logical :: rng_factory logical :: expressions logical :: counters logical :: os_data logical :: model logical :: pacify integer :: i u = unit select case (iotype) case ("LISTDIRECTED") screen = .true. case default screen = .false. end select var_list = flagged (v_list, F_SHOW_VAR_LIST) rng_factory = flagged (v_list, F_SHOW_RNG, .true.) expressions = flagged (v_list, F_SHOW_EXPRESSIONS) counters = .true. os_data = flagged (v_list, F_SHOW_OS_DATA) model = .false. pacify = flagged (v_list, F_PACIFY) associate (process => dtv) if (screen) then write (msg_buffer, "(A)") repeat ("-", 72) call msg_message () else call write_separator (u, 2) end if call process%meta%write (u, screen) if (var_list) then call process%env%write (u, show_var_list=var_list, & show_model=.false., show_lib=.false., & show_os_data=os_data) else if (.not. screen) then write (u, "(1x,A)") "Variable list: [not shown]" end if if (process%meta%type == PRC_UNKNOWN) then call write_separator (u, 2) return else if (screen) then return end if call write_separator (u) call process%config%write (u, counters, model, expressions) if (rng_factory) then if (allocated (process%rng_factory)) then call write_separator (u) call process%rng_factory%write (u) end if end if call write_separator (u, 2) if (allocated (process%component)) then write (u, "(1x,A)") "Process component configuration:" do i = 1, size (process%component) call write_separator (u) call process%component(i)%write (u) end do else write (u, "(1x,A)") "Process component configuration: [undefined]" end if call write_separator (u, 2) if (allocated (process%term)) then write (u, "(1x,A)") "Process term configuration:" do i = 1, size (process%term) call write_separator (u) call process%term(i)%write (u) end do else write (u, "(1x,A)") "Process term configuration: [undefined]" end if call write_separator (u, 2) call process%beam_config%write (u) call write_separator (u, 2) if (allocated (process%mci_entry)) then write (u, "(1x,A)") "Multi-channel integrator configurations:" do i = 1, size (process%mci_entry) call write_separator (u) write (u, "(1x,A,I0,A)") "MCI #", i, ":" call process%mci_entry(i)%write (u, pacify) end do end if call write_separator (u, 2) end associate iostat = 0 iomsg = "" end subroutine process_write_formatted @ %def process_write_formatted @ <>= procedure :: write_meta => process_write_meta <>= subroutine process_write_meta (process, unit, testflag) class(process_t), intent(in) :: process integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u, i u = given_output_unit (unit) select case (process%meta%type) case (PRC_UNKNOWN) write (u, "(1x,A)") "Process instance [undefined]" return case (PRC_DECAY) write (u, "(1x,A)", advance="no") "Process instance [decay]:" case (PRC_SCATTERING) write (u, "(1x,A)", advance="no") "Process instance [scattering]:" case default call msg_bug ("process_instance_write: undefined process type") end select write (u, "(1x,A,A,A)") "'", char (process%meta%id), "'" write (u, "(3x,A,A,A)") "Run ID = '", char (process%meta%run_id), "'" if (allocated (process%meta%component_id)) then write (u, "(3x,A)") "Process components:" do i = 1, size (process%meta%component_id) if (process%pcm%component_selected(i)) then write (u, "(3x,'*')", advance="no") else write (u, "(4x)", advance="no") end if write (u, "(1x,I0,9A)") i, ": '", & char (process%meta%component_id (i)), "': ", & char (process%meta%component_description (i)) end do end if end subroutine process_write_meta @ %def process_write_meta @ Screen output. Write a short account of the process configuration and the current results. The verbose version lists the components, the short version just the results. <>= procedure :: show => process_show <>= subroutine process_show (object, unit, verbose) class(process_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u logical :: verb real(default) :: err_percent u = given_output_unit (unit) verb = .true.; if (present (verbose)) verb = verbose if (verb) then call object%meta%show (u, object%config%model%get_name ()) select case (object%meta%type) case (PRC_DECAY) write (u, "(2x,A)", advance="no") "Computed width =" case (PRC_SCATTERING) write (u, "(2x,A)", advance="no") "Computed cross section =" case default; return end select else if (object%meta%run_id /= "") then write (u, "('Run',1x,A,':',1x)", advance="no") & char (object%meta%run_id) end if write (u, "(A)", advance="no") char (object%meta%id) select case (object%meta%num_id) case (0) write (u, "(':')") case default write (u, "(1x,'(',I0,')',':')") object%meta%num_id end select write (u, "(2x)", advance="no") end if if (object%has_integral_tot ()) then write (u, "(ES14.7,1x,'+-',ES9.2)", advance="no") & object%get_integral_tot (), object%get_error_tot () select case (object%meta%type) case (PRC_DECAY) write (u, "(1x,A)", advance="no") "GeV" case (PRC_SCATTERING) write (u, "(1x,A)", advance="no") "fb " case default write (u, "(1x,A)", advance="no") " " end select if (object%get_integral_tot () /= 0) then err_percent = abs (100 & * object%get_error_tot () / object%get_integral_tot ()) else err_percent = 0 end if if (err_percent == 0) then write (u, "(1x,'(',F4.0,4x,'%)')") err_percent else if (err_percent < 0.1) then write (u, "(1x,'(',F7.3,1x,'%)')") err_percent else if (err_percent < 1) then write (u, "(1x,'(',F6.2,2x,'%)')") err_percent else if (err_percent < 10) then write (u, "(1x,'(',F5.1,3x,'%)')") err_percent else write (u, "(1x,'(',F4.0,4x,'%)')") err_percent end if else write (u, "(A)") "[integral undefined]" end if end subroutine process_show @ %def process_show @ Finalizer. Explicitly iterate over all subobjects that may contain allocated pointers. TODO wk 2018 (workaround): The finalizer for the [[config_data]] component is not called. The reason is that this deletes model data local to the process, but these could be referenced by pointers (flavor objects) from some persistent event record. Obviously, such side effects should be avoided, but this requires refactoring the event-handling procedures. <>= procedure :: final => process_final <>= subroutine process_final (process) class(process_t), intent(inout) :: process integer :: i ! call process%meta%final () call process%env%final () ! call process%config%final () if (allocated (process%component)) then do i = 1, size (process%component) call process%component(i)%final () end do end if if (allocated (process%term)) then do i = 1, size (process%term) call process%term(i)%final () end do end if call process%beam_config%final () if (allocated (process%mci_entry)) then do i = 1, size (process%mci_entry) call process%mci_entry(i)%final () end do end if if (allocated (process%pcm)) then call process%pcm%final () deallocate (process%pcm) end if end subroutine process_final @ %def process_final @ \subsubsection{Process setup} Initialize a process. We need a process library [[lib]] and the process identifier [[proc_id]] (string). We will fetch the current run ID from the variable list [[var_list]]. We collect all important data from the environment and store them in the appropriate places. OS data, model, and variable list are copied into [[env]] (true snapshot), also the process library (pointer only). The [[meta]] subobject is initialized with process ID and attributes taken from the process library. We initialize the [[config]] subobject with all data that are relevant for this run, using the settings from [[env]]. These data determine the MD5 sum for this run, which allows us to identify the setup and possibly skips in a later re-run. We also allocate and initialize the embedded RNG factory. We take the seed from the [[var_list]], and we should return the [[var_list]] to the caller with a new seed. Finally, we allocate the process component manager [[pcm]], which implements the chosen algorithm for process integration. The first task of the manager is to allocate the component array and to determine the component categories (e.g., Born/Virtual etc.). TODO wk 2018: The [[pcm]] dispatcher should be provided by the caller, if we eventually want to eliminate dependencies on concrete [[pcm_t]] extensions. <>= procedure :: init => process_init <>= subroutine process_init & (process, proc_id, lib, os_data, model, var_list, beam_structure) class(process_t), intent(out) :: process type(string_t), intent(in) :: proc_id type(process_library_t), intent(in), target :: lib type(os_data_t), intent(in) :: os_data class(model_t), intent(in), target :: model type(var_list_t), intent(inout), target, optional :: var_list type(beam_structure_t), intent(in), optional :: beam_structure integer :: next_rng_seed if (debug_on) 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 wk 2018: Eventually, we may eliminate all references to the extensions of [[pcm_t]] from this module and therefore move this outside the module as well. <>= subroutine dispatch_pcm (pcm, is_nlo) class(pcm_t), allocatable, intent(out) :: pcm logical, intent(in) :: is_nlo if (.not. is_nlo) then allocate (pcm_default_t :: pcm) else allocate (pcm_nlo_t :: pcm) end if end subroutine dispatch_pcm @ %def dispatch_pcm @ This step is performed after phase-space and core objects are done: collect all missing information and prepare the process component manager for the appropriate integration algorithm. <>= procedure :: complete_pcm_setup => process_complete_pcm_setup <>= subroutine process_complete_pcm_setup (process) class(process_t), intent(inout) :: process call process%pcm%complete_setup & (process%core_entry, process%component, process%env%get_model_ptr ()) end subroutine process_complete_pcm_setup @ %def process_complete_pcm_setup @ \subsection{Core management} Allocate cores (interface objects to matrix-element code). The [[dispatch_core]] procedure is taken as an argument, so we do not depend on the implementation, and thus on the specific core types. The [[helicity_selection]] object collects data that the matrix-element code needs for configuring the appropriate behavior. After the cores have been allocated, and assuming the phs initial configuration has been done before, we proceed with computing the [[pcm]] internal data. <>= procedure :: setup_cores => process_setup_cores <>= subroutine process_setup_cores (process, dispatch_core, & helicity_selection, use_color_factors, has_beam_pol) class(process_t), intent(inout) :: process procedure(dispatch_core_proc) :: dispatch_core type(helicity_selection_t), intent(in), optional :: helicity_selection logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol integer :: i associate (pcm => process%pcm) call pcm%allocate_cores (process%config, process%core_entry) do i = 1, size (process%core_entry) call dispatch_core (process%core_entry(i)%core, & process%core_entry(i)%core_def, & process%config%model, & helicity_selection, & process%config%qcd, & use_color_factors, & has_beam_pol) call process%core_entry(i)%configure & (process%env%get_lib_ptr (), process%meta%id) if (process%core_entry(i)%core%uses_blha ()) then call pcm%setup_blha (process%core_entry(i)) end if end do end associate end subroutine process_setup_cores @ %def process_setup_cores <>= abstract interface subroutine dispatch_core_proc (core, core_def, model, & helicity_selection, qcd, use_color_factors, has_beam_pol) import class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_def_t), intent(in) :: core_def class(model_data_t), intent(in), target, optional :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol end subroutine dispatch_core_proc end interface @ %def dispatch_core_proc @ Use the [[pcm]] to initialize the BLHA interface for each core which requires it. <>= procedure :: prepare_blha_cores => process_prepare_blha_cores <>= subroutine process_prepare_blha_cores (process) class(process_t), intent(inout), target :: process integer :: i associate (pcm => process%pcm) do i = 1, size (process%core_entry) associate (core_entry => process%core_entry(i)) if (core_entry%core%uses_blha ()) then pcm%uses_blha = .true. call pcm%prepare_blha_core (core_entry, process%config%model) end if end associate end do end associate end subroutine process_prepare_blha_cores @ %def process_prepare_blha_cores @ Create the BLHA interface data, using PCM for specific data, and write the BLHA contract file(s). We take various configuration data and copy them to the [[blha_master]] record, which then creates and writes the contracts. For assigning the QCD/EW 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(inout) :: process integer :: alpha_power, alphas_power integer :: openloops_phs_tolerance, openloops_stability_log logical :: use_cms 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, & 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%set_photon_characteristics (flv_born, process%config%n_in) 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")) 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 select type (pcm => process%pcm) type is (pcm_nlo_t) if (pcm%use_real_partition .and. .not. pcm%use_real_singular) then if (pcm%component_type(i) == COMP_REAL_SING) then active = .false. end if end if end select 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 () if (debug_on) 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%get_n_emitters_sc () 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_in%get_length () == 1) .and. & all (pdg_in(1,:) == pdg_in(1,i0)) .and. & all (pdg_in(2,:) == pdg_in(2,i0))) then pdg_scattering(:) = pdg_in(:,i0)%get (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_in%get_length () == 1) & .and. all (pdg_in(1,:) == pdg_in(1,i0))) then pdg_decay(:) = pdg_in(:,i0)%get (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 @ Set up index mapping for [[region_data]] for singular regions equivalent w.r.t. their amplitudes. Has to be called after [[region_data]] AND the [[core]] are fully set up. For processes with structure function, subprocesses which lead to the same amplitude for the hard interaction can differ if structure functions are applied. In this case we remap flavor structures to themselves if the eqvivalent hard interaction flavor structure has no identical initial state. <>= procedure :: optimize_nlo_singular_regions => process_optimize_nlo_singular_regions <>= subroutine process_optimize_nlo_singular_regions (process) class(process_t), intent(inout) :: process class(prc_core_t), pointer :: core, core_sub integer, dimension(:), allocatable :: eqv_flv_index_born integer, dimension(:), allocatable :: eqv_flv_index_real integer, dimension(:,:), allocatable :: flv_born, flv_real integer :: i_flv, i_flv2, n_in, i integer :: i_component, i_core, i_core_sub logical :: fetched_born, fetched_real logical :: optimize fetched_born = .false.; fetched_real = .false. select type (pcm => process%pcm) type is (pcm_nlo_t) optimize = pcm%settings%reuse_amplitudes_fks if (optimize) then do i_component = 1, pcm%n_components i_core = pcm%get_i_core(i_component) core => process%get_core_ptr (i_core) if (.not. core%data_known) cycle associate (data => core%data) if (pcm%nlo_type_core(i_core) == NLO_REAL .and. & .not. pcm%component_type(i_component) == COMP_SUB) then if (allocated (core%data%eqv_flv_index)) then eqv_flv_index_real = core%get_equivalent_flv_index () fetched_real = .true. end if i_core_sub = pcm%get_i_core (pcm%i_sub) core_sub => process%get_core_ptr (i_core_sub) if (allocated (core_sub%data%eqv_flv_index)) then eqv_flv_index_born = core_sub%get_equivalent_flv_index () fetched_born = .true. end if if (fetched_born .and. fetched_real) exit end if end associate end do if (.not. fetched_born .or. .not. fetched_real) then call msg_warning('Failed to fetch flavor equivalence indices. & &Disabling singular region optimization') optimize = .false. eqv_flv_index_born = [(i, i = 1, pcm%region_data%n_flv_born)] eqv_flv_index_real = [(i, i = 1, pcm%region_data%n_flv_real)] end if if (optimize .and. pcm%has_pdfs) then flv_born = pcm%region_data%get_flv_states_born () flv_real = pcm%region_data%get_flv_states_real () n_in = pcm%region_data%n_in do i_flv = 1, size (eqv_flv_index_born) do i_flv2 = 1, i_flv if (any (flv_born(1:n_in, eqv_flv_index_born(i_flv)) /= & flv_born(1:n_in, i_flv))) then eqv_flv_index_born(i_flv) = i_flv exit end if end do end do do i_flv = 1, size (eqv_flv_index_real) do i_flv2 = 1, i_flv if (any (flv_real(1:n_in, eqv_flv_index_real(i_flv)) /= & flv_real(1:n_in, i_flv))) then eqv_flv_index_real(i_flv) = i_flv exit end if end do end do end if else eqv_flv_index_born = [(i, i = 1, pcm%region_data%n_flv_born)] eqv_flv_index_real = [(i, i = 1, pcm%region_data%n_flv_real)] end if pcm%region_data%eqv_flv_index_born = eqv_flv_index_born pcm%region_data%eqv_flv_index_real = eqv_flv_index_real call pcm%region_data%find_eqv_regions (optimize) end select end subroutine process_optimize_nlo_singular_regions @ %def process_optimize_nlo_singular_regions @ 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, nlo_type 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) nlo_type = component%config%get_nlo_type () select case (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 if (combined_integration) then select type (phs_config => component%phs_config) class is (phs_wood_config_t) phs_config%is_combined_integration = .true. 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 if (debug_on) 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 and not if a combined integration of all components together has been performed. <>= 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 (.not. pcm%settings%combined_integration .and. & 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 NLO and the LO result $\iota = I_{NLO} / I_{LO}$. 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, i_component real(default) :: int_born, int_nlo int_nlo = zero int_born = process%mci_entry(1)%get_integral () i_mci = 2 do i_component = 2, size (process%component) if (process%component_can_be_integrated (i_component)) then int_nlo = int_nlo + process%mci_entry(i_mci)%get_integral () i_mci = i_mci + 1 end if 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, i_component sum_int_nlo = zero; err2 = zero int_born = process%mci_entry(1)%get_integral () err_born = process%mci_entry(1)%get_error () i_mci = 2 do i_component = 2, size (process%component) if (process%component_can_be_integrated (i_component)) then sum_int_nlo = sum_int_nlo + process%mci_entry(i_mci)%get_integral () err2 = err2 + process%mci_entry(i_mci)%get_error()**2 i_mci = i_mci + 1 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 => process_lab_is_cm <>= pure function process_lab_is_cm (process) result (lab_is_cm) logical :: lab_is_cm class(process_t), intent(in) :: process lab_is_cm = process%beam_config%lab_is_cm ! This asks beam_config for the frame end function process_lab_is_cm @ %def process_lab_is_cm @ <>= 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 :: get_i_core => process_get_i_core <>= integer function process_get_i_core (process, i_term) result (i_core) class(process_t), intent(in) :: process integer, intent(in) :: i_term i_core = process%term(i_term)%i_core end function process_get_i_core @ %def process_get_i_core @ <>= 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 wk 2018: should not depend explicitly on NLO data. <>= procedure :: get_md5sum_constants => process_get_md5sum_constants <>= function process_get_md5sum_constants (process, i_component, & type_string, nlo_type) result (this_md5sum) character(32) :: this_md5sum class(process_t), intent(in) :: process integer, intent(in) :: i_component type(string_t), intent(in) :: type_string integer, intent(in) :: nlo_type type(process_constants_t) :: data integer :: unit call process%env%fill_process_constants (process%meta%id, i_component, data) unit = data%fill_unit_for_md5sum (.false.) write (unit, '(A)') char(type_string) select case (nlo_type) case (NLO_MISMATCH) write (unit, '(I0)') NLO_SUBTRACTION case default write (unit, '(I0)') nlo_type end select rewind (unit) this_md5sum = md5sum (unit) close (unit) end function process_get_md5sum_constants @ %def process_get_md5sum_constants @ Return the set of outgoing flavors that are associated with a particular term. We deduce this from the effective interaction. <>= procedure :: get_term_flv_out => process_get_term_flv_out <>= subroutine process_get_term_flv_out (process, i_term, flv) class(process_t), intent(in), target :: process integer, intent(in) :: i_term type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv type(interaction_t), pointer :: int int => process%term(i_term)%int_eff if (.not. associated (int)) int => process%term(i_term)%int - call interaction_get_flv_out (int, flv) + call int%get_flv_out (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 lab-frame beam energy/energies.. <>= procedure :: get_energy => process_get_energy <>= function process_get_energy (process) result (e) class(process_t), intent(in) :: process real(default), dimension(:), allocatable :: e e = process%beam_config%data%get_energy () end function process_get_energy @ %def process_get_energy @ 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(process%beam_config%data%n) :: 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 @ 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 wk 2018: This is used only by event initialization, which deals with an incomplete process object. <>= procedure :: init_nlo_settings => process_init_nlo_settings <>= subroutine process_init_nlo_settings (process, var_list) class(process_t), intent(inout) :: process type(var_list_t), intent(in), target :: var_list select type (pcm => process%pcm) type is (pcm_nlo_t) call pcm%init_nlo_settings (var_list) if (debug_active (D_SUBTRACTION) .or. debug_active (D_VIRTUAL)) & call pcm%settings%write () class default call msg_fatal ("Attempt to set nlo_settings with a non-NLO pcm!") end select end subroutine process_init_nlo_settings @ %def process_init_nlo_settings @ <>= generic :: get_nlo_type_component => get_nlo_type_component_single procedure :: get_nlo_type_component_single => process_get_nlo_type_component_single <>= elemental function process_get_nlo_type_component_single (process, i_component) result (val) integer :: val class(process_t), intent(in) :: process integer, intent(in) :: i_component val = process%component(i_component)%get_nlo_type () end function process_get_nlo_type_component_single @ %def process_get_nlo_type_component_single @ <>= generic :: get_nlo_type_component => get_nlo_type_component_all procedure :: get_nlo_type_component_all => process_get_nlo_type_component_all <>= pure function process_get_nlo_type_component_all (process) result (val) integer, dimension(:), allocatable :: val class(process_t), intent(in) :: process allocate (val (size (process%component))) val = process%component%get_nlo_type () end function process_get_nlo_type_component_all @ %def process_get_nlo_type_component_all @ <>= procedure :: is_nlo_calculation => process_is_nlo_calculation <>= function process_is_nlo_calculation (process) result (nlo) logical :: nlo class(process_t), intent(in) :: process select type (pcm => process%pcm) type is (pcm_nlo_t) nlo = .true. class default nlo = .false. end select end function process_is_nlo_calculation @ %def process_is_nlo_calculation @ <>= procedure :: get_negative_sf => process_get_negative_sf <>= function process_get_negative_sf (process) result (neg_sf) logical :: neg_sf class(process_t), intent(in) :: process neg_sf = process%config%process_def%get_negative_sf () end function process_get_negative_sf @ %def process_get_negative_sf @ <>= 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 if (debug_on) 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 does not 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]] 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 = .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 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 = beam_config%data%lab_is_cm 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 = beam_config%data%lab_is_cm 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, & lab_is_cm = beam_config%lab_is_cm .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 an 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 \to -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 .or. nlo_t == NLO_DGLAP 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 = 6 * 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 !!! necessary dummy, needs refactoring, !!! c.f. [[term_instance_evaluate_interaction_userdef_tree]] n_sub = n_sub + n_beams_rescaled 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 = .false. logical :: combined_integration = .false. integer :: real_partition_type = REAL_FULL 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 if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_mci_entry_create_component_list") if (mci_entry%combined_integration) then if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, & "mci_entry%real_partition_type", mci_entry%real_partition_type) n = get_n_components (mci_entry%real_partition_type) allocate (i_list (n)) 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 (real_partition_type) result (n_components) integer :: n_components integer, intent(in) :: real_partition_type select case (real_partition_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 if (debug_on) 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 @ 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 phs_points, only: assignment(=) 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_workspace => pcm_default_allocate_workspace <>= subroutine pcm_default_allocate_workspace (pcm, work) class(pcm_default_t), intent(in) :: pcm class(pcm_workspace_t), intent(inout), allocatable :: work allocate (pcm_default_workspace_t :: work) end subroutine pcm_default_allocate_workspace @ %def pcm_default_allocate_workspace @ 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_workspace_t) :: pcm_default_workspace_t contains <> end type pcm_default_workspace_t @ %def pcm_default_workspace_t @ <>= procedure :: final => pcm_default_workspace_final <>= subroutine pcm_default_workspace_final (pcm_work) class(pcm_default_workspace_t), intent(inout) :: pcm_work end subroutine pcm_default_workspace_final @ %def pcm_default_workspace_final @ <>= procedure :: is_nlo => pcm_default_workspace_is_nlo <>= function pcm_default_workspace_is_nlo (pcm_work) result (is_nlo) logical :: is_nlo class(pcm_default_workspace_t), intent(inout) :: pcm_work is_nlo = .false. end function pcm_default_workspace_is_nlo @ %def pcm_default_workspace_is_nlo @ \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 call core%set_equivalent_flv_hel_indices () 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(inout) :: 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. logical :: use_real_singular = .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')) select case (char (var_list%get_sval (var_str ("$real_partition_mode")))) case ("default", "off") pcm%use_real_partition = .false. pcm%use_real_singular = .false. case ("all", "on", "singular") pcm%use_real_partition = .true. pcm%use_real_singular = .true. case ("finite") pcm%use_real_partition = .true. pcm%use_real_singular = .false. case default call msg_fatal ("The real partition mode can only be " // & "default, off, all, on, singular or finite.") end select 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 wk 2018: this convention for real components can be improved. Check whether all component types should be assigned, not just for combined integration. <>= procedure :: categorize_components => pcm_nlo_categorize_components <>= subroutine pcm_nlo_categorize_components (pcm, config) class(pcm_nlo_t), intent(inout) :: pcm type(process_config_data_t), intent(in) :: config type(process_component_def_t), pointer :: component_def integer :: i allocate (pcm%nlo_type (pcm%n_components), source = COMPONENT_UNDEFINED) allocate (pcm%component_type (pcm%n_components), source = COMP_DEFAULT) do i = 1, pcm%n_components component_def => config%process_def%get_component_def_ptr (i) pcm%nlo_type(i) = component_def%get_nlo_type () if (pcm%combined_integration) then select case (pcm%nlo_type(i)) case (BORN) pcm%i_born = i pcm%component_type(i) = COMP_MASTER case (NLO_REAL) pcm%component_type(i) = COMP_REAL case (NLO_VIRTUAL) pcm%component_type(i) = COMP_VIRT case (NLO_MISMATCH) pcm%component_type(i) = COMP_MISMATCH case (NLO_DGLAP) pcm%component_type(i) = COMP_PDF case (NLO_SUBTRACTION) pcm%component_type(i) = COMP_SUB pcm%i_sub = i end select else select case (pcm%nlo_type(i)) case (BORN) pcm%i_born = i pcm%component_type(i) = COMP_MASTER case (NLO_REAL) pcm%component_type(i) = COMP_REAL case (NLO_VIRTUAL) pcm%component_type(i) = COMP_VIRT case (NLO_MISMATCH) pcm%component_type(i) = COMP_MISMATCH case (NLO_SUBTRACTION) pcm%i_sub = i end select end if end do call refine_real_type ( & pack ([(i, i=1, pcm%n_components)], & pcm%component_type==COMP_REAL)) contains subroutine refine_real_type (i_real) integer, dimension(:), intent(in) :: i_real pcm%i_real = i_real(1) if (pcm%use_real_partition) then pcm%component_type (i_real(1)) = COMP_REAL_SING pcm%component_type (i_real(2:)) = COMP_REAL_FIN end if end subroutine refine_real_type end subroutine pcm_nlo_categorize_components @ %def pcm_nlo_categorize_components @ \subsubsection{Phase-space initial configuration} Setup for the NLO/PHS processes: two phase-space configurations, (1) Born/wood, (2) real correction/FKS. All components use either one of these two configurations. TODO wk 2018: The [[first_real_component]] identifier is really ugly. Nothing should rely on the ordering. <>= procedure :: init_phs_config => pcm_nlo_init_phs_config <>= subroutine pcm_nlo_init_phs_config & (pcm, phs_entry, meta, env, phs_par, mapping_defs) class(pcm_nlo_t), intent(inout) :: pcm type(process_phs_config_t), & dimension(:), allocatable, intent(out) :: phs_entry type(process_metadata_t), intent(in) :: meta type(process_environment_t), intent(in) :: env type(mapping_defaults_t), intent(in) :: mapping_defs type(phs_parameters_t), intent(in) :: phs_par integer :: i logical :: first_real_component allocate (phs_entry (2)) call dispatch_phs (phs_entry(1)%phs_config, & env%get_var_list_ptr (), & env%get_os_data (), & meta%id, & mapping_defs, phs_par, & var_str ("wood")) call dispatch_phs (phs_entry(2)%phs_config, & env%get_var_list_ptr (), & env%get_os_data (), & meta%id, & mapping_defs, phs_par, & var_str ("fks")) allocate (pcm%i_phs_config (pcm%n_components), source=0) first_real_component = .true. do i = 1, pcm%n_components select case (pcm%nlo_type(i)) case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION) pcm%i_phs_config(i) = 1 case (NLO_REAL) if (pcm%use_real_partition) then if (pcm%use_real_singular) then if (first_real_component) then pcm%i_phs_config(i) = 2 first_real_component = .false. else pcm%i_phs_config(i) = 1 end if else pcm%i_phs_config(i) = 1 end if else pcm%i_phs_config(i) = 2 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 call core%set_equivalent_flv_hel_indices () 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 :: alpha_power, alphas_power call pcm%handle_threshold_core (core_entry) call component(1)%config%get_coupling_powers (alpha_power, alphas_power) call pcm%setup_region_data & (core_entry, component(pcm%i_real)%phs_config, model, alpha_power, alphas_power) 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(inout) :: 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) call pcm%blha_defaults%set_loop_method (blha_master) 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 wk 2018: check whether [[phs_entry]] needs to be intent(inout). <>= procedure :: setup_region_data => pcm_nlo_setup_region_data <>= subroutine pcm_nlo_setup_region_data & (pcm, core_entry, phs_config, model, alpha_power, alphas_power) 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 integer, intent(in) :: alpha_power, alphas_power 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, alpha_power, alphas_power) 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 wk 2018: the component type need not be stored in the component; we may remove this when everything is controlled by [[pcm]]. <>= procedure :: init_component => pcm_nlo_init_component <>= subroutine pcm_nlo_init_component & (pcm, component, i, active, & phs_config, env, meta, config) class(pcm_nlo_t), intent(in) :: pcm type(process_component_t), intent(out) :: component integer, intent(in) :: i logical, intent(in) :: active class(phs_config_t), allocatable, intent(in) :: phs_config type(process_environment_t), intent(in) :: env type(process_metadata_t), intent(in) :: meta type(process_config_data_t), intent(in) :: config logical :: activate select case (pcm%nlo_type(i)) case default; activate = active case (NLO_SUBTRACTION); activate = .false. end select call component%init (i, & env, meta, config, & activate, & phs_config) component%component_type = pcm%component_type(i) end subroutine pcm_nlo_init_component @ %def pcm_nlo_init_component @ Override the base method: record the active components in the PCM object, and report inactive components (except for the subtraction component). <>= procedure :: record_inactive_components => pcm_nlo_record_inactive_components <>= subroutine pcm_nlo_record_inactive_components (pcm, component, meta) class(pcm_nlo_t), intent(inout) :: pcm type(process_component_t), dimension(:), intent(in) :: component type(process_metadata_t), intent(inout) :: meta integer :: i pcm%component_active = component%active do i = 1, pcm%n_components select case (pcm%nlo_type(i)) case (NLO_SUBTRACTION) case default if (.not. component(i)%active) call meta%deactivate_component (i) end select end do end subroutine pcm_nlo_record_inactive_components @ %def pcm_nlo_record_inactive_components @ <>= procedure :: core_is_radiation => pcm_nlo_core_is_radiation <>= function pcm_nlo_core_is_radiation (pcm, i_core) result (is_rad) logical :: is_rad class(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_core is_rad = pcm%nlo_type(i_core) == NLO_REAL ! .and. .not. pcm%cm%sub(i_core) end function pcm_nlo_core_is_radiation @ %def pcm_nlo_core_is_radiation @ <>= procedure :: get_n_flv_born => pcm_nlo_get_n_flv_born <>= function pcm_nlo_get_n_flv_born (pcm_nlo) result (n_flv) integer :: n_flv class(pcm_nlo_t), intent(in) :: pcm_nlo n_flv = pcm_nlo%region_data%n_flv_born end function pcm_nlo_get_n_flv_born @ %def pcm_nlo_get_n_flv_born @ <>= procedure :: get_n_flv_real => pcm_nlo_get_n_flv_real <>= function pcm_nlo_get_n_flv_real (pcm_nlo) result (n_flv) integer :: n_flv class(pcm_nlo_t), intent(in) :: pcm_nlo n_flv = pcm_nlo%region_data%n_flv_real end function pcm_nlo_get_n_flv_real @ %def pcm_nlo_get_n_flv_real @ <>= procedure :: get_n_alr => pcm_nlo_get_n_alr <>= function pcm_nlo_get_n_alr (pcm) result (n_alr) integer :: n_alr class(pcm_nlo_t), intent(in) :: pcm n_alr = pcm%region_data%n_regions end function pcm_nlo_get_n_alr @ %def pcm_nlo_get_n_alr @ <>= procedure :: get_flv_states => pcm_nlo_get_flv_states <>= function pcm_nlo_get_flv_states (pcm, born) result (flv) integer, dimension(:,:), allocatable :: flv class(pcm_nlo_t), intent(in) :: pcm logical, intent(in) :: born if (born) then flv = pcm%region_data%get_flv_states_born () else flv = pcm%region_data%get_flv_states_real () end if end function pcm_nlo_get_flv_states @ %def pcm_nlo_get_flv_states @ <>= procedure :: get_qn => pcm_nlo_get_qn <>= function pcm_nlo_get_qn (pcm, born) result (qn) type(quantum_numbers_t), dimension(:,:), allocatable :: qn class(pcm_nlo_t), intent(in) :: pcm logical, intent(in) :: born if (born) then qn = pcm%qn_born else qn = pcm%qn_real end if end function pcm_nlo_get_qn @ %def pcm_nlo_get_qn @ Check if there are massive emitters. Since the mass-structure of all underlying Born configurations have to be the same (\textbf{This does not have to be the case when different components are generated at LO}) , we just use the first one to determine this. <>= procedure :: has_massive_emitter => pcm_nlo_has_massive_emitter <>= function pcm_nlo_has_massive_emitter (pcm) result (val) logical :: val class(pcm_nlo_t), intent(in) :: pcm integer :: i val = .false. associate (reg_data => pcm%region_data) do i = reg_data%n_in + 1, reg_data%n_legs_born if (any (i == reg_data%emitters)) & val = val .or. reg_data%flv_born(1)%massive(i) end do end associate end function pcm_nlo_has_massive_emitter @ %def pcm_nlo_has_massive_emitter @ Returns an array which specifies if the particle at position [[i]] is massive. <>= procedure :: get_mass_info => pcm_nlo_get_mass_info <>= function pcm_nlo_get_mass_info (pcm, i_flv) result (massive) class(pcm_nlo_t), intent(in) :: pcm integer, intent(in) :: i_flv logical, dimension(:), allocatable :: massive allocate (massive (size (pcm%region_data%flv_born(i_flv)%massive))) massive = pcm%region_data%flv_born(i_flv)%massive end function pcm_nlo_get_mass_info @ %def pcm_nlo_get_mass_info @ <>= procedure :: allocate_workspace => pcm_nlo_allocate_workspace <>= subroutine pcm_nlo_allocate_workspace (pcm, work) class(pcm_nlo_t), intent(in) :: pcm class(pcm_workspace_t), intent(inout), allocatable :: work allocate (pcm_nlo_workspace_t :: work) end subroutine pcm_nlo_allocate_workspace @ %def pcm_nlo_allocate_workspace @ <>= 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_work, generator, & sqrts, mode, singular_jacobian) class(pcm_nlo_t), intent(in) :: pcm type(phs_fks_generator_t), intent(inout) :: generator type(pcm_nlo_workspace_t), intent(in), target :: pcm_work 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_work%isr_kinematics, & pcm_work%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 call generator%set_xi_and_y_bounds (pcm%settings%fks_template%xi_min, & pcm%settings%fks_template%y_max) 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_nlo_workspace_t <>= type, extends (pcm_workspace_t) :: pcm_nlo_workspace_t 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_nlo_workspace_t @ %def pcm_nlo_workspace_t @ <>= procedure :: set_radiation_event => pcm_nlo_workspace_set_radiation_event procedure :: set_subtraction_event => pcm_nlo_workspace_set_subtraction_event <>= subroutine pcm_nlo_workspace_set_radiation_event (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work pcm_work%real_sub%radiation_event = .true. pcm_work%real_sub%subtraction_event = .false. end subroutine pcm_nlo_workspace_set_radiation_event subroutine pcm_nlo_workspace_set_subtraction_event (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work pcm_work%real_sub%radiation_event = .false. pcm_work%real_sub%subtraction_event = .true. end subroutine pcm_nlo_workspace_set_subtraction_event @ %def pcm_nlo_workspace_set_radiation_event @ %def pcm_nlo_workspace_set_subtraction_event <>= procedure :: disable_subtraction => pcm_nlo_workspace_disable_subtraction <>= subroutine pcm_nlo_workspace_disable_subtraction (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work pcm_work%real_sub%subtraction_deactivated = .true. end subroutine pcm_nlo_workspace_disable_subtraction @ %def pcm_nlo_workspace_disable_subtraction @ <>= procedure :: init_config => pcm_nlo_workspace_init_config <>= subroutine pcm_nlo_workspace_init_config (pcm_work, pcm, active_components, & nlo_types, energy, i_real_fin, model) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm logical, intent(in), dimension(:) :: active_components integer, intent(in), dimension(:) :: nlo_types real(default), intent(in), dimension(:) :: energy integer, intent(in) :: i_real_fin class(model_data_t), intent(in) :: model integer :: i_component if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "pcm_nlo_workspace_init_config") call pcm_work%init_real_and_isr_kinematics (pcm, energy) select type (pcm) 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_work%setup_real_component (pcm, & pcm%settings%fks_template%subtraction_disabled) end if case (NLO_VIRTUAL) call pcm_work%init_virtual (pcm, model) case (NLO_MISMATCH) call pcm_work%init_soft_mismatch (pcm) case (NLO_DGLAP) call pcm_work%init_dglap_remnant (pcm) end select end if end do end select end subroutine pcm_nlo_workspace_init_config @ %def pcm_nlo_workspace_init_config @ <>= procedure :: setup_real_component => pcm_nlo_workspace_setup_real_component <>= subroutine pcm_nlo_workspace_setup_real_component (pcm_work, pcm, & subtraction_disabled) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work class(pcm_t), intent(in) :: pcm logical, intent(in) :: subtraction_disabled select type (pcm) type is (pcm_nlo_t) call pcm_work%init_real_subtraction (pcm) if (subtraction_disabled) call pcm_work%disable_subtraction () end select end subroutine pcm_nlo_workspace_setup_real_component @ %def pcm_nlo_workspace_setup_real_component @ <>= procedure :: init_real_and_isr_kinematics => & pcm_nlo_workspace_init_real_and_isr_kinematics <>= subroutine pcm_nlo_workspace_init_real_and_isr_kinematics (pcm_work, pcm, energy) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm real(default), dimension(:), intent(in) :: energy integer :: n_contr allocate (pcm_work%real_kinematics) allocate (pcm_work%isr_kinematics) select type (pcm) type is (pcm_nlo_t) associate (region_data => pcm%region_data) if (allocated (region_data%alr_contributors)) then n_contr = size (region_data%alr_contributors) else if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then n_contr = 2 else n_contr = 1 end if call pcm_work%real_kinematics%init & (region_data%n_legs_real, region_data%n_phs, & region_data%n_regions, n_contr) if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) & call pcm_work%real_kinematics%init_onshell & (region_data%n_legs_real, region_data%n_phs) pcm_work%isr_kinematics%n_in = region_data%n_in end associate end select pcm_work%isr_kinematics%beam_energy = energy end subroutine pcm_nlo_workspace_init_real_and_isr_kinematics @ %def pcm_nlo_workspace_init_real_and_isr_kinematics @ <>= procedure :: set_real_and_isr_kinematics => & pcm_nlo_workspace_set_real_and_isr_kinematics <>= subroutine pcm_nlo_workspace_set_real_and_isr_kinematics (pcm_work, phs_identifiers, sqrts) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers real(default), intent(in) :: sqrts call pcm_work%real_sub%set_real_kinematics & (pcm_work%real_kinematics) call pcm_work%real_sub%set_isr_kinematics & (pcm_work%isr_kinematics) end subroutine pcm_nlo_workspace_set_real_and_isr_kinematics @ %def pcm_nlo_workspace_set_real_and_isr_kinematics @ <>= procedure :: init_real_subtraction => pcm_nlo_workspace_init_real_subtraction <>= subroutine pcm_nlo_workspace_init_real_subtraction (pcm_work, pcm) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work class(pcm_t), intent(in) :: pcm select type (pcm) type is (pcm_nlo_t) associate (region_data => pcm%region_data) call pcm_work%real_sub%init (region_data, pcm%settings) if (allocated (pcm%settings%selected_alr)) then associate (selected_alr => pcm%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_work%real_sub%selected_alr (size (selected_alr))) pcm_work%real_sub%selected_alr = selected_alr end if end associate end if end associate end select end subroutine pcm_nlo_workspace_init_real_subtraction @ %def pcm_nlo_workspace_init_real_subtraction @ <>= procedure :: set_momenta_and_scales_virtual => & pcm_nlo_workspace_set_momenta_and_scales_virtual <>= subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual (pcm_work, p, & ren_scale, fac_scale, es_scale) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work type(vector4_t), intent(in), dimension(:) :: p real(default), allocatable, intent(in) :: ren_scale real(default), intent(in) :: fac_scale real(default), allocatable, intent(in) :: es_scale associate (virtual => pcm_work%virtual) call virtual%set_ren_scale (ren_scale) call virtual%set_fac_scale (p, fac_scale) call virtual%set_ellis_sexton_scale (es_scale) end associate end subroutine pcm_nlo_workspace_set_momenta_and_scales_virtual @ %def pcm_nlo_workspace_set_momenta_and_scales_virtual @ <>= procedure :: set_fac_scale => pcm_nlo_workspace_set_fac_scale <>= subroutine pcm_nlo_workspace_set_fac_scale (pcm_work, fac_scale) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work real(default), intent(in) :: fac_scale pcm_work%isr_kinematics%fac_scale = fac_scale end subroutine pcm_nlo_workspace_set_fac_scale @ %def pcm_nlo_workspace_set_fac_scale @ <>= procedure :: set_momenta => pcm_nlo_workspace_set_momenta <>= subroutine pcm_nlo_workspace_set_momenta (pcm_work, p_born, p_real, i_phs, cms) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work 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_work%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_born kinematics%p_real_cms%phs_point(i_phs) = 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_born kinematics%p_real_lab%phs_point(i_phs) = p_real end if end associate end subroutine pcm_nlo_workspace_set_momenta @ %def pcm_nlo_workspace_set_momenta @ <>= procedure :: get_momenta => pcm_nlo_workspace_get_momenta <>= function pcm_nlo_workspace_get_momenta (pcm_work, pcm, & i_phs, born_phsp, cms) result (p) type(vector4_t), dimension(:), allocatable :: p class(pcm_nlo_workspace_t), intent(in) :: pcm_work class(pcm_t), intent(in) :: pcm 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 (pcm) type is (pcm_nlo_t) if (born_phsp) then if (yorn) then p = pcm_work%real_kinematics%p_born_cms%phs_point(1) else p =pcm_work%real_kinematics%p_born_lab%phs_point(1) end if else if (yorn) then p = pcm_work%real_kinematics%p_real_cms%phs_point(i_phs) else p = pcm_work%real_kinematics%p_real_lab%phs_point(i_phs) end if end if end select end function pcm_nlo_workspace_get_momenta @ %def pcm_nlo_workspace_get_momenta @ <>= procedure :: get_xi_max => pcm_nlo_workspace_get_xi_max <>= function pcm_nlo_workspace_get_xi_max (pcm_work, alr) result (xi_max) real(default) :: xi_max class(pcm_nlo_workspace_t), intent(in) :: pcm_work integer, intent(in) :: alr integer :: i_phs i_phs = pcm_work%real_kinematics%alr_to_i_phs (alr) xi_max = pcm_work%real_kinematics%xi_max (i_phs) end function pcm_nlo_workspace_get_xi_max @ %def pcm_nlo_workspace_get_xi_max @ <>= procedure :: set_x_rad => pcm_nlo_workspace_set_x_rad <>= subroutine pcm_nlo_workspace_set_x_rad (pcm_work, x_tot) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work real(default), intent(in), dimension(:) :: x_tot integer :: n_par n_par = size (x_tot) if (n_par < 3) then pcm_work%real_kinematics%x_rad = zero else pcm_work%real_kinematics%x_rad = x_tot (n_par - 2 : n_par) end if end subroutine pcm_nlo_workspace_set_x_rad @ %def pcm_nlo_workspace_set_x_rad @ <>= procedure :: init_virtual => pcm_nlo_workspace_init_virtual <>= subroutine pcm_nlo_workspace_init_virtual (pcm_work, pcm, model) class(pcm_nlo_workspace_t), intent(inout), target :: pcm_work class(pcm_t), intent(in) :: pcm class(model_data_t), intent(in) :: model select type (pcm) type is (pcm_nlo_t) associate (region_data => pcm%region_data) call pcm_work%virtual%init (region_data%get_flv_states_born (), & region_data%n_in, pcm%settings, model, pcm%has_pdfs) end associate end select end subroutine pcm_nlo_workspace_init_virtual @ %def pcm_nlo_workspace_init_virtual @ <>= procedure :: disable_virtual_subtraction => pcm_nlo_workspace_disable_virtual_subtraction <>= subroutine pcm_nlo_workspace_disable_virtual_subtraction (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work end subroutine pcm_nlo_workspace_disable_virtual_subtraction @ %def pcm_nlo_workspace_disable_virtual_subtraction @ <>= procedure :: compute_sqme_virt => pcm_nlo_workspace_compute_sqme_virt <>= subroutine pcm_nlo_workspace_compute_sqme_virt (pcm_work, pcm, p, & alpha_coupling, separate_uborns, sqme_virt) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm type(vector4_t), intent(in), dimension(:) :: p real(default), dimension(2), intent(in) :: alpha_coupling logical, intent(in) :: separate_uborns real(default), dimension(:), allocatable, intent(inout) :: sqme_virt type(vector4_t), dimension(:), allocatable :: pp associate (virtual => pcm_work%virtual) allocate (pp (size (p))) if (virtual%settings%factorization_mode == FACTORIZATION_THRESHOLD) then pp = pcm_work%real_kinematics%p_born_onshell%get_momenta (1) else pp = p end if select type (pcm) type is (pcm_nlo_t) if (separate_uborns) then allocate (sqme_virt (pcm%get_n_flv_born ())) else allocate (sqme_virt (1)) end if sqme_virt = zero call virtual%evaluate (pcm%region_data, & alpha_coupling, pp, separate_uborns, sqme_virt) end select end associate end subroutine pcm_nlo_workspace_compute_sqme_virt @ %def pcm_nlo_workspace_compute_sqme_virt @ <>= procedure :: compute_sqme_mismatch => pcm_nlo_workspace_compute_sqme_mismatch <>= subroutine pcm_nlo_workspace_compute_sqme_mismatch (pcm_work, pcm, & alpha_s, separate_uborns, sqme_mism) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm real(default), intent(in) :: alpha_s logical, intent(in) :: separate_uborns real(default), dimension(:), allocatable, intent(inout) :: sqme_mism select type (pcm) type is (pcm_nlo_t) if (separate_uborns) then allocate (sqme_mism (pcm%get_n_flv_born ())) else allocate (sqme_mism (1)) end if sqme_mism = zero sqme_mism = pcm_work%soft_mismatch%evaluate (alpha_s) end select end subroutine pcm_nlo_workspace_compute_sqme_mismatch @ %def pcm_nlo_workspace_compute_sqme_mismatch @ <>= procedure :: compute_sqme_dglap_remnant => pcm_nlo_workspace_compute_sqme_dglap_remnant <>= subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant (pcm_work, pcm, & alpha_coupling, separate_uborns, sqme_dglap) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm real(default), dimension(2), intent(in) :: alpha_coupling logical, intent(in) :: separate_uborns real(default), dimension(:), allocatable, intent(inout) :: sqme_dglap select type (pcm) type is (pcm_nlo_t) if (separate_uborns) then allocate (sqme_dglap (pcm%get_n_flv_born ())) else allocate (sqme_dglap (1)) end if end select sqme_dglap = zero call pcm_work%dglap_remnant%evaluate (alpha_coupling, separate_uborns, sqme_dglap) end subroutine pcm_nlo_workspace_compute_sqme_dglap_remnant @ %def pcm_nlo_workspace_compute_sqme_dglap_remnant @ <>= procedure :: set_fixed_order_event_mode => pcm_nlo_workspace_set_fixed_order_event_mode <>= subroutine pcm_nlo_workspace_set_fixed_order_event_mode (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work pcm_work%real_sub%purpose = FIXED_ORDER_EVENTS end subroutine pcm_nlo_workspace_set_fixed_order_event_mode <>= procedure :: set_powheg_mode => pcm_nlo_workspace_set_powheg_mode <>= subroutine pcm_nlo_workspace_set_powheg_mode (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work pcm_work%real_sub%purpose = POWHEG end subroutine pcm_nlo_workspace_set_powheg_mode @ %def pcm_nlo_workspace_set_fixed_order_event_mode @ %def pcm_nlo_workspace_set_powheg_mode @ <>= procedure :: init_soft_mismatch => pcm_nlo_workspace_init_soft_mismatch <>= subroutine pcm_nlo_workspace_init_soft_mismatch (pcm_work, pcm) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm select type (pcm) type is (pcm_nlo_t) call pcm_work%soft_mismatch%init (pcm%region_data, & pcm_work%real_kinematics, pcm%settings%factorization_mode) end select end subroutine pcm_nlo_workspace_init_soft_mismatch @ %def pcm_nlo_workspace_init_soft_mismatch @ <>= procedure :: init_dglap_remnant => pcm_nlo_workspace_init_dglap_remnant <>= subroutine pcm_nlo_workspace_init_dglap_remnant (pcm_work, pcm) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work class(pcm_t), intent(in) :: pcm select type (pcm) type is (pcm_nlo_t) call pcm_work%dglap_remnant%init ( & pcm%settings, & pcm%region_data, & pcm_work%isr_kinematics) end select end subroutine pcm_nlo_workspace_init_dglap_remnant @ %def pcm_nlo_workspace_init_dglap_remnant @ <>= procedure :: is_fixed_order_nlo_events & => pcm_nlo_workspace_is_fixed_order_nlo_events <>= function pcm_nlo_workspace_is_fixed_order_nlo_events (pcm_work) result (is_fnlo) logical :: is_fnlo class(pcm_nlo_workspace_t), intent(in) :: pcm_work is_fnlo = pcm_work%real_sub%purpose == FIXED_ORDER_EVENTS end function pcm_nlo_workspace_is_fixed_order_nlo_events @ %def pcm_nlo_workspace_is_fixed_order_nlo_events @ <>= procedure :: final => pcm_nlo_workspace_final <>= subroutine pcm_nlo_workspace_final (pcm_work) class(pcm_nlo_workspace_t), intent(inout) :: pcm_work call pcm_work%real_sub%final () call pcm_work%virtual%final () call pcm_work%soft_mismatch%final () call pcm_work%dglap_remnant%final () if (associated (pcm_work%real_kinematics)) then call pcm_work%real_kinematics%final () nullify (pcm_work%real_kinematics) end if if (associated (pcm_work%isr_kinematics)) then nullify (pcm_work%isr_kinematics) end if end subroutine pcm_nlo_workspace_final @ %def pcm_nlo_workspace_final @ <>= procedure :: is_nlo => pcm_nlo_workspace_is_nlo <>= function pcm_nlo_workspace_is_nlo (pcm_work) result (is_nlo) logical :: is_nlo class(pcm_nlo_workspace_t), intent(inout) :: pcm_work is_nlo = .true. end function pcm_nlo_workspace_is_nlo @ %def pcm_nlo_workspace_is_nlo @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \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 phs_points, only: assignment(=), size 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_base, only: pcm_t, pcm_workspace_t use pcm, only: pcm_nlo_t, pcm_nlo_workspace_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 @ Configure the kinematics object. This consists of several configuration steps which correspond to individual procedures. In essence, we configure the structure-function part, the partonic phase-space part, and various NLO items. TODO wk 19-03-01: This includes some region-data setup within [[pcm]], hence [[pcm]] is intent(inout). This should be moved elsewhere, so [[pcm]] can become strictly intent(in). <>= procedure :: configure => kinematics_configure <>= subroutine kinematics_configure (kin, pcm, pcm_work, & sf_chain, beam_config, phs_config, nlo_type, is_i_sub) class(kinematics_t), intent(out) :: kin class(pcm_t), intent(inout) :: pcm class(pcm_workspace_t), intent(in) :: pcm_work 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 integer, intent(in) :: nlo_type logical, intent(in) :: is_i_sub logical :: extended_sf extended_sf = nlo_type == NLO_DGLAP .or. (nlo_type == NLO_REAL .and. is_i_sub) call kin%init_sf_chain (sf_chain, beam_config, & extended_sf = pcm%has_pdfs .and. extended_sf) !!! Add one for additional Born matrix element call kin%init_phs (phs_config) call kin%set_nlo_info (nlo_type) select type (phs => kin%phs) type is (phs_fks_t) call phs%allocate_momenta (phs_config, .not. (nlo_type == NLO_REAL)) select type (pcm) type is (pcm_nlo_t) call pcm%region_data%init_phs_identifiers (phs%phs_identifiers) !!! The triple select type pyramid of doom select type (pcm_work) type is (pcm_nlo_workspace_t) if (allocated (pcm_work%real_kinematics%alr_to_i_phs)) & call pcm%region_data%set_alr_to_i_phs (phs%phs_identifiers, & pcm_work%real_kinematics%alr_to_i_phs) end select end select end select end subroutine kinematics_configure @ %def kinematics_configure @ 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 @ <>= procedure :: set_threshold => kinematics_set_threshold <>= subroutine kinematics_set_threshold (kin, factorization_mode) class(kinematics_t), intent(inout) :: kin integer, intent(in) :: factorization_mode kin%threshold = factorization_mode == FACTORIZATION_THRESHOLD end subroutine kinematics_set_threshold @ %def kinematics_set_threshold @ 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) if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) then call phs%generate_radiation_variables & (r_in(phs%n_r_born + 1 : phs%n_r_born + 3), threshold = k%threshold) call phs%compute_cms_energy () end if end select end subroutine kinematics_evaluate_radiation_kinematics @ %def kinematics_evaluate_radiation_kinematics @ <>= procedure :: generate_fsr_in => kinematics_generate_fsr_in <>= subroutine kinematics_generate_fsr_in (kin) class(kinematics_t), intent(inout) :: kin select type (phs => kin%phs) type is (phs_fks_t) call phs%generate_fsr_in () end select end subroutine kinematics_generate_fsr_in @ %def kinematics_generate_fsr_in @ <>= 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 (debug_on) call msg_debug2 (D_REAL, "phase space is phs_FKS") if (phs%q_defined) then call phs%get_born_momenta (p) if (debug_on) then call msg_debug2 (D_REAL, "q is defined") call msg_debug2 (D_REAL, "get_born_momenta called") end if 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. else k%phs_factor = 0 success = .false. end if end select end subroutine kinematics_compute_selected_channel @ %def kinematics_compute_selected_channel @ <>= procedure :: redo_sf_chain => kinematics_redo_sf_chain <>= subroutine kinematics_redo_sf_chain (kin, mci_work, phs_channel) class(kinematics_t), intent(inout) :: kin 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 () sf_channel = kin%phs%config%get_sf_channel (phs_channel) call kin%sf_chain%compute_kinematics (sf_channel, x) end if end subroutine kinematics_redo_sf_chain @ %def kinematics_redo_sf_chain @ 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 @ <>= procedure :: get_boost_to_lab => kinematics_get_boost_to_lab <>= function kinematics_get_boost_to_lab (kin) result (lt) type(lorentz_transformation_t) :: lt class(kinematics_t), intent(in) :: kin lt = kin%phs%get_lorentz_transformation () end function kinematics_get_boost_to_lab @ %def kinematics_get_boost_to_lab @ <>= procedure :: get_boost_to_cms => kinematics_get_boost_to_cms <>= function kinematics_get_boost_to_cms (kin) result (lt) type(lorentz_transformation_t) :: lt class(kinematics_t), intent(in) :: kin lt = inverse (kin%phs%get_lorentz_transformation ()) end function kinematics_get_boost_to_cms @ %def kinematics_get_boost_to_cms @ 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, negative_sf, sf_rescale) class(kinematics_t), intent(inout) :: k real(default), intent(in) :: fac_scale logical, intent(in), optional :: negative_sf 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, negative_sf = negative_sf, sf_rescale = 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 => kinematics_lab_is_cm <>= function kinematics_lab_is_cm (k) result (lab_is_cm) logical :: lab_is_cm class(kinematics_t), intent(in) :: k lab_is_cm = k%phs%config%lab_is_cm end function kinematics_lab_is_cm @ %def kinematics_lab_is_cm @ <>= 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_work, nlo_type) class(kinematics_t), intent(inout) :: k type(pcm_nlo_workspace_t), intent(inout) :: pcm_work integer, intent(in) :: nlo_type real(default) :: sqrts, mtop type(lorentz_transformation_t) :: L_to_cms type(vector4_t), dimension(:), allocatable :: p_tot, p_onshell integer :: n_tot n_tot = k%phs%get_n_tot () allocate (p_tot (size (pcm_work%real_kinematics%p_born_cms%phs_point(1)))) select type (phs => k%phs) type is (phs_fks_t) p_tot = pcm_work%real_kinematics%p_born_cms%phs_point(1) 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_work%real_kinematics%p_born_cms%set_momenta (1, p_tot) p_onshell = pcm_work%real_kinematics%p_born_onshell%phs_point(1) call threshold_projection_born (mtop, L_to_cms, p_tot, p_onshell) pcm_work%real_kinematics%p_born_onshell%phs_point(1) = p_onshell if (debug2_active (D_THRESHOLD)) then print *, 'On-shell projected Born: ' call vector4_write_set (p_onshell) end if 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%lab_is_cm () .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 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 [[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. Although each [[term_instance]] carries a [[weight]], this currently always keeps the value $1$ and is only used to be given to routines to fulfill their signature. <>= type :: term_instance_t type(process_term_t), pointer :: config => null () class(pcm_t), pointer :: pcm => null () class(pcm_workspace_t), pointer :: pcm_work => null () logical :: active = .false. 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), allocatable :: fac_scale real(default), allocatable :: ren_scale real(default), allocatable :: es_scale real(default), allocatable :: alpha_qcd_forced real(default) :: weight = 1 type(vector4_t), dimension(:), allocatable :: p_seed type(vector4_t), dimension(:), allocatable :: p_hard integer :: nlo_type = BORN integer, dimension(:), allocatable :: same_kinematics logical :: negative_sf = .false. contains <> end type term_instance_t @ %def term_instance_t @ <>= procedure :: write => term_instance_write <>= subroutine term_instance_write (term, unit, kin, show_eff_state, testflag) class(term_instance_t), intent(in) :: term integer, intent(in), optional :: unit type(kinematics_t), intent(in), optional :: kin logical, intent(in), optional :: show_eff_state logical, intent(in), optional :: testflag real(default) :: fac_scale, ren_scale 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%get_fac_scale () write (u, "(3x,A,ES19.12)") "renormalization scale = ", term%get_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 !!! This used to be a member of term_instance if (present (kin)) then call kin%write (u) end if 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%ren_scale)) deallocate (term%ren_scale) if (allocated (term%fac_scale)) deallocate (term%fac_scale) if (allocated (term%es_scale)) deallocate (term%es_scale) 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%connected%final () call term%isolated%final () call term%int_hard%final () term%pcm => null () term%pcm_work => null () end subroutine term_instance_final @ %def term_instance_final @ For a new term object, we configure the structure-function interface, the phase space, the matrix-element (interaction) interface, etc. <>= procedure :: configure => term_instance_configure <>= subroutine term_instance_configure (term_instance, process, i, pcm_work, sf_chain, kin) class(term_instance_t), intent(out), target :: term_instance type(process_t), intent(in), target :: process integer, intent(in) :: i class(pcm_workspace_t), intent(in), target :: pcm_work type(sf_chain_t), intent(in), target :: sf_chain type(kinematics_t), intent(inout), target :: kin 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 call term_instance%init & (process%get_pcm_ptr (), pcm_work, 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_dynamics (process, i, kin, & real_finite = process%component_is_real_finite (i_component)) select type (phs => kin%phs) type is (phs_fks_t) call term_instance%set_emitter (kin) call term_instance%setup_fks_kinematics (kin, & process%get_var_list_ptr (), & process%get_beam_config_ptr ()) end select select type (pcm => term_instance%pcm) type is (pcm_nlo_t) call kin%set_threshold (pcm%settings%factorization_mode) end select call term_instance%setup_expressions (process%get_meta (), process%get_config ()) end if end subroutine term_instance_configure @ %def term_instance_configure @ First part of term-instance configuration: initialize by assigning pointers to the overall [[pcm]] and the associated [[pcm_workspace]] objects. <>= procedure :: init => term_instance_init <>= subroutine term_instance_init (term_instance, pcm, pcm_work, nlo_type) class(term_instance_t), intent(out) :: term_instance class(pcm_t), intent(in), target :: pcm class(pcm_workspace_t), intent(in), target :: pcm_work integer, intent(in) :: nlo_type term_instance%pcm => pcm term_instance%pcm_work => pcm_work term_instance%nlo_type = nlo_type end subroutine term_instance_init @ %def term_instance_init @ The second part of term-instance configuration concerns dynamics, i.e., the interface to the matrix-element (interaction), and the parton-state objects that combine all kinematics and matrix-element data for evaluation. 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 :: setup_dynamics => term_instance_setup_dynamics <>= subroutine term_instance_setup_dynamics (term, process, i_term, kin, real_finite) class(term_instance_t), intent(inout), target :: term type(process_t), intent(in), target:: process integer, intent(in) :: i_term type(kinematics_t), intent(in) :: kin 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, dimension(:,:), allocatable :: flv_born, flv_real type(flavor_t), dimension(:,:), allocatable :: flv_pdf type(quantum_numbers_t), dimension(:,:), allocatable :: qn_pdf integer :: n_in, n_vir, n_out, n_tot, n_sub integer :: n_flv_born, n_flv_real, n_flv_total 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) term%negative_sf = process%get_negative_sf () 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 => kin%sf_chain%get_out_int_ptr () n_in = term%int_hard%get_n_in () do j = 1, n_in i = kin%sf_chain%get_out_i (j) call term%int_hard%set_source_link (j, sf_chain_int, i) end do call term%isolated%init (kin%sf_chain, term%int_hard) allocate (mask_in (n_in)) mask_in = kin%sf_chain%get_out_mask () select type (phs => kin%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_beams_rescaled + term%get_n_sub () 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, & requires_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) ! Does connected%trace never have any helicity qn? call term%init_interaction_qn_index (core, term%connected%trace, n_sub, & process%get_model_ptr (), is_polarized = .false.) call term%init_interaction_qn_index (core, term%int_hard, n_sub, process%get_model_ptr ()) if (requires_extended_sf) then select type (pcm => term%pcm) type is (pcm_nlo_t) n_in = pcm%region_data%get_n_in () flv_born = pcm%region_data%get_flv_states_born () flv_real = pcm%region_data%get_flv_states_real () n_flv_born = pcm%region_data%get_n_flv_born () n_flv_real = pcm%region_data%get_n_flv_real () n_flv_total = n_flv_born + n_flv_real allocate (flv_pdf(n_in, n_flv_total), & qn_pdf(n_in, n_flv_total)) call flv_pdf(:, :n_flv_born)%init (flv_born(:n_in, :)) call flv_pdf(:, n_flv_born + 1:n_flv_total)%init (flv_real(:n_in, :)) call qn_pdf%init (flv_pdf) call sf_chain_int%init_qn_index (qn_pdf, n_flv_born, n_flv_real) end select end if 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_setup_dynamics @ %def term_instance_setup_dynamics @ Set up index mapping from state matrix to index pair [[i_flv]], [[i_sub]]. <>= public :: setup_interaction_qn_index <>= subroutine setup_interaction_qn_index (int, data, qn_config, n_sub, is_polarized) class(interaction_t), intent(inout) :: int class(process_constants_t), intent(in) :: data type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_config integer, intent(in) :: n_sub logical, intent(in) :: is_polarized integer :: i type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel if (is_polarized) then call setup_interaction_qn_hel (int, data, qn_hel) call int%init_qn_index (qn_config, n_sub, qn_hel) call int%set_qn_index_helicity_flip (.true.) else call int%init_qn_index (qn_config, n_sub) end if end subroutine setup_interaction_qn_index @ %def setup_interaction_qn_index @ Set up beam polarisation quantum numbers, if 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 an 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. <>= public :: setup_interaction_qn_hel <>= subroutine setup_interaction_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_interaction_qn_hel @ %def setup_interaction_qn_hel @ <>= procedure :: init_interaction_qn_index => term_instance_init_interaction_qn_index <>= subroutine term_instance_init_interaction_qn_index (term, core, int, n_sub, & model, is_polarized) class(term_instance_t), intent(inout), target :: term class(prc_core_t), intent(in) :: core class(interaction_t), intent(inout) :: int integer, intent(in) :: n_sub class(model_data_t), intent(in) :: model logical, intent(in), optional :: is_polarized logical :: polarized type(quantum_numbers_t), dimension(:, :), allocatable :: qn_config integer, dimension(:,:), allocatable :: flv_born type(flavor_t), dimension(:), allocatable :: flv integer :: i select type (core) class is (prc_external_t) if (present (is_polarized)) then polarized = is_polarized else polarized = core%includes_polarization () end if select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) associate (is_born => .not. (term%nlo_type == NLO_REAL .and. & .not. term%is_subtraction ())) select type (pcm => term%pcm) type is (pcm_nlo_t) qn_config = pcm%get_qn (is_born) end select call setup_interaction_qn_index (int, term%config%data, & qn_config, n_sub, polarized) end associate class default call term%config%data%get_flv_state (flv_born) allocate (flv (size (flv_born, dim = 1))) allocate (qn_config (size (flv_born, dim = 1), size (flv_born, dim = 2))) do i = 1, core%data%n_flv call flv%init (flv_born(:,i), model) call qn_config(:, i)%init (flv) end do call setup_interaction_qn_index (int, term%config%data, & qn_config, n_sub, polarized) end select class default call int%init_qn_index () end select end subroutine term_instance_init_interaction_qn_index @ %def term_instance_init_interaction_qn_index @ <>= procedure :: setup_fks_kinematics => term_instance_setup_fks_kinematics <>= subroutine term_instance_setup_fks_kinematics (term, kin, var_list, beam_config) class(term_instance_t), intent(inout), target :: term type(kinematics_t), intent(inout) :: kin 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 => kin%phs) type is (phs_fks_t) select type (pcm => term%pcm) type is (pcm_nlo_t) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) call pcm%setup_phs_generator (pcm_work, & phs%generator, phs%config%sqrts, mode, singular_jacobian) if (beam_config%has_structure_function ()) then pcm_work%isr_kinematics%isr_mode = SQRTS_VAR else pcm_work%isr_kinematics%isr_mode = SQRTS_FIXED end if if (debug_on) call msg_debug (D_PHASESPACE, "isr_mode: ", pcm_work%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 (pcm => term%pcm) type is (pcm_nlo_t) associate (settings => pcm%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 @ Set up 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, kin, mci_work, phs_channel, success) class(term_instance_t), intent(inout), target :: term type(kinematics_t), intent(inout) :: kin type(mci_work_t), intent(in) :: mci_work integer, intent(in) :: phs_channel logical, intent(out) :: success call kin%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_projections => term_instance_evaluate_projections <>= subroutine term_instance_evaluate_projections (term, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin if (kin%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_work => term%pcm_work) type is (pcm_nlo_workspace_t) call kin%threshold_projection (pcm_work, term%nlo_type) end select end if end subroutine term_instance_evaluate_projections @ %def term_instance_evaluate_projections @ 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, kin, recover, skip_term, success) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin integer, intent(in), optional :: skip_term logical, intent(in), optional :: recover 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 (present (recover)) then if (recover) return end if if (term%nlo_type == NLO_REAL .and. kin%emitter >= 0) then call kin%evaluate_radiation (term%p_seed, p, success) select type (pcm => term%pcm) type is (pcm_nlo_t) if (pcm%dalitz_plot%active) then if (kin%emitter > kin%n_in) then if (p(kin%emitter)**2 > tiny_07) & call pcm%register_dalitz_plot (kin%emitter, p) end if end if end select else if (is_subtraction_component (kin%emitter, term%nlo_type)) then call kin%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) if (debug_on) then call msg_debug2 (D_REAL, "inside compute_hard_kinematics") if (debug2_active (D_REAL)) call vector4_write_set (p) end if 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, kin, p_seed_ref) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(in) :: kin integer :: n_in type(vector4_t), dimension(:), intent(in), optional :: p_seed_ref n_in = kin%n_in call kin%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.) if (present (p_seed_ref)) then term%p_seed(n_in + 1 : ) = p_seed_ref else term%p_seed(n_in + 1 : ) = int_eff%get_momenta (outgoing = .true.) end if 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. JRR: Obsolete now. <>= 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. JRR: Obsolete now. <>= 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 @ Applies the real partition by computing the real partition function $F(\Phi)$ and multiplying either $\mathcal{R}_\text{sin} = \mathcal{R} \cdot F$ or $\mathcal{R}_\text{fin} = \mathcal{R} \cdot (1-F)$. <>= procedure :: apply_real_partition => term_instance_apply_real_partition <>= subroutine term_instance_apply_real_partition (term, kin, process) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(in) :: kin type(process_t), intent(in) :: process real(default) :: f, sqme integer :: i_component integer :: i_amp, n_amps, qn_index 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. kin%emitter < 0 if (is_subtraction) return select case (process%get_component_type (i_component)) case (COMP_REAL_FIN) call term%connected%trace%set_duplicate_flv_zero() end select 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 qn_index = term%connected%trace%get_qn_index (i_amp, i_sub = 0) sqme = real (term%connected%trace%get_matrix_element (qn_index)) if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_apply_real_partition") select type (pcm => term%pcm) 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) if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "Real finite") sqme = sqme * (one - f) case (COMP_REAL_SING) if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "Real singular") sqme = sqme * f end select end select end select if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "apply_damping: sqme", sqme) call term%connected%trace%set_matrix_element (qn_index, cmplx (sqme, zero, default)) end do end if end subroutine term_instance_apply_real_partition @ %def term_instance_apply_real_partition @ <>= 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, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin integer :: i_phs logical :: set_emitter select type (pcm => term%pcm) type is (pcm_nlo_t) select type (phs => kin%phs) type is (phs_fks_t) !!! Without resonances, i_alr = i_phs i_phs = term%config%i_term kin%i_phs = i_phs set_emitter = i_phs <= pcm%region_data%n_phs .and. term%nlo_type == NLO_REAL if (set_emitter) then kin%emitter = phs%phs_identifiers(i_phs)%emitter select type (pcm => term%pcm) type is (pcm_nlo_t) if (allocated (pcm%region_data%i_phs_to_i_con)) & kin%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 @ 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 matrix elements we get from OpenLoops and GoSam are already squared and summed over color and helicity. They should not be squared again. <>= procedure :: setup_event_data => term_instance_setup_event_data <>= subroutine term_instance_setup_event_data (term, kin, core, model) class(term_instance_t), intent(inout), target :: term type(kinematics_t), intent(in) :: kin class(prc_core_t), intent(in) :: core class(model_data_t), intent(in), target :: model integer :: n_in logical :: mask_color type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in n_in = term%int_hard%get_n_in () allocate (mask_in (n_in)) mask_in = kin%sf_chain%get_out_mask () call setup_isolated (term%isolated, core, model, mask_in, term%config%col) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) mask_color = pcm_work%is_fixed_order_nlo_events () class default mask_color = .false. end select call setup_connected (term%connected, term%isolated, core, & term%nlo_type, mask_color) 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 select type (core) class is (prc_blha_t) call isolated%matrix%init_identity(isolated%int_eff) isolated%has_matrix = .true. class default call isolated%setup_square_matrix (core, model, mask, color) end select !!! TODO (PS-09-10-20) We should not square the flows !!! if they come from BLHA either call isolated%setup_square_flows (core, model, mask) end subroutine setup_isolated subroutine setup_connected (connected, isolated, core, nlo_type, mask_color) type(connected_state_t), intent(inout), target :: connected type(isolated_state_t), intent(in), target :: isolated class(prc_core_t), intent(in) :: core integer, intent(in) :: nlo_type logical, intent(in) :: mask_color 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 do not 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 term%init_interaction_qn_index (core, connected%matrix, 0, model, & is_polarized = .false.) select type (core) class is (prc_blha_t) call connected%setup_connected_flows & (isolated, mask_color = mask_color) class default call connected%setup_connected_flows (isolated) end select 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_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (pcm => term%pcm) type is (pcm_nlo_t) if (debug_on) call msg_debug2 (D_SUBTRACTION, & "term_instance_evaluate_color_correlations: " // & "use_internal_color_correlations:", & pcm%settings%use_internal_color_correlations) if (debug_on) call msg_debug2 (D_SUBTRACTION, "fac_scale", term%get_fac_scale ()) do i_flv_born = 1, pcm%region_data%n_flv_born select case (term%nlo_type) case (NLO_REAL) call transfer_me_array_to_bij (pcm, i_flv_born, & pcm_work%real_sub%sqme_born (i_flv_born), & pcm_work%real_sub%sqme_born_color_c (:, :, i_flv_born)) case (NLO_MISMATCH) call transfer_me_array_to_bij (pcm, i_flv_born, & pcm_work%soft_mismatch%sqme_born (i_flv_born), & pcm_work%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 (pcm, i_flv_born, & -one, pcm_work%virtual%sqme_color_c (:, :, i_flv_born)) case (NLO_DGLAP) call transfer_me_array_to_bij (pcm, i_flv_born, & pcm_work%dglap_remnant%sqme_born (i_flv_born), & pcm_work%dglap_remnant%sqme_color_c_extra (:, :, 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 logical :: special_case_interferences integer :: i_color_c, i_sub, n_offset real(default), dimension(:), allocatable :: sqme if (debug_on) 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 special_case_interferences = pcm%region_data%nlo_correction_type == "EW" n_offset = 0 if (term%nlo_type == NLO_VIRTUAL) then n_offset = 1 else if (pcm%has_pdfs .and. (term%is_subtraction () & .or. term%nlo_type == NLO_DGLAP)) then n_offset = n_beams_rescaled 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%trace%get_qn_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%trace%get_qn_index (i_flv, i_sub = 0)), default), & pcm%region_data%get_flv_states_born (i_flv), & sqme_color_c, special_case_interferences) 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_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (pcm => term%pcm) type is (pcm_nlo_t) do i_flv_born = 1, pcm%region_data%n_flv_born select case (term%nlo_type) case (NLO_REAL) call transfer_me_array_to_bij (pcm, i_flv_born, & pcm_work%real_sub%sqme_born (i_flv_born), & pcm_work%real_sub%sqme_born_charge_c (:, :, i_flv_born)) case (NLO_MISMATCH) call transfer_me_array_to_bij (pcm, i_flv_born, & pcm_work%soft_mismatch%sqme_born (i_flv_born), & pcm_work%soft_mismatch%sqme_born_charge_c (:, :, i_flv_born)) case (NLO_VIRTUAL) call transfer_me_array_to_bij (pcm, i_flv_born, & one, pcm_work%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 real(default), 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) = -one sigma(flv_born%n_in + 1: ) = one 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_sub, i_emitter, emitter integer :: n_flv, n_sub_color, n_sub_spin, n_offset,i,j real(default), dimension(1:3, 1:3) :: sqme_spin_c real(default), dimension(:), allocatable :: sqme_spin_c_all real(default), dimension(:), allocatable :: sqme_spin_c_arr if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_spin_correlations") select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) if (pcm_work%real_sub%requires_spin_correlations () & .and. term%nlo_type == NLO_REAL) then select type (core) type is (prc_openloops_t) select type (pcm => term%pcm) type is (pcm_nlo_t) n_flv = term%connected%trace%get_qn_index_n_flv () n_sub_color = term%get_n_sub_color () n_sub_spin = term%get_n_sub_spin () n_offset = 0; if(pcm%has_pdfs) n_offset = n_beams_rescaled allocate (sqme_spin_c_arr(6)) 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%trace%get_qn_index (i_flv, & i_sub = i_sub + n_offset + n_sub_color)), default) end do do i_emitter = 1, pcm%region_data%n_emitters emitter = pcm%region_data%emitters(i_emitter) if (emitter > 0) then call split_array (sqme_spin_c_all, sqme_spin_c_arr) do j = 1, size (sqme_spin_c, dim=2) do i = j, size (sqme_spin_c, dim=1) !!! Restoring the symmetric matrix packed into a 1-dim array !!! c.f. [[prc_openloops_compute_sqme_spin_c]] sqme_spin_c(i,j) = sqme_spin_c_arr(j + i * (i - 1) / 2) if (i /= j) sqme_spin_c(j,i) = sqme_spin_c(i,j) end do end do pcm_work%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 @@ <>= procedure :: apply_fks => term_instance_apply_fks <>= subroutine term_instance_apply_fks (term, kin, alpha_s_sub, alpha_qed_sub) class(term_instance_t), intent(inout) :: term class(kinematics_t), intent(inout) :: kin 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_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (pcm => term%pcm) type is (pcm_nlo_t) if (term%connected%has_matrix) then allocate (sqme (pcm%get_n_alr ())) else allocate (sqme (1)) end if sqme = zero select type (phs => kin%phs) type is (phs_fks_t) if (pcm%has_pdfs .and. & pcm%settings%use_internal_color_correlations) then call msg_fatal ("Color correlations for proton processes " // & "so far only supported by OpenLoops.") end if call pcm_work%set_real_and_isr_kinematics & (phs%phs_identifiers, kin%phs%get_sqrts ()) if (kin%emitter < 0) then call pcm_work%set_subtraction_event () do i_phs = 1, pcm%region_data%n_phs emitter = phs%phs_identifiers(i_phs)%emitter call pcm_work%real_sub%compute (emitter, & i_phs, alpha_s_sub, alpha_qed_sub, term%connected%has_matrix, sqme) end do else call pcm_work%set_radiation_event () emitter = kin%emitter; i_phs = kin%i_phs do i = 1, term%connected%trace%get_qn_index_n_flv () pcm_work%real_sub%sqme_real_non_sub (i, i_phs) = & real (term%connected%trace%get_matrix_element ( & term%connected%trace%get_qn_index (i))) end do call pcm_work%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 (pcm => term%pcm) type is (pcm_nlo_t) is_subtraction = kin%emitter < 0 if (term%connected%has_matrix) & call refill_evaluator (cmplx (sqme * term%weight, 0, default), & pcm%get_qn (is_subtraction), & pcm%region_data%get_flavor_indices (is_subtraction), & term%connected%matrix) if (term%connected%has_flows) & call refill_evaluator (cmplx (sqme * term%weight, 0, default), & pcm%get_qn (is_subtraction), & pcm%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), dimension(2) :: 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%get_ren_scale () print *, 'fac_scale: ', term%get_fac_scale () if (allocated (term%es_scale)) then print *, 'ES scale: ', term%es_scale else print *, 'ES scale: ', term%get_ren_scale () end if end if select type (pcm => term%pcm) type is (pcm_nlo_t) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) alpha_coupling = [alpha_s, alpha_qed] if (debug2_active (D_VIRTUAL)) then print *, 'alpha_s: ', alpha_coupling (1) print *, 'alpha_qed: ', alpha_coupling (2) end if allocate (p_born (pcm%region_data%n_legs_born)) if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then p_born = pcm_work%real_kinematics%p_born_onshell%get_momenta(1) else p_born = term%int_hard%get_momenta () end if call pcm_work%set_momenta_and_scales_virtual & (p_born, term%ren_scale, term%get_fac_scale (), & term%es_scale) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) associate (virtual => pcm_work%virtual) do i_flv = 1, term%connected%trace%get_qn_index_n_flv () virtual%sqme_born(i_flv) = & real (term%connected%trace%get_matrix_element ( & term%connected%trace%get_qn_index (i_flv, i_sub = 0))) virtual%sqme_virt_fin(i_flv) = & real (term%connected%trace%get_matrix_element ( & term%connected%trace%get_qn_index (i_flv, i_sub = 1))) end do end associate end select call pcm_work%compute_sqme_virt (term%pcm, term%p_hard, alpha_coupling, & term%connected%has_matrix, sqme_virt) call term%connected%trace%set_only_matrix_element & (1, cmplx (sum(sqme_virt), 0, default)) if (term%connected%has_matrix) & call refill_evaluator (cmplx (sqme_virt * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%matrix) if (term%connected%has_flows) & call refill_evaluator (cmplx (sqme_virt * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%flows) end select end select end subroutine term_instance_evaluate_sqme_virt @ %def term_instance_evaluate_sqme_virt @ Needs generalization to electroweak corrections. <>= 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_work => term%pcm_work) type is (pcm_nlo_workspace_t) call pcm_work%compute_sqme_mismatch & (term%pcm, 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 (pcm => term%pcm) type is (pcm_nlo_t) if (term%connected%has_matrix) & call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%matrix) if (term%connected%has_flows) & call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%flows) 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, alpha_qed) class(term_instance_t), intent(inout) :: term real(default), intent(in) :: alpha_s, alpha_qed real(default), dimension(2) :: alpha_coupling 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.") if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_evaluate_sqme_dglap") select type (pcm => term%pcm) type is (pcm_nlo_t) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) alpha_coupling = [alpha_s,alpha_qed] if (debug2_active (D_PROCESS_INTEGRATION)) then associate (n_flv => pcm_work%dglap_remnant%reg_data%n_flv_born) print *, "size(sqme_born) = ", size (pcm_work%dglap_remnant%sqme_born) call term%connected%trace%write () end associate end if call pcm_work%compute_sqme_dglap_remnant (pcm, alpha_coupling, & term%connected%has_matrix, sqme_dglap) end select 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 (pcm => term%pcm) type is (pcm_nlo_t) call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%matrix) if (term%connected%has_flows) then call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), & pcm%get_qn (.true.), & remove_duplicates_from_int_array ( & pcm%region_data%get_flavor_indices (.true.)), & term%connected%flows) end if 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. 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, kin) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(in), pointer :: core type(kinematics_t), intent(inout) :: kin if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, & "term_instance_evaluate_interaction") if (kin%only_cm_frame .and. (.not. kin%lab_is_cm())) then term%p_hard = kin%get_boost_to_cms () * term%int_hard%get_momenta () else term%p_hard = term%int_hard%get_momenta () end if select type (core) class is (prc_external_t) call term%evaluate_interaction_userdef (core, kin) 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 real(default) :: fac_scale, ren_scale integer :: i if (allocated (term%fac_scale)) then fac_scale = term%fac_scale else fac_scale = term%scale end if if (allocated (term%ren_scale)) then ren_scale = term%ren_scale else ren_scale = term%scale end if 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), & fac_scale, ren_scale, term%alpha_qcd_forced, & term%core_state) end do select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) call pcm_work%set_fac_scale (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, kin) class(term_instance_t), intent(inout) :: term class(prc_core_t), intent(inout) :: core type(kinematics_t), intent(inout) :: kin if (debug_on) 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%get_ren_scale ()) if (allocated (core_state%threshold_data)) & call evaluate_threshold_parameters (core_state, core, kin%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%get_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_work => term%pcm_work) type is (pcm_nlo_workspace_t) call pcm_work%set_fac_scale (term%get_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_work => term%pcm_work) type is (pcm_nlo_workspace_t) if (kin%emitter >= 0) then call core%set_offshell_momenta & (pcm_work%real_kinematics%p_real_cms%get_momenta(term%config%i_term)) leg = thr_leg (kin%emitter) call core%set_leg (leg) call core%set_onshell_momenta & (pcm_work%real_kinematics%p_real_onshell(leg)%get_momenta(term%config%i_term)) else call core%set_leg (0) call core%set_offshell_momenta & (pcm_work%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_beams_rescaled]] copies of these matrix elements as the first [[n_beams_rescaled]] subtractions. This is a remnant from times before the method [[term_instance_set_sf_factors]] and these entries are not used anymore. However, eliminating these entries involves deeper changes in how the connection tables for the evaluator product are set up and should therefore be part of a larger refactoring of the interactions \& state matrices. The next $n_{\text{born}}\times n_{sub_color}$ are color-correlated Born matrix elements, with then again the next $n_{\text{born}}\times n_{emitters}\times n_{sub_spin}$ being spin-correlated Born matrix elements. If two or more flavor structures would produce the same amplitude we only compute one and use the [[eqv_index]] determined by the [[prc_core]] and just copy the result to improve performance. <>= 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(6) :: 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_color_c_eqv, i_spin_c, i_spin_c_eqv integer :: i_flv_eqv, i_hel_eqv integer :: emitter, i_emitter logical :: bad_point, bp logical, dimension(:,:), allocatable :: eqv_me_evaluated if (debug_on) 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%int_hard%get_qn_index_n_flv () n_hel = term%int_hard%get_qn_index_n_hel () n_sub_color = term%get_n_sub_color () n_sub_spin = term%get_n_sub_spin () allocate (eqv_me_evaluated(n_flv,n_hel)) eqv_me_evaluated = .false. do i_flv = 1, n_flv do i_hel = 1, n_hel i_flv_eqv = core%data%eqv_flv_index(i_flv) i_hel_eqv = core%data%eqv_hel_index(i_hel) if (.not. eqv_me_evaluated(i_flv_eqv, i_hel_eqv)) then select type (core) class is (prc_external_t) call core%update_alpha_s (term%core_state, term%get_ren_scale ()) call core%compute_sqme (i_flv, i_hel, term%p_hard, & term%get_ren_scale (), sqme, bad_point) call term%pcm_work%set_bad_point (bad_point) associate (i_int => term%int_hard%get_qn_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%has_pdfs .and. & (term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then n_pdf_off = n_pdf_off + n_beams_rescaled do i_sub = 1, n_pdf_off term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub)) = & term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub = 0)) end do end if if (term%pcm%has_pdfs .and. term%nlo_type == NLO_DGLAP) then sqme_color_c = zero select type (pcm => term%pcm) type is (pcm_nlo_t) if (pcm%settings%nlo_correction_type == "EW" .and. & pcm%region_data%alphas_power > 0) then select type (core) class is (prc_blha_t) call core%compute_sqme_color_c_raw (i_flv, i_hel, & term%p_hard, term%get_ren_scale (), sqme_color_c, & bad_point) call term%pcm_work%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%get_ren_scale (), sqme_color_c, & bad_point) call term%pcm_work%set_bad_point (bad_point) end select end if end select do i_sub = 1, n_sub_color i_color_c = term%int_hard%get_qn_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 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%get_ren_scale (), sqme_color_c, bad_point) call term%pcm_work%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%get_ren_scale (), sqme_color_c, bad_point) call term%pcm_work%set_bad_point (bad_point) end select do i_sub = 1, n_sub_color i_color_c = term%int_hard%get_qn_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 (pcm => term%pcm) type is (pcm_nlo_t) do i_emitter = 1, pcm%region_data%n_emitters emitter = pcm%region_data%emitters(i_emitter) if (emitter > 0) then call core%compute_sqme_spin_c & (i_flv, & i_hel, & emitter, & term%p_hard, & term%get_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%int_hard%get_qn_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 eqv_me_evaluated(i_flv_eqv, i_hel_eqv) = .true. else associate (i_int => term%int_hard%get_qn_index & (i_flv = i_flv, i_hel = i_hel, i_sub = 0), & i_int_eqv => term%int_hard%get_qn_index & (i_flv = i_flv_eqv, i_hel = i_hel_eqv, i_sub = 0)) term%amp(i_int) = term%amp(i_int_eqv) end associate n_pdf_off = 0 if (term%pcm%has_pdfs .and. & (term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then n_pdf_off = n_pdf_off + n_beams_rescaled do i_sub = 1, n_pdf_off term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub)) = & term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub = 0)) end do end if if (term%pcm%has_pdfs .and. term%nlo_type == NLO_DGLAP) then do i_sub = 1, n_sub_color i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel, i_sub + n_pdf_off) i_color_c_eqv = term%int_hard%get_qn_index & (i_flv_eqv, i_hel_eqv, i_sub + n_pdf_off) term%amp(i_color_c) = term%amp(i_color_c_eqv) end do end if if ((term%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. & term%nlo_type == NLO_MISMATCH) then do i_sub = 1, n_sub_color i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel, i_sub + n_pdf_off) i_color_c_eqv = term%int_hard%get_qn_index & (i_flv_eqv, i_hel_eqv, i_sub + n_pdf_off) term%amp(i_color_c) = term%amp(i_color_c_eqv) end do do i_sub = 1, n_sub_spin i_spin_c = term%int_hard%get_qn_index (i_flv, i_hel, & i_sub + n_pdf_off + n_sub_color) i_spin_c_eqv = term%int_hard%get_qn_index (i_flv_eqv, i_hel_eqv, & i_sub + n_pdf_off + n_sub_color) term%amp(i_spin_c) = term%amp(i_spin_c_eqv) end do end if end if end do end do end subroutine term_instance_evaluate_interaction_userdef_tree @ %def term_instance_evaluate_interaction_userdef_tree @ Same as for [[term_instance_evaluate_interaction_userdef_tree]], but for the integrated-subtraction and finite one-loop terms. We only need color-correlated Born matrix elements, but an additional entry per flavor structure for the finite one-loop contribution. We thus have $2+n_{sub_color}$ entries in the [[term%amp]] for each [[i_flv]] and [[i_hel]] combination. If two or more flavor structures would produce the same amplitude we only compute one and use the [[eqv_index]] determined by the [[prc_core]] and just copy the result to improve performance. <>= 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, i_color_c_eqv integer :: i_flv_eqv, i_hel_eqv real(default), dimension(4) :: sqme_virt real(default), dimension(:), allocatable :: sqme_color_c real(default) :: es_scale logical :: bad_point logical, dimension(:,:), allocatable :: eqv_me_evaluated if (debug_on) 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%int_hard%get_qn_index_n_flv () n_hel = term%int_hard%get_qn_index_n_hel () n_sub = term%int_hard%get_qn_index_n_sub () allocate (eqv_me_evaluated(n_flv,n_hel)) eqv_me_evaluated = .false. i_virt = 1 do i_flv = 1, n_flv do i_hel = 1, n_hel i_flv_eqv = core%data%eqv_flv_index(i_flv) i_hel_eqv = core%data%eqv_hel_index(i_hel) if (.not. eqv_me_evaluated(i_flv_eqv, i_hel_eqv)) then select type (core) class is (prc_external_t) if (allocated (term%es_scale)) then es_scale = term%es_scale else es_scale = term%get_ren_scale () end if call core%compute_sqme_virt (i_flv, i_hel, term%p_hard, & term%get_ren_scale (), es_scale, & term%pcm%blha_defaults%loop_method, & sqme_virt, bad_point) call term%pcm_work%set_bad_point (bad_point) end select associate (i_born => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = 0), & i_loop => term%int_hard%get_qn_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 (pcm => term%pcm) 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%get_ren_scale (), & sqme_color_c, bad_point) call term%pcm_work%set_bad_point (bad_point) do i_sub = 1 + i_virt, n_sub i_color_c = term%int_hard%get_qn_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%get_ren_scale (), sqme_color_c, bad_point) call term%pcm_work%set_bad_point (bad_point) do i_sub = 1 + i_virt, n_sub i_color_c = term%int_hard%get_qn_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 eqv_me_evaluated(i_flv_eqv, i_hel_eqv) = .true. else associate (i_born => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = 0), & i_loop => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = i_virt), & i_born_eqv => term%int_hard%get_qn_index & (i_flv_eqv, i_hel = i_hel_eqv, i_sub = 0), & i_loop_eqv => term%int_hard%get_qn_index & (i_flv_eqv, i_hel = i_hel_eqv, i_sub = 1)) term%amp(i_loop) = term%amp(i_loop_eqv) term%amp(i_born) = term%amp(i_born_eqv) end associate do i_sub = 1 + i_virt, n_sub i_color_c = term%int_hard%get_qn_index & (i_flv, i_hel = i_hel, i_sub = i_sub) i_color_c_eqv = term%int_hard%get_qn_index & (i_flv_eqv, i_hel = i_hel_eqv, i_sub = i_sub) ! Index shift: i_sub - i_virt term%amp(i_color_c) = term%amp(i_color_c_eqv) end do end if 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 [[kin]] 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, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin real(default) :: fac_scale if (allocated (term%fac_scale)) then fac_scale = term%fac_scale else fac_scale = term%scale end if call kin%evaluate_sf_chain (fac_scale, term%negative_sf) call term%evaluate_scaled_sf_chains (kin) call term%isolated%evaluate_sf_chain (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, in which we have an emitter in the initial state, we rescale the kinematics for it using [[sf_rescale_real_t]].\\ References: arXiv:0709.2092, (2.35)-(2.42).\\ Obviously, it is completely irrelevant, which beam is treated. It becomes problematic when handling [[e, p]]-beams. <>= procedure :: evaluate_scaled_sf_chains => term_instance_evaluate_scaled_sf_chains <>= subroutine term_instance_evaluate_scaled_sf_chains (term, kin) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin class(sf_rescale_t), allocatable :: sf_rescale if (.not. term%pcm%has_pdfs) return if (term%nlo_type == NLO_REAL) then if (term%is_subtraction ()) then allocate (sf_rescale_collinear_t :: sf_rescale) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (sf_rescale) type is (sf_rescale_collinear_t) call sf_rescale%set (pcm_work%real_kinematics%xi_tilde) end select end select call kin%sf_chain%evaluate (term%get_fac_scale (), & term%negative_sf, sf_rescale) deallocate (sf_rescale) else if (kin%emitter >= 0 .and. kin%emitter <= kin%n_in) then allocate (sf_rescale_real_t :: sf_rescale) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (sf_rescale) type is (sf_rescale_real_t) call sf_rescale%set (pcm_work%real_kinematics%xi_tilde * & pcm_work%real_kinematics%xi_max (kin%i_phs), & pcm_work%real_kinematics%y (kin%i_phs)) end select end select call kin%sf_chain%evaluate (term%get_fac_scale (), & term%negative_sf, sf_rescale) deallocate (sf_rescale) else call kin%sf_chain%evaluate (term%get_fac_scale (), term%negative_sf) end if else if (term%nlo_type == NLO_DGLAP) then allocate (sf_rescale_dglap_t :: sf_rescale) select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) select type (sf_rescale) type is (sf_rescale_dglap_t) call sf_rescale%set (pcm_work%isr_kinematics%z) end select end select call kin%sf_chain%evaluate (term%get_fac_scale (), & term%negative_sf, sf_rescale) deallocate (sf_rescale) 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 and renormalization scale are identical to the general scale if not explicitly set: <>= procedure :: get_fac_scale => term_instance_get_fac_scale procedure :: get_ren_scale => term_instance_get_ren_scale <>= function term_instance_get_fac_scale (term) result (fac_scale) class(term_instance_t), intent(in) :: term real(default) :: fac_scale if (allocated (term%fac_scale)) then fac_scale = term%fac_scale else fac_scale = term%scale end if end function term_instance_get_fac_scale function term_instance_get_ren_scale (term) result (ren_scale) class(term_instance_t), intent(in) :: term real(default) :: ren_scale if (allocated (term%ren_scale)) then ren_scale = term%ren_scale else ren_scale = term%scale end if end function term_instance_get_ren_scale @ %def term_instance_get_fac_scale term_instance_get_ren_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 @ 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_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} NOTE: The description below represents the intended structure after refactoring and disentangling the FKS-NLO vs. LO algorithm dependencies. 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 [[pcm]] pointer is a shortcut to the [[pcm]] (process-component manager) component of the associated process, which we need wherever the calculation depends on the overall algorithm. The [[pcm_work]] component is the workspace for the [[pcm]] object referenced above. 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 [[kinematics]] array contains the set of phase-space points that are associated with the current calculation. The entries may correspond to different process components and terms. (TODO wk 19-02-22: Not implemented yet.) TODO wk 19-02-22: May include extra arrays for storing (squared) amplitude data. The [[term]] data set may be reduced to just results, or be removed altogether. The [[term]] subobjects are workspace for evaluating kinematics, matrix elements, cuts etc. The array entries correspond to the [[term]] configuration entries in the associated process object. 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 () class(pcm_t), pointer :: pcm => null () class(pcm_workspace_t), allocatable :: pcm_work 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(kinematics_t), dimension(:), allocatable :: kin type(term_instance_t), dimension(:), allocatable :: term type(mci_work_t), dimension(:), allocatable :: mci_work class(process_instance_hook_t), pointer :: hook => null () contains <> end type process_instance_t @ %def process_instance @ Wrapper type for storing pointers to process instance objects in arrays. <>= public :: process_instance_ptr_t <>= type :: process_instance_ptr_t type(process_instance_t), pointer :: p => null () end type process_instance_ptr_t @ %def process_instance_ptr_t @ The process hooks are first-in-last-out list of objects which are evaluated after the phase space and matrixelement are evaluated. It is possible to retrieve the sampler object and read the sampler information. The hook object are part of the [[process_instance]] and therefore, share a common lifetime. A data transfer, after the usual lifetime of the [[process_instance]], is not provided, as such the finalisation procedure has to take care of this! E.g. write the object to file from which later the collected information can then be retrieved. <>= public :: process_instance_hook_t <>= type, abstract :: process_instance_hook_t class(process_instance_hook_t), pointer :: next => null () contains procedure(process_instance_hook_init), deferred :: init procedure(process_instance_hook_final), deferred :: final procedure(process_instance_hook_evaluate), deferred :: evaluate end type process_instance_hook_t @ %def process_instance_hook_t @ We have to provide a [[init]], a [[final]] procedure and, for after evaluation, the [[evaluate]] procedure. The [[init]] procedures accesses [[var_list]] and current [[instance]] object. <>= public :: process_instance_hook_final, process_instance_hook_evaluate <>= abstract interface subroutine process_instance_hook_init (hook, var_list, instance) import :: process_instance_hook_t, var_list_t, process_instance_t class(process_instance_hook_t), intent(inout), target :: hook type(var_list_t), intent(in) :: var_list class(process_instance_t), intent(in), target :: instance end subroutine process_instance_hook_init subroutine process_instance_hook_final (hook) import :: process_instance_hook_t class(process_instance_hook_t), intent(inout) :: hook end subroutine process_instance_hook_final subroutine process_instance_hook_evaluate (hook, instance) import :: process_instance_hook_t, process_instance_t class(process_instance_hook_t), intent(inout) :: hook class(process_instance_t), intent(in), target :: instance end subroutine process_instance_hook_evaluate end interface @ %def process_instance_hook_final, process_instance_hook_evaluate @ The output routine contains a header with the most relevant information about the process, copied from [[process_metadata_write]]. We mark the active components by an asterisk. The next section is the MC parameter input. The following sections are written only if the evaluation status is beyond setting the parameters, or if the [[verbose]] option is set. <>= procedure :: write_header => process_instance_write_header procedure :: write => process_instance_write <>= subroutine process_instance_write_header (object, unit, testflag) class(process_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) if (associated (object%process)) then call object%process%write_meta (u, testflag) else write (u, "(1x,A)") "Process instance [undefined process]" return end if write (u, "(3x,A)", advance = "no") "status = " select case (object%evaluation_status) case (STAT_INITIAL); write (u, "(A)") "initialized" case (STAT_ACTIVATED); write (u, "(A)") "activated" case (STAT_BEAM_MOMENTA); write (u, "(A)") "beam momenta set" case (STAT_FAILED_KINEMATICS); write (u, "(A)") "failed kinematics" case (STAT_SEED_KINEMATICS); write (u, "(A)") "seed kinematics" case (STAT_HARD_KINEMATICS); write (u, "(A)") "hard kinematics" case (STAT_EFF_KINEMATICS); write (u, "(A)") "effective kinematics" case (STAT_FAILED_CUTS); write (u, "(A)") "failed cuts" case (STAT_PASSED_CUTS); write (u, "(A)") "passed cuts" case (STAT_EVALUATED_TRACE); write (u, "(A)") "evaluated trace" call write_separator (u) write (u, "(3x,A,ES19.12)") "sqme = ", object%sqme case (STAT_EVENT_COMPLETE); write (u, "(A)") "event complete" call write_separator (u) write (u, "(3x,A,ES19.12)") "sqme = ", object%sqme write (u, "(3x,A,ES19.12)") "weight = ", object%weight if (.not. vanishes (object%excess)) & write (u, "(3x,A,ES19.12)") "excess = ", object%excess case default; write (u, "(A)") "undefined" end select if (object%i_mci /= 0) then call write_separator (u) call object%mci_work(object%i_mci)%write (u, testflag) end if call write_separator (u, 2) end subroutine process_instance_write_header subroutine process_instance_write (object, unit, testflag) class(process_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u, i u = given_output_unit (unit) call object%write_header (u) if (object%evaluation_status >= STAT_BEAM_MOMENTA) then call object%sf_chain%write (u) call write_separator (u, 2) if (object%evaluation_status >= STAT_SEED_KINEMATICS) then if (object%evaluation_status >= STAT_HARD_KINEMATICS) then call write_separator (u, 2) write (u, "(1x,A)") "Active terms:" if (any (object%term%active)) then do i = 1, size (object%term) if (object%term(i)%active) then call write_separator (u) call object%term(i)%write (u, & kin = object%kin(i), & 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), pointer :: term type(var_list_t), pointer :: var_list integer :: i_born, i_real, i_real_fin, i_component if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_instance_init") instance%process => process instance%pcm => process%get_pcm_ptr () 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_workspace (instance%pcm_work) 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_work each time. i_real_fin = process%get_associated_real_fin (1) if (.not. pcm%initialized) then i_born = pcm%get_i_core (pcm%i_born) i_real = pcm%get_i_core (pcm%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_work => instance%pcm_work) type is (pcm_nlo_workspace_t) call pcm_work%init_config (pcm, & process%component_can_be_integrated (), & process%get_nlo_type_component (), process%get_energy (), & i_real_fin, process%get_model_ptr ()) end select end select ! TODO wk-03-01 n_terms will eventually acquire a different meaning allocate (instance%kin (process%get_n_terms ())) do i = 1, process%get_n_terms () term => process%get_term_ptr (i) i_component = term%i_component call instance%kin(i)%configure (pcm, instance%pcm_work, & instance%sf_chain, & process%get_beam_config_ptr (), & process%get_phs_config (i_component), & process%get_nlo_type_component (i_component), & term%i_sub == i) end do ! TODO wk-03-01 n_terms will eventually acquire a different meaning allocate (instance%term (process%get_n_terms ())) do i = 1, process%get_n_terms () call instance%term(i)%configure (process, i, instance%pcm_work, & instance%sf_chain, instance%kin(i)) 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%kin)) then do i = 1, size (instance%kin) call instance%kin(i)%final () end do deallocate (instance%kin) end if 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_work%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), target :: 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%kin%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%kin(i)%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%kin(j)%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) instance%term(i_term_same)%p_seed = instance%term(i_term)%p_seed associate (phs => instance%kin(i_term_same)%phs) call phs%set_lorentz_transformation & (instance%kin(i_term)%phs%get_lorentz_transformation ()) select type (phs) type is (phs_fks_t) call phs%set_momenta (instance%term(i_term_same)%p_seed) if (i_term_same /= i_term) then call phs%set_reference_frames (.false.) end if end select end associate instance%kin(i_term_same)%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%kin(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), kin => instance%kin(i)) if (associated (term%config)) then core => instance%process%get_core_term (i) call term%setup_event_data (kin, 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 ()) then if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then call instance%kin(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, recover, skip_term) class(process_instance_t), intent(inout) :: instance logical, intent(in), optional :: recover 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 (present (recover)) then if (recover) return 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) associate (term => instance%term(i_term(j)), kin => instance%kin(i_term(j))) if (kin%new_seed) then call term%compute_seed_kinematics (kin, & instance%mci_work(instance%i_mci), channel, success) call instance%transfer_same_kinematics (i_term(j)) end if if (.not. success) exit select type (pcm => instance%pcm) class is (pcm_nlo_t) call term%evaluate_projections (kin) call kin%evaluate_radiation_kinematics & (instance%mci_work(instance%i_mci)%get_x_process ()) call kin%generate_fsr_in () call kin%compute_xi_ref_momenta (pcm%region_data, term%nlo_type) end select end associate 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_work => instance%pcm_work) class is (pcm_nlo_workspace_t) call pcm_work%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, i 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%kin(i_term)%recover_mcpar & (instance%mci_work(instance%i_mci), channel, instance%term(i_term)%p_seed) if (instance%term(i_term)%nlo_type == NLO_REAL) then do i = 1, size (instance%term) if (i /= i_term .and. instance%term(i)%nlo_type == NLO_REAL) then if (instance%term(i)%active) then call instance%kin(i)%recover_mcpar & (instance%mci_work(instance%i_mci), channel, & instance%term(i)%p_seed) end if end if end do end if 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%kin(i_term)%recover_sfchain (channel, instance%term(i_term)%p_seed) 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, recover, skip_term) class(process_instance_t), intent(inout) :: instance integer, intent(in), optional :: skip_term logical, intent(in), optional :: recover integer :: i logical :: success success = .true. if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then do i = 1, size (instance%term) associate (term => instance%term(i), kin => instance%kin(i)) if (term%active) then call term%compute_hard_kinematics & (kin, recover, skip_term, success) if (.not. success) exit !!! Ren scale is zero when this is commented out! Understand! if (term%nlo_type == NLO_REAL) & call kin%redo_sf_chain (instance%mci_work(instance%i_mci), & instance%selected_channel) end if end associate 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 type(vector4_t), dimension(:), allocatable :: p_seed_ref integer :: i if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then call instance%term(i_term)%recover_seed_kinematics (instance%kin(i_term)) if (instance%term(i_term)%nlo_type == NLO_REAL) then allocate (p_seed_ref (instance%term(i_term)%isolated%int_eff%get_n_out ())) p_seed_ref = instance%term(i_term)%isolated%int_eff%get_momenta & (outgoing = .true.) do i = 1, size (instance%term) if (i /= i_term .and. instance%term(i)%nlo_type == NLO_REAL) then if (instance%term(i)%active) then call instance%term(i)%recover_seed_kinematics & (instance%kin(i), p_seed_ref) end if end if end do end if end if 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 successful, 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 () call set_ellis_sexton_scale () 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 (pcm => instance%pcm) 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 (pcm%settings%cut_all_real_sqmes) & passed_real = passed_real .and. instance%term(i)%passed if (pcm%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 subroutine set_ellis_sexton_scale () real(default) :: es_scale type(var_list_t), pointer :: var_list integer :: i var_list => instance%process%get_var_list_ptr () es_scale = var_list%get_rval (var_str ("ellis_sexton_scale")) do i = 1, size (instance%term) if (instance%term(i)%active .and. instance%term(i)%nlo_type == NLO_VIRTUAL) then if (es_scale > zero) then if (allocated (instance%term(i)%es_scale)) then instance%term(i)%es_scale = es_scale else allocate (instance%term(i)%es_scale, source=es_scale) end if end if end if end do end subroutine set_ellis_sexton_scale 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%kin(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 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, recover) class(process_instance_t), intent(inout) :: instance logical, intent(in), optional :: recover 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 () logical :: has_pdfs if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_evaluate_trace") has_pdfs = instance%process%pcm_contains_pdfs () 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), kin => instance%kin(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 call term%evaluate_interaction (core, kin) call term%evaluate_trace (kin) i_real_fin = instance%process%get_associated_real_fin (1) if (instance%process%uses_real_partition ()) & call term%apply_real_partition (kin, instance%process) if (term%config%i_component /= i_real_fin) then if ((term%nlo_type == NLO_REAL .and. kin%emitter < 0) & .or. term%nlo_type == NLO_MISMATCH & .or. term%nlo_type == NLO_DGLAP) & call term%set_born_sqmes (core) if (term%is_subtraction () .or. & term%nlo_type == NLO_DGLAP) & call term%set_sf_factors (kin, has_pdfs) if (term%nlo_type > BORN) then if (.not. (term%nlo_type == NLO_REAL .and. & kin%emitter >= 0)) then select type (pcm => term%pcm) type is (pcm_nlo_t) if (char (pcm%settings%nlo_correction_type) == "QCD" .or. & char (pcm%settings%nlo_correction_type) == "Full") & call term%evaluate_color_correlations (core_sub) if (char (pcm%settings%nlo_correction_type) == "EW" .or. & char (pcm%settings%nlo_correction_type) == "Full") then call term%evaluate_charge_correlations (core_sub) select type (pcm => term%pcm) type is (pcm_nlo_t) associate (reg_data => pcm%region_data) if (reg_data%alphas_power > 0) & call term%evaluate_color_correlations (core_sub) end associate end select end if end select end if if (term%is_subtraction ()) then call term%evaluate_spin_correlations (core_sub) end if end if alpha_s = core%get_alpha_s (term%core_state) alpha_qed = core%get_alpha_qed (term%core_state) if (term%nlo_type > BORN) then select type (pcm => term%pcm) type is (pcm_nlo_t) if (alpha_qed == -1 .and. (& char (pcm%settings%nlo_correction_type) == "EW" .or. & char (pcm%settings%nlo_correction_type) == "Full")) then call msg_bug("Attempting to compute EW corrections with alpha_qed = -1") end if end select end if if (present (recover)) then if (recover) return end if select case (term%nlo_type) case (NLO_REAL) call term%apply_fks (kin, 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, alpha_qed) 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_work%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_work => term%pcm_work) type is (pcm_nlo_workspace_t) do i_flv = 1, term%connected%trace%get_qn_index_n_flv () ii_flv = term%connected%trace%get_qn_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_work%real_sub%sqme_born(i_flv) = sqme case (NLO_MISMATCH) pcm_work%soft_mismatch%sqme_born(i_flv) = sqme case (NLO_DGLAP) pcm_work%dglap_remnant%sqme_born(i_flv) = sqme end select end do end select end subroutine term_instance_set_born_sqmes @ %def term_instance_set_born_sqmes @ Calculates and then saves the ratio of the value of the (rescaled) real structure function chain of each ISR alpha region over the value of the corresponding underlying born flavor structure. In the case of emitter 0 we also need the rescaled ratio for emitter 1 and 2 in that region for the (soft-)collinear limits. If the emitter is 1 or 2 in some cases, e. g. for EW corrections where a photon in the proton is required, there can be the possibility of soft radiation off the initial state. For that purpose the unrescaled ratio is needed and as a default we always save these numbers in [[sf_factors(:, 0)]]. Altough this procedure is implying functionality for general structure functions, it should be reviewed for anything else besides PDFs, as there might be complications in the details. The general idea of getting the ratio in this way should hold up in these cases as well, however. <>= procedure :: set_sf_factors => term_instance_set_sf_factors <>= subroutine term_instance_set_sf_factors (term, kin, has_pdfs) class(term_instance_t), intent(inout) :: term type(kinematics_t), intent(inout) :: kin logical, intent(in) :: has_pdfs type(interaction_t), pointer :: sf_chain_int real(default) :: factor_born, factor_real integer :: n_in, alr, em integer :: i_born, i_real select type (pcm_work => term%pcm_work) type is (pcm_nlo_workspace_t) if (.not. has_pdfs) then pcm_work%real_sub%sf_factors = one return end if select type (pcm => term%pcm) type is (pcm_nlo_t) sf_chain_int => kin%sf_chain%get_out_int_ptr () associate (reg_data => pcm%region_data) n_in = reg_data%get_n_in () do alr = 1, reg_data%n_regions em = reg_data%regions(alr)%emitter if (em <= n_in) then i_born = reg_data%regions(alr)%uborn_index i_real = reg_data%regions(alr)%real_index factor_born = sf_chain_int%get_matrix_element & (sf_chain_int%get_sf_qn_index_born (i_born, i_sub = 0)) factor_real = sf_chain_int%get_matrix_element & (sf_chain_int%get_sf_qn_index_real (i_real, i_sub = em)) call set_factor (pcm_work, alr, em, factor_born, factor_real) if (em == 0) then do em = 1, 2 factor_real = sf_chain_int%get_matrix_element & (sf_chain_int%get_sf_qn_index_real (i_real, i_sub = em)) call set_factor (pcm_work, alr, em, factor_born, factor_real) end do else factor_real = sf_chain_int%get_matrix_element & (sf_chain_int%get_sf_qn_index_real (i_real, i_sub = 0)) call set_factor (pcm_work, alr, 0, factor_born, factor_real) end if end if end do end associate end select end select contains subroutine set_factor (pcm_work, alr, em, factor_born, factor_real) type(pcm_nlo_workspace_t), intent(inout), target :: pcm_work integer, intent(in) :: alr, em real(default), intent(in) :: factor_born, factor_real real(default) :: factor if (any (vanishes ([factor_real, factor_born], tiny(1._default), tiny(1._default)))) then factor = zero else factor = factor_real / factor_born end if select case (term%nlo_type) case (NLO_REAL) pcm_work%real_sub%sf_factors(alr, em) = factor case (NLO_DGLAP) pcm_work%dglap_remnant%sf_factors(alr, em) = factor end select end subroutine end subroutine term_instance_set_sf_factors @ %def term_instance_set_sf_factors @ <>= 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 ( & instance%kin(i_terms(i_term)), & 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_work => instance%pcm_work) type is (pcm_nlo_workspace_t) if (allocated (pcm_work%i_mci_to_real_component)) then call msg_warning ("i_mci_to_real_component already allocated - replace it") deallocate (pcm_work%i_mci_to_real_component) end if allocate (pcm_work%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_work%i_mci_to_real_component (i_mci) = & component%config%get_associated_real () case (COMP_REAL_FIN) pcm_work%i_mci_to_real_component (i_mci) = & component%config%get_associated_real_fin () case (COMP_REAL_SING) pcm_work%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) 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 process and keep the event nevertheless if (instance%keep_failed_events ()) then do i = 1, size (instance%term) associate (term => instance%term(i)) if (term%active) then call term%evaluate_event_data () end if end associate end do ! 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 for the term instance with index [[i_term]] and a phase space point set with index [[i_phs]]. In addition, for the real emission, each term instance corresponds to one emitter. 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 logical :: has_pdfs has_pdfs = instance%process%pcm_contains_pdfs () if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_compute_sqme_rad") select type (pcm_work => instance%pcm_work) type is (pcm_nlo_workspace_t) associate (term => instance%term(i_term), kin => instance%kin(i_term)) core => instance%process%get_core_term (i_term) if (is_subtraction) then call pcm_work%set_subtraction_event () else call pcm_work%set_radiation_event () end if call term%int_hard%set_momenta (pcm_work%get_momenta & (term%pcm, 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, kin) call term%evaluate_trace (kin) if (term%is_subtraction ()) then call term%set_sf_factors (kin, has_pdfs) select type (pcm => instance%pcm) type is (pcm_nlo_t) if (char (pcm%settings%nlo_correction_type) == "QCD" .or. & char (pcm%settings%nlo_correction_type) == "Full") & call term%evaluate_color_correlations (core) if (char (pcm%settings%nlo_correction_type) == "EW" .or. & char (pcm%settings%nlo_correction_type) == "Full") & call term%evaluate_charge_correlations (core) end select call term%evaluate_spin_correlations (core) end if i_real_fin = instance%process%get_associated_real_fin (1) if (term%config%i_component /= i_real_fin) & call term%apply_fks (kin, core%get_alpha_s (term%core_state), & core%get_alpha_qed (term%core_state)) 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, recover 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) recover = instance%pcm_work%is_nlo () if (recover_phs) then call instance%recover_mcpar (i_term) call instance%recover_beam_momenta (i_term) call instance%compute_seed_kinematics & (recover = recover, skip_term = i_term) call instance%compute_hard_kinematics & (recover = recover, skip_term = 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 (recover) 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%kin(i_term_base)) 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%kin(i)%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), kin => instance%kin(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 & (kin, instance%mci_work(i_component), 1, success) call kin%evaluate_radiation_kinematics & (instance%mci_work(instance%i_mci)%get_x_process ()) call term%compute_hard_kinematics (kin, 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_work => instance%pcm_work) type is (pcm_nlo_workspace_t) i_real = pcm_work%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(:), allocatable :: 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, success) 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 logical, intent(out), optional :: success 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), & success = success) 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%kin(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%kin(i_term)%get_boost_to_cms () end function process_instance_get_boost_to_cms @ %def process_instance_get_boost_to_cms @ <>= procedure :: lab_is_cm => process_instance_lab_is_cm <>= function process_instance_lab_is_cm (instance, i_term) result (lab_is_cm) logical :: lab_is_cm class(process_instance_t), intent(in) :: instance integer, intent(in) :: i_term lab_is_cm = instance%kin(i_term)%phs%lab_is_cm () end function process_instance_lab_is_cm @ %def process_instance_lab_is_cm @ 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%kin) call pacify (instance%kin(i)%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%kin(1)%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%kin(1)%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/particles/particles.nw =================================================================== --- trunk/src/particles/particles.nw (revision 8778) +++ trunk/src/particles/particles.nw (revision 8779) @@ -1,8525 +1,8523 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: particle objects %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Particles} \includemodulegraph{particles} This chapter collects modules that implement particle objects, for use in event records. While within interactions, all correlations are manifest, a particle array is derived by selecting a particular quantum number set. This involves tracing over all other particles, as far as polarization is concerned. Thus, a particle has definite flavor, color, and a single-particle density matrix for polarization. \begin{description} \item[su\_algebra] We make use of $su(N)$ generators as the basis for representing polarization matrices. This module defines the basis and provides the necessary transformation routines. \item[bloch\_vectors] This defines polarization objects in Bloch representation. The object describes the spin density matrix of a particle, currently restricted to spin $0\ldots 2$. \item[polarizations] This extends the basic polarization object such that it supports properties of physical particles and appropriate constructors. \item[particles] Particle objects and particle lists, as the base of event records. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{$su(N)$ Algebra} We need a specific choice of basis for a well-defined component representation. The matrix elements of $T^a$ are ordered as $m=\ell,\ell-1,\ldots -\ell$, i.e., from highest down to lowest weight, for both row and column. We list first the generators of the $su(2)$ subalgebras which leave $|m|$ invariant ($|m|\neq 0$): \begin{equation} T^{b+1,b+2,b+3} \equiv \sigma^{1,2,3} \end{equation} acting on the respective subspace $|m|=\ell,\ell-1,\ldots$ for $b=0,1,\ldots$. This defines generators $T^a$ for $a=1,\ldots 3N/2$ ($\ldots 3(N-1)/2$) for $N$ even (odd), respectively. The following generators successively extend this to $su(4)$, $su(6)$, \ldots until $su(N)$ by adding first the missing off-diagonal and then diagonal generators. The phase conventions are analogous. (It should be possible to code these conventions for generic spin, but in the current implementation we restrict ourselves to $s\leq 2$, i.e., $N\leq 5$.) <<[[su_algebra.f90]]>>= <> module su_algebra <> use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR <> <> contains <> end module su_algebra @ %def su_algebra @ \subsection{$su(N)$ fundamental representation} The dimension of the basis for a given spin type. consecutively, starting at [[SCALAR=1]]. <>= public :: algebra_dimension <>= function algebra_dimension (s) result (n) integer :: n integer, intent(in) :: s n = fundamental_dimension (s) ** 2 - 1 end function algebra_dimension @ %def algebra_dimension @ The dimension of the fundamental (defining) representation that we use. This implementation assumes that the spin type is numerically equal to the fundamental dimension. <>= public :: fundamental_dimension <>= function fundamental_dimension (s) result (d) integer :: d integer, intent(in) :: s d = s end function fundamental_dimension @ %def fundamental_dimension @ \subsection{Mapping between helicity and matrix index} Return the helicity that corresponds to a particular entry in the polarization matrix representation. Helicities are counted downwards, in integers, and zero helicity is included (omitted) for odd (even) spin, respectively. <>= public :: helicity_value <>= function helicity_value (s, i) result (h) integer :: h integer, intent(in) :: s, i integer, dimension(1), parameter :: hh1 = [0] integer, dimension(2), parameter :: hh2 = [1, -1] integer, dimension(3), parameter :: hh3 = [1, 0, -1] integer, dimension(4), parameter :: hh4 = [2, 1, -1, -2] integer, dimension(5), parameter :: hh5 = [2, 1, 0, -1, -2] h = 0 select case (s) case (SCALAR) select case (i) case (1:1); h = hh1(i) end select case (SPINOR) select case (i) case (1:2); h = hh2(i) end select case (VECTOR) select case (i) case (1:3); h = hh3(i) end select case (VECTORSPINOR) select case (i) case (1:4); h = hh4(i) end select case (TENSOR) select case (i) case (1:5); h = hh5(i) end select end select end function helicity_value @ %def helicity_value @ Inverse: return the index that corresponds to a certain helicity value in the chosen representation. <>= public :: helicity_index <>= function helicity_index (s, h) result (i) integer, intent(in) :: s, h integer :: i integer, dimension(0:0), parameter :: hi1 = [1] integer, dimension(-1:1), parameter :: hi2 = [2, 0, 1] integer, dimension(-1:1), parameter :: hi3 = [3, 2, 1] integer, dimension(-2:2), parameter :: hi4 = [4, 3, 0, 2, 1] integer, dimension(-2:2), parameter :: hi5 = [5, 4, 3, 2, 1] select case (s) case (SCALAR) i = hi1(h) case (SPINOR) i = hi2(h) case (VECTOR) i = hi3(h) case (VECTORSPINOR) i = hi4(h) case (TENSOR) i = hi5(h) end select end function helicity_index @ %def helicity_index @ \subsection{Generator Basis: Cartan Generators} For each supported spin type, we return specific properties of the set of generators via inquiry functions. This is equivalent to using explicit representations of the generators. For easy access, the properties are hard-coded and selected via case expressions. Return true if the generator \#[[i]] is in the Cartan subalgebra, i.e., a diagonal matrix for spin type [[s]]. <>= public :: is_cartan_generator <>= elemental function is_cartan_generator (s, i) result (cartan) logical :: cartan integer, intent(in) :: s, i select case (s) case (SCALAR) case (SPINOR) select case (i) case (3); cartan = .true. case default cartan = .false. end select case (VECTOR) select case (i) case (3,8); cartan = .true. case default cartan = .false. end select case (VECTORSPINOR) select case (i) case (3,6,15); cartan = .true. case default cartan = .false. end select case (TENSOR) select case (i) case (3,6,15,24); cartan = .true. case default cartan = .false. end select case default cartan = .false. end select end function is_cartan_generator @ %def is_cartan_generator @ Return the index of Cartan generator \#[[k]] in the chosen representation. This has to conform to [[cartan]] above. <>= public :: cartan_index <>= elemental function cartan_index (s, k) result (ci) integer :: ci integer, intent(in) :: s, k integer, dimension(1), parameter :: ci2 = [3] integer, dimension(2), parameter :: ci3 = [3,8] integer, dimension(3), parameter :: ci4 = [3,6,15] integer, dimension(4), parameter :: ci5 = [3,6,15,24] select case (s) case (SPINOR) ci = ci2(k) case (VECTOR) ci = ci3(k) case (VECTORSPINOR) ci = ci4(k) case (TENSOR) ci = ci5(k) case default ci = 0 end select end function cartan_index @ %def cartan_index @ The element \#[[k]] of the result vector [[a]] is equal to the $(h,h)$ diagonal entry of the generator matrix $T^k$. That is, evaluating this for all allowed values of [[h]], we recover the set of Cartan generator matrices. <>= public :: cartan_element <>= function cartan_element (s, h) result (a) real(default), dimension(:), allocatable :: a integer, intent(in) :: s, h real(default), parameter :: sqrt2 = sqrt (2._default) real(default), parameter :: sqrt3 = sqrt (3._default) real(default), parameter :: sqrt10 = sqrt (10._default) allocate (a (algebra_dimension (s)), source = 0._default) select case (s) case (SCALAR) case (SPINOR) select case (h) case (1) a(3) = 1._default / 2 case (-1) a(3) = -1._default / 2 end select case (VECTOR) select case (h) case (1) a(3) = 1._default / 2 a(8) = 1._default / (2 * sqrt3) case (-1) a(3) = -1._default / 2 a(8) = 1._default / (2 * sqrt3) case (0) a(8) = -1._default / sqrt3 end select case (VECTORSPINOR) select case (h) case (2) a(3) = 1._default / 2 a(15) = 1._default / (2 * sqrt2) case (-2) a(3) = -1._default / 2 a(15) = 1._default / (2 * sqrt2) case (1) a(6) = 1._default / 2 a(15) = -1._default / (2 * sqrt2) case (-1) a(6) = -1._default / 2 a(15) = -1._default / (2 * sqrt2) end select case (TENSOR) select case (h) case (2) a(3) = 1._default / 2 a(15) = 1._default / (2 * sqrt2) a(24) = 1._default / (2 * sqrt10) case (-2) a(3) = -1._default / 2 a(15) = 1._default / (2 * sqrt2) a(24) = 1._default / (2 * sqrt10) case (1) a(6) = 1._default / 2 a(15) = -1._default / (2 * sqrt2) a(24) = 1._default / (2 * sqrt10) case (-1) a(6) = -1._default / 2 a(15) = -1._default / (2 * sqrt2) a(24) = 1._default / (2 * sqrt10) case (0) a(24) = -4._default / (2 * sqrt10) end select end select end function cartan_element @ %def cartan_element @ Given an array of diagonal matrix elements [[rd]] of a generator, compute the array [[a]] of basis coefficients. The array must be ordered as defined by [[helicity_value]], i.e., highest weight first. The calculation is organized such that the trace of the generator, i.e., the sum of [[rd]] values, drops out. The result array [[a]] has coefficients for all basis generators, but only Cartan generators can get a nonzero coefficient. <>= public :: cartan_coeff <>= function cartan_coeff (s, rd) result (a) real(default), dimension(:), allocatable :: a integer, intent(in) :: s real(default), dimension(:), intent(in) :: rd real(default), parameter :: sqrt2 = sqrt (2._default) real(default), parameter :: sqrt3 = sqrt (3._default) real(default), parameter :: sqrt10 = sqrt (10._default) integer :: n n = algebra_dimension (s) allocate (a (n), source = 0._default) select case (s) case (SPINOR) a(3) = rd(1) - rd(2) case (VECTOR) a(3) = rd(1) - rd(3) a(8) = (rd(1) - 2 * rd(2) + rd(3)) / sqrt3 case (VECTORSPINOR) a(3) = rd(1) - rd(4) a(6) = rd(2) - rd(3) a(15) = (rd(1) - rd(2) - rd(3) + rd(4)) / sqrt2 case (TENSOR) a(3) = rd(1) - rd(5) a(6) = rd(2) - rd(4) a(15) = (rd(1) - rd(2) - rd(4) + rd(5)) / sqrt2 a(24) = (rd(1) + rd(2) - 4 * rd(3) + rd(4) + rd(5)) / sqrt10 end select end function cartan_coeff @ %def cartan_coeff @ \subsection{Roots (Off-Diagonal Generators)} Return the appropriate generator index for a given off-diagonal helicity combination. We require $h_1>h_2$. We return the index of the appropriate real-valued generator if [[r]] is true, else the complex-valued one. This is separate from the [[cartan_coeff]] function above. The reason is that the off-diagonal generators have only a single nonzero matrix element, so there is a one-to-one correspondence of helicity and index. <>= public :: root_index <>= function root_index (s, h1, h2, r) result (ai) integer :: ai integer, intent(in) :: s, h1, h2 logical :: r ai = 0 select case (s) case (SCALAR) case (SPINOR) select case (h1) case (1) select case (h2) case (-1); ai = 1 end select end select case (VECTOR) select case (h1) case (1) select case (h2) case (-1); ai = 1 case (0); ai = 4 end select case (0) select case (h2) case (-1); ai = 6 end select end select case (VECTORSPINOR) select case (h1) case (2) select case (h2) case (-2); ai = 1 case (1); ai = 7 case (-1); ai = 11 end select case (1) select case (h2) case (-1); ai = 4 case (-2); ai = 13 end select case (-1) select case (h2) case (-2); ai = 9 end select end select case (TENSOR) select case (h1) case (2) select case (h2) case (-2); ai = 1 case (1); ai = 7 case (-1); ai = 11 case (0); ai = 16 end select case (1) select case (h2) case (-1); ai = 4 case (-2); ai = 13 case (0); ai = 20 end select case (-1) select case (h2) case (-2); ai = 9 end select case (0) select case (h2) case (-2); ai = 18 case (-1); ai = 22 end select end select end select if (ai /= 0 .and. .not. r) ai = ai + 1 end function root_index @ %def root_index @ Inverse: return the helicity values ($h_2>h_1$) for an off-diagonal generator. The flag [[r]] tells whether this is a real or diagonal generator. The others are Cartan generators. <>= public :: root_helicity <>= subroutine root_helicity (s, i, h1, h2, r) integer, intent(in) :: s, i integer, intent(out) :: h1, h2 logical, intent(out) :: r h1 = 0 h2 = 0 r = .false. select case (s) case (SCALAR) case (SPINOR) select case (i) case ( 1, 2); h1 = 1; h2 = -1; r = i == 1 end select case (VECTOR) select case (i) case ( 1, 2); h1 = 1; h2 = -1; r = i == 1 case ( 4, 5); h1 = 1; h2 = 0; r = i == 4 case ( 6, 7); h1 = 0; h2 = -1; r = i == 6 end select case (VECTORSPINOR) select case (i) case ( 1, 2); h1 = 2; h2 = -2; r = i == 1 case ( 4, 5); h1 = 1; h2 = -1; r = i == 4 case ( 7, 8); h1 = 2; h2 = 1; r = i == 7 case ( 9,10); h1 = -1; h2 = -2; r = i == 9 case (11,12); h1 = 2; h2 = -1; r = i ==11 case (13,14); h1 = 1; h2 = -2; r = i ==13 end select case (TENSOR) select case (i) case ( 1, 2); h1 = 2; h2 = -2; r = i == 1 case ( 4, 5); h1 = 1; h2 = -1; r = i == 4 case ( 7, 8); h1 = 2; h2 = 1; r = i == 7 case ( 9,10); h1 = -1; h2 = -2; r = i == 9 case (11,12); h1 = 2; h2 = -1; r = i ==11 case (13,14); h1 = 1; h2 = -2; r = i ==13 case (16,17); h1 = 2; h2 = 0; r = i ==16 case (18,19); h1 = 0; h2 = -2; r = i ==18 case (20,21); h1 = 1; h2 = 0; r = i ==20 case (22,23); h1 = 0; h2 = -1; r = i ==22 end select end select end subroutine root_helicity @ %def root_helicity @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[su_algebra_ut.f90]]>>= <> module su_algebra_ut use unit_tests use su_algebra_uti <> <> contains <> end module su_algebra_ut @ %def su_algebra_ut @ <<[[su_algebra_uti.f90]]>>= <> module su_algebra_uti <> use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR use su_algebra <> <> contains <> end module su_algebra_uti @ %def su_algebra_ut @ API: driver for the unit tests below. <>= public :: su_algebra_test <>= subroutine su_algebra_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine su_algebra_test @ %def su_algebra_test @ \subsubsection{Generator Ordering} Show the position of Cartan generators in the sequence of basis generators. <>= call test (su_algebra_1, "su_algebra_1", & "generator ordering", & u, results) <>= public :: su_algebra_1 <>= subroutine su_algebra_1 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: su_algebra_1" write (u, "(A)") "* Purpose: test su(N) algebra implementation" write (u, "(A)") write (u, "(A)") "* su(N) generators: & &list and mark Cartan subalgebra" write (u, "(A)") write (u, "(A)") "* s = 0" call cartan_check (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call cartan_check (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call cartan_check (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call cartan_check (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call cartan_check (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: su_algebra_1" contains subroutine cartan_check (s) integer, intent(in) :: s integer :: i write (u, *) do i = 1, algebra_dimension (s) write (u, "(1x,L1)", advance="no") is_cartan_generator (s, i) end do write (u, *) end subroutine cartan_check end subroutine su_algebra_1 @ %def su_algebra_1 @ \subsubsection{Cartan Generator Basis} Show the explicit matrix representation for all Cartan generators and check their traces and Killing products. Also test helicity index mappings. <>= call test (su_algebra_2, "su_algebra_2", & "Cartan generator representation", & u, results) <>= public :: su_algebra_2 <>= subroutine su_algebra_2 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: su_algebra_2" write (u, "(A)") "* Purpose: test su(N) algebra implementation" write (u, "(A)") write (u, "(A)") "* diagonal su(N) generators: & &show explicit representation" write (u, "(A)") "* and check trace and Killing form" write (u, "(A)") write (u, "(A)") "* s = 1/2" call cartan_show (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call cartan_show (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call cartan_show (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call cartan_show (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: su_algebra_2" contains subroutine cartan_show (s) integer, intent(in) :: s real(default), dimension(:,:), allocatable :: rd integer, dimension(:), allocatable :: ci integer :: n, d, h, i, j, k, l n = algebra_dimension (s) d = fundamental_dimension (s) write (u, *) write (u, "(A2,5X)", advance="no") "h:" do i = 1, d j = helicity_index (s, helicity_value (s, i)) write (u, "(1x,I2,5X)", advance="no") helicity_value (s, j) end do write (u, "(8X)", advance="no") write (u, "(1X,A)") "tr" allocate (rd (n,d), source = 0._default) do i = 1, d h = helicity_value (s, i) rd(:,i) = cartan_element (s, h) end do allocate (ci (d-1), source = 0) do k = 1, d-1 ci(k) = cartan_index (s, k) end do write (u, *) do k = 1, d-1 write (u, "('T',I2,':',1X)", advance="no") ci(k) do i = 1, d write (u, 1, advance="no") rd(ci(k),i) end do write (u, "(8X)", advance="no") write (u, 1) sum (rd(ci(k),:)) end do write (u, *) write (u, "(6X)", advance="no") do k = 1, d-1 write (u, "(2X,'T',I2,3X)", advance="no") ci(k) end do write (u, *) do k = 1, d-1 write (u, "('T',I2,2X)", advance="no") ci(k) do l = 1, d-1 write (u, 1, advance="no") dot_product (rd(ci(k),:), rd(ci(l),:)) end do write (u, *) end do 1 format (1x,F7.4) end subroutine cartan_show end subroutine su_algebra_2 @ %def su_algebra_2 @ \subsubsection{Bloch Representation: Cartan Generators} Transform from Bloch vectors to matrix and back, considering Cartan generators only. <>= call test (su_algebra_3, "su_algebra_3", & "Cartan generator mapping", & u, results) <>= public :: su_algebra_3 <>= subroutine su_algebra_3 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: su_algebra_3" write (u, "(A)") "* Purpose: test su(N) algebra implementation" write (u, "(A)") write (u, "(A)") "* diagonal su(N) generators: & &transform to matrix and back" write (u, "(A)") write (u, "(A)") "* s = 1/2" call cartan_expand (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call cartan_expand (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call cartan_expand (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call cartan_expand (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: su_algebra_3" contains subroutine cartan_expand (s) integer, intent(in) :: s real(default), dimension(:,:), allocatable :: rd integer, dimension(:), allocatable :: ci real(default), dimension(:), allocatable :: a logical, dimension(:), allocatable :: mask integer :: n, d, h, i, k, l n = algebra_dimension (s) d = fundamental_dimension (s) allocate (rd (n,d), source = 0._default) do i = 1, d h = helicity_value (s, i) rd(:,i) = cartan_element (s, h) end do allocate (ci (d-1), source = 0) do k = 1, d-1 ci(k) = cartan_index (s, k) end do allocate (a (n)) write (u, *) do k = 1, d-1 a(:) = cartan_coeff (s, rd(ci(k),:)) write (u, "('T',I2,':',1X)", advance="no") ci(k) do i = 1, n if (is_cartan_generator (s, i)) then write (u, 1, advance="no") a(i) else if (a(i) /= 0) then ! this should not happen (nonzero non-Cartan entry) write (u, "(1X,':',I2,':',3X)", advance="no") i end if end do write (u, *) end do 1 format (1X,F7.4) end subroutine cartan_expand end subroutine su_algebra_3 @ %def su_algebra_3 @ \subsubsection{Bloch Representation: Roots} List the mapping between helicity transitions and (real) off-diagonal generators. <>= call test (su_algebra_4, "su_algebra_4", & "Root-helicity mapping", & u, results) <>= public :: su_algebra_4 <>= subroutine su_algebra_4 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: su_algebra_4" write (u, "(A)") "* Purpose: test su(N) algebra implementation" write (u, "(A)") write (u, "(A)") "* off-diagonal su(N) generators: & &mapping from/to helicity pair" write (u, "(A)") write (u, "(A)") "* s = 1/2" call root_expand (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call root_expand (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call root_expand (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call root_expand (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: su_algebra_4" contains subroutine root_expand (s) integer, intent(in) :: s integer :: n, d, i, j, h1, h2 logical :: r n = algebra_dimension (s) write (u, *) do i = 1, n if (is_cartan_generator (s, i)) cycle call root_helicity (s, i, h1, h2, r) j = root_index (s, h1, h2, r) write (u, "('T',I2,':')", advance="no") j write (u, "(2(1x,I2))", advance="no") h1, h2 if (r) then write (u, *) else write (u, "('*')") end if end do end subroutine root_expand end subroutine su_algebra_4 @ %def su_algebra_4 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Bloch Representation} Particle polarization is determined by a particular quantum state which has just helicity information. Physically, this is the spin density matrix $\rho$, where we do not restrict ourselves to pure states. We adopt the phase convention for a spin-1/2 particle that \begin{equation} \rho = \tfrac12(1 + \vec\alpha\cdot\vec\sigma) \end{equation} with the polarization axis $\vec\alpha$. For a particle with arbitrary spin $s$, and thus $N=2s+1$ spin states, we extend the above definition to generalized Bloch form \begin{equation} \rho = \frac1N\left(1 + \sqrt{2N(N-1)}\alpha^aT^a\right) \end{equation} where the $T^a$ ($a=1,\ldots N^2-1$) are a basis of $su(N)$ algebra generators. These $N\times N$ matrices are hermitean, traceless, and orthogonal via \begin{equation} \mathop{\rm Tr}T^aT^b = \frac12 \delta^{ab} \end{equation} In the spin-1/2 case, this reduces to the above (standard Bloch) representation since $T^a = \sigma^a/2$, $a=1,2,3$. For the spin-1 case, we could use $T^a = \lambda^a/2$ with the Gell-Mann matrices, \begin{equation} \rho = \frac13\left(1 + \sqrt{3}\alpha^a\lambda^a\right), \end{equation} The normalization is chosen that $|alpha|\leq 1$ for allowed density matrix, where $|\alpha|=1$ is a necessary, but not sufficient, condition for a pure state. We need a specific choice of basis for a well-defined component representation. The matrix elements of $T^a$ are ordered as $m=\ell,\ell-1,\ldots -\ell$, i.e., from highest down to lowest weight, for both row and column. We list first the generators of the $su(2)$ subalgebras which leave $|m|$ invariant ($|m|\neq 0$): \begin{equation} T^{b+1,b+2,b+3} \equiv \sigma^{1,2,3} \end{equation} acting on the respective subspace $|m|=\ell,\ell-1,\ldots$ for $b=0,1,\ldots$. This defines generators $T^a$ for $a=1,\ldots 3N/2$ ($\ldots 3(N-1)/2$) for $N$ even (odd), respectively. The following generators successively extend this to $su(4)$, $su(6)$, \ldots until $su(N)$ by adding first the missing off-diagonal and then diagonal generators. The phase conventions are analogous. (It should be possible to code these conventions for generic spin, but in the current implementation we restrict ourselves to $s\leq 2$, i.e., $N\leq 5$.) Particle polarization is determined by a particular quantum state which has just helicity information. Physically, this is the spin density matrix $\rho$, where we do not restrict ourselves to pure states. We adopt the phase convention for a spin-1/2 particle that \begin{equation} \rho = \tfrac12(1 + \vec\alpha\cdot\vec\sigma) \end{equation} with the polarization axis $\vec\alpha$. For a particle with arbitrary spin $s$, and thus $N=2s+1$ spin states, we extend the above definition to generalized Bloch form \begin{equation} \rho = \frac1N\left(1 + \sqrt{2N(N-1)}\alpha^aT^a\right) \end{equation} where the $T^a$ ($a=1,\ldots N^2-1$) are a basis of $su(N)$ algebra generators. These $N\times N$ matrices are hermitean, traceless, and orthogonal via \begin{equation} \mathop{\rm Tr}T^aT^b = \frac12 \delta^{ab} \end{equation} In the spin-1/2 case, this reduces to the above (standard Bloch) representation since $T^a = \sigma^a/2$, $a=1,2,3$. For the spin-1 case, we could use $T^a = \lambda^a/2$ with the Gell-Mann matrices, \begin{equation} \rho = \frac13\left(1 + \sqrt{3}\alpha^a\lambda^a\right), \end{equation} The normalization is chosen that $|alpha|\leq 1$ for allowed density matrix, where $|\alpha|=1$ is a necessary, but not sufficient, condition for a pure state. <<[[bloch_vectors.f90]]>>= <> module bloch_vectors <> use physics_defs, only: UNKNOWN, SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR use su_algebra <> <> <> contains <> end module bloch_vectors @ %def bloch_vectors @ \subsection{Preliminaries} The normalization factor $\sqrt{2N(N-1)}/N$ that enters the Bloch representation. <>= function bloch_factor (s) result (f) real(default) :: f integer, intent(in) :: s select case (s) case (SCALAR) f = 0 case (SPINOR) f = 1 case (VECTOR) f = 2 * sqrt (3._default) / 3 case (VECTORSPINOR) f = 2 * sqrt (6._default) / 4 case (TENSOR) f = 2 * sqrt (10._default) / 5 case default f = 0 end select end function bloch_factor @ %def bloch_factor @ \subsection{The basic polarization type} The basic polarization object holds just the entries of the Bloch vector as an allocatable array. Bloch is active whenever the coefficient array is allocated. For convenience, we store the spin type ($2s$) and the multiplicity ($N$) together with the coefficient array ($\alpha$). We have to allow for the massless case where $s$ is arbitrary $>0$ but $N=2$, and furthermore the chiral massless case where $N=1$. In the latter case, the array remains deallocated but the chirality is set to $\pm 1$. In the Bloch vector implementation, we do not distinguish between particle and antiparticle. If the distinction applies, it must be made by the caller when transforming between density matrix and Bloch vector. <>= public :: bloch_vector_t <>= type :: bloch_vector_t private integer :: spin_type = UNKNOWN real(default), dimension(:), allocatable :: a contains <> end type bloch_vector_t @ %def bloch_vector_t @ \subsection{Direct Access} This basic initializer just sets the spin type, leaving the Bloch vector unallocated. The object therefore does not support nonzero polarization. <>= procedure :: init_unpolarized => bloch_vector_init_unpolarized <>= subroutine bloch_vector_init_unpolarized (pol, spin_type) class(bloch_vector_t), intent(out) :: pol integer, intent(in) :: spin_type pol%spin_type = spin_type end subroutine bloch_vector_init_unpolarized @ %def bloch_vector_init_unpolarized @ The standard initializer allocates the Bloch vector and initializes with zeros, so we can define a polarization later. We make sure that this works only for the supported spin type. Initializing with [[UNKNOWN]] spin type resets the Bloch vector to undefined, i.e., unpolarized state. <>= generic :: init => bloch_vector_init procedure, private :: bloch_vector_init <>= subroutine bloch_vector_init (pol, spin_type) class(bloch_vector_t), intent(out) :: pol integer, intent(in) :: spin_type pol%spin_type = spin_type select case (spin_type) case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR) allocate (pol%a (algebra_dimension (spin_type)), source = 0._default) end select end subroutine bloch_vector_init @ %def bloch_vector_init @ Fill the Bloch vector from an array, no change of normalization. No initialization and no check, we assume that the shapes do match. <>= procedure :: from_array => bloch_vector_from_array <>= subroutine bloch_vector_from_array (pol, a) class(bloch_vector_t), intent(inout) :: pol real(default), dimension(:), allocatable, intent(in) :: a pol%a(:) = a end subroutine bloch_vector_from_array @ %def bloch_vector_from_array @ Transform to an array of reals, i.e., extract the Bloch vector as-is. <>= procedure :: to_array => bloch_vector_to_array <>= subroutine bloch_vector_to_array (pol, a) class(bloch_vector_t), intent(in) :: pol real(default), dimension(:), allocatable, intent(out) :: a if (pol%is_defined ()) allocate (a (size (pol%a)), source = pol%a) end subroutine bloch_vector_to_array @ %def bloch_vector_to_array @ \subsection{Raw I/O} <>= procedure :: write_raw => bloch_vector_write_raw procedure :: read_raw => bloch_vector_read_raw <>= subroutine bloch_vector_write_raw (pol, u) class(bloch_vector_t), intent(in) :: pol integer, intent(in) :: u write (u) pol%spin_type write (u) allocated (pol%a) if (allocated (pol%a)) then write (u) pol%a end if end subroutine bloch_vector_write_raw subroutine bloch_vector_read_raw (pol, u, iostat) class(bloch_vector_t), intent(out) :: pol integer, intent(in) :: u integer, intent(out) :: iostat integer :: s logical :: polarized read (u, iostat=iostat) s read (u, iostat=iostat) polarized if (iostat /= 0) return if (polarized) then call pol%init (s) read (u, iostat=iostat) pol%a else call pol%init_unpolarized (s) end if end subroutine bloch_vector_read_raw @ %def bloch_vector_write_raw @ %def bloch_vector_read_raw @ \subsection{Properties} Re-export algebra functions that depend on the spin type. These functions do not depend on the Bloch vector being allocated. <>= procedure :: get_n_states procedure :: get_length procedure :: hel_index => bv_helicity_index procedure :: hel_value => bv_helicity_value procedure :: bloch_factor => bv_factor <>= function get_n_states (pol) result (n) class(bloch_vector_t), intent(in) :: pol integer :: n n = fundamental_dimension (pol%spin_type) end function get_n_states function get_length (pol) result (n) class(bloch_vector_t), intent(in) :: pol integer :: n n = algebra_dimension (pol%spin_type) end function get_length function bv_helicity_index (pol, h) result (i) class(bloch_vector_t), intent(in) :: pol integer, intent(in) :: h integer :: i i = helicity_index (pol%spin_type, h) end function bv_helicity_index function bv_helicity_value (pol, i) result (h) class(bloch_vector_t), intent(in) :: pol integer, intent(in) :: i integer :: h h = helicity_value (pol%spin_type, i) end function bv_helicity_value function bv_factor (pol) result (f) class(bloch_vector_t), intent(in) :: pol real(default) :: f f = bloch_factor (pol%spin_type) end function bv_factor @ %def get_n_states @ %def helicity_index @ %def helicity_value @ If the Bloch vector object is defined, the spin type is anything else but [[UNKNOWN]]. This allows us the provide the representation-specific functions above. <>= procedure :: is_defined => bloch_vector_is_defined <>= function bloch_vector_is_defined (pol) result (flag) class(bloch_vector_t), intent(in) :: pol logical :: flag flag = pol%spin_type /= UNKNOWN end function bloch_vector_is_defined @ %def bloch_vector_is_defined @ If the Bloch vector object is (technically) polarized, it is defined, and the vector coefficient array has been allocated. However, the vector value may be zero. <>= procedure :: is_polarized => bloch_vector_is_polarized <>= function bloch_vector_is_polarized (pol) result (flag) class(bloch_vector_t), intent(in) :: pol logical :: flag flag = allocated (pol%a) end function bloch_vector_is_polarized @ %def bloch_vector_is_polarized @ Return true if the polarization is diagonal, i.e., all entries in the density matrix are on the diagonal. This is equivalent to requiring that only Cartan generator coefficients are nonzero in the Bloch vector. <>= procedure :: is_diagonal => bloch_vector_is_diagonal <>= function bloch_vector_is_diagonal (pol) result (diagonal) class(bloch_vector_t), intent(in) :: pol logical :: diagonal integer :: s, i s = pol%spin_type diagonal = .true. if (pol%is_polarized ()) then do i = 1, size (pol%a) if (is_cartan_generator (s, i)) cycle if (pol%a(i) /= 0) then diagonal = .false. return end if end do end if end function bloch_vector_is_diagonal @ %def bloch_vector_is_diagonal @ Return the Euclidean norm of the Bloch vector. This is equal to the Killing form value of the corresponding algebra generator. We assume that the polarization object has been initialized. For a pure state, the norm is unity. All other allowed states have a norm less than unity. (For $s\geq 1$, this is a necessary but not sufficient condition.) <>= procedure :: get_norm => bloch_vector_get_norm <>= function bloch_vector_get_norm (pol) result (norm) class(bloch_vector_t), intent(in) :: pol real(default) :: norm select case (pol%spin_type) case (SPINOR,VECTOR,VECTORSPINOR,TENSOR) norm = sqrt (dot_product (pol%a, pol%a)) case default norm = 1 end select end function bloch_vector_get_norm @ %def bloch_vector_get_norm @ \subsection{Diagonal density matrix} This initializer takes a diagonal density matrix, represented by a real-valued array. We assume that the trace is unity, and that the array has the correct shape for the given [[spin_type]]. The [[bloch_factor]] renormalization is necessary such that a pure state maps to a Bloch vector with unit norm. <>= generic :: init => bloch_vector_init_diagonal procedure, private :: bloch_vector_init_diagonal <>= subroutine bloch_vector_init_diagonal (pol, spin_type, rd) class(bloch_vector_t), intent(out) :: pol integer, intent(in) :: spin_type real(default), dimension(:), intent(in) :: rd call pol%init (spin_type) call pol%set (rd) end subroutine bloch_vector_init_diagonal @ %def bloch_vector_init_diagonal @ Set a Bloch vector, given a diagonal density matrix as a real array. The Bloch vector must be initialized with correct characteristics. <>= generic :: set => bloch_vector_set_diagonal procedure, private :: bloch_vector_set_diagonal <>= subroutine bloch_vector_set_diagonal (pol, rd) class(bloch_vector_t), intent(inout) :: pol real(default), dimension(:), intent(in) :: rd integer :: s s = pol%spin_type select case (s) case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR) pol%a(:) = cartan_coeff (s, rd) / bloch_factor (s) end select end subroutine bloch_vector_set_diagonal @ %def bloch_vector_set_diagonal @ @ \subsection{Massless density matrix} This is a specific variant which initializes an equipartition for the maximum helicity, corresponding to an unpolarized massless particle. <>= procedure :: init_max_weight => bloch_vector_init_max_weight <>= subroutine bloch_vector_init_max_weight (pol, spin_type) class(bloch_vector_t), intent(out) :: pol integer, intent(in) :: spin_type call pol%init (spin_type) select case (spin_type) case (VECTOR) call pol%set ([0.5_default, 0._default, 0.5_default]) case (VECTORSPINOR) call pol%set ([0.5_default, 0._default, 0._default, 0.5_default]) case (TENSOR) call pol%set ([0.5_default, 0._default, 0._default, 0._default, 0.5_default]) end select end subroutine bloch_vector_init_max_weight @ %def bloch_vector_init_max_weight @ Initialize the maximum-weight submatrix with a three-component Bloch vector. This is not as trivial as it seems because we need the above initialization for the generalized Bloch in order to remove the lower weights from the density matrix. <>= procedure :: init_vector => bloch_vector_init_vector procedure :: to_vector => bloch_vector_to_vector <>= subroutine bloch_vector_init_vector (pol, s, a) class(bloch_vector_t), intent(out) :: pol integer, intent(in) :: s real(default), dimension(3), intent(in) :: a call pol%init_max_weight (s) select case (s) case (SPINOR, VECTOR, VECTORSPINOR, TENSOR) pol%a(1:3) = a / bloch_factor (s) end select end subroutine bloch_vector_init_vector subroutine bloch_vector_to_vector (pol, a) class(bloch_vector_t), intent(in) :: pol real(default), dimension(3), intent(out) :: a integer :: s s = pol%spin_type select case (s) case (SPINOR, VECTOR, VECTORSPINOR, TENSOR) a = pol%a(1:3) * bloch_factor (s) case default a = 0 end select end subroutine bloch_vector_to_vector @ %def bloch_vector_init_vector @ %def bloch_vector_to_vector @ \subsection{Arbitrary density matrix} Initialize the Bloch vector from a density matrix. We assume that the density is valid. In particular, the shape should match, the matrix should be hermitian, and the trace should be unity. We first fill the diagonal, then add the off-diagonal parts. <>= generic :: init => bloch_vector_init_matrix procedure, private :: bloch_vector_init_matrix <>= subroutine bloch_vector_init_matrix (pol, spin_type, r) class(bloch_vector_t), intent(out) :: pol integer, intent(in) :: spin_type complex(default), dimension(:,:), intent(in) :: r select case (spin_type) case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR) call pol%init (spin_type) call pol%set (r) case default call pol%init (UNKNOWN) end select end subroutine bloch_vector_init_matrix @ %def bloch_vector_init_matrix @ Set a Bloch vector, given an arbitrary density matrix as a real array. The Bloch vector must be initialized with correct characteristics. <>= generic :: set => bloch_vector_set_matrix procedure, private :: bloch_vector_set_matrix <>= subroutine bloch_vector_set_matrix (pol, r) class(bloch_vector_t), intent(inout) :: pol complex(default), dimension(:,:), intent(in) :: r real(default), dimension(:), allocatable :: rd integer :: s, d, i, j, h1, h2, ir, ii s = pol%spin_type select case (s) case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR) d = fundamental_dimension (s) allocate (rd (d)) do i = 1, d rd(i) = r(i,i) end do call pol%set (rd) do i = 1, d h1 = helicity_value (s, i) do j = i+1, d h2 = helicity_value (s, j) ir = root_index (s, h1, h2, .true.) ii = root_index (s, h1, h2, .false.) pol%a(ir) = real (r(j,i) + r(i,j)) / bloch_factor (s) pol%a(ii) = aimag (r(j,i) - r(i,j)) / bloch_factor (s) end do end do end select end subroutine bloch_vector_set_matrix @ %def bloch_vector_set_matrix @ Allocate and fill the density matrix [[r]] (with the index ordering as defined in [[su_algebra]]) that corresponds to a given Bloch vector. If the optional [[only_max_weight]] is set, the resulting matrix has entries only for $\pm h_\text{max}$, as appropriate for a massless particle (for spin $\geq 1$). Note that we always add the unit matrix, as this is part of the Bloch-vector definition. <>= procedure :: to_matrix => bloch_vector_to_matrix <>= subroutine bloch_vector_to_matrix (pol, r, only_max_weight) class(bloch_vector_t), intent(in) :: pol complex(default), dimension(:,:), intent(out), allocatable :: r logical, intent(in), optional :: only_max_weight integer :: d, s, h0, ng, ai, h, h1, h2, i, j logical :: is_real, only_max complex(default) :: val if (.not. pol%is_polarized ()) return s = pol%spin_type only_max = .false. select case (s) case (VECTOR, VECTORSPINOR, TENSOR) if (present (only_max_weight)) only_max = only_max_weight end select if (only_max) then ng = 2 h0 = helicity_value (s, 1) else ng = algebra_dimension (s) h0 = 0 end if d = fundamental_dimension (s) allocate (r (d, d), source = (0._default, 0._default)) do i = 1, d h = helicity_value (s, i) if (abs (h) < h0) cycle r(i,i) = 1._default / d & + dot_product (cartan_element (s, h), pol%a) * bloch_factor (s) end do do ai = 1, ng if (is_cartan_generator (s, ai)) cycle call root_helicity (s, ai, h1, h2, is_real) i = helicity_index (s, h1) j = helicity_index (s, h2) if (is_real) then val = cmplx (pol%a(ai) / 2 * bloch_factor (s), 0._default, & kind=default) r(i,j) = r(i,j) + val r(j,i) = r(j,i) + val else val = cmplx (0._default, pol%a(ai) / 2 * bloch_factor (s), & kind=default) r(i,j) = r(i,j) - val r(j,i) = r(j,i) + val end if end do end subroutine bloch_vector_to_matrix @ %def bloch_vector_to_matrix @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[bloch_vectors_ut.f90]]>>= <> module bloch_vectors_ut use unit_tests use bloch_vectors_uti <> <> contains <> end module bloch_vectors_ut @ %def bloch_vectors_ut @ <<[[bloch_vectors_uti.f90]]>>= <> module bloch_vectors_uti <> use physics_defs, only: UNKNOWN, SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR use su_algebra, only: algebra_dimension, fundamental_dimension, helicity_value use bloch_vectors <> <> contains <> end module bloch_vectors_uti @ %def bloch_vectors_ut @ API: driver for the unit tests below. <>= public :: bloch_vectors_test <>= subroutine bloch_vectors_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine bloch_vectors_test @ %def bloch_vectors_test @ \subsubsection{Initialization} Initialize the Bloch vector for any spin type. First as unpolarized (no array), then as polarized but with zero polarization. <>= call test (bloch_vectors_1, "bloch_vectors_1", & "initialization", & u, results) <>= public :: bloch_vectors_1 <>= subroutine bloch_vectors_1 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: bloch_vectors_1" write (u, "(A)") "* Purpose: test Bloch-vector & &polarization implementation" write (u, "(A)") write (u, "(A)") "* Initialization (unpolarized)" write (u, "(A)") write (u, "(A)") "* unknown" call bloch_init (UNKNOWN) write (u, "(A)") write (u, "(A)") "* s = 0" call bloch_init (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call bloch_init (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call bloch_init (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call bloch_init (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call bloch_init (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: bloch_vectors_1" contains subroutine bloch_init (s) integer, intent(in) :: s type(bloch_vector_t) :: pol real(default), dimension(:), allocatable :: a integer :: i write (u, *) write (u, "(1X,L1,L1)", advance="no") & pol%is_defined (), pol%is_polarized () call pol%init_unpolarized (s) write (u, "(1X,L1,L1)", advance="no") & pol%is_defined (), pol%is_polarized () call pol%init (s) write (u, "(1X,L1,L1)", advance="no") & pol%is_defined (), pol%is_polarized () write (u, *) call pol%to_array (a) if (allocated (a)) then write (u, "(*(F7.4))") a a(:) = [(real (mod (i, 10), kind=default), i = 1, size (a))] call pol%from_array (a) call pol%to_array (a) write (u, "(*(F7.4))") a else write (u, *) write (u, *) end if end subroutine bloch_init end subroutine bloch_vectors_1 @ %def bloch_vectors_1 @ \subsubsection{Pure state (diagonal)} Initialize the Bloch vector with a pure state of definite helicity and check the normalization. <>= call test (bloch_vectors_2, "bloch_vectors_2", & "pure state (diagonal)", & u, results) <>= public :: bloch_vectors_2 <>= subroutine bloch_vectors_2 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: bloch_vectors_2" write (u, "(A)") "* Purpose: test Bloch-vector & &polarization implementation" write (u, "(A)") write (u, "(A)") "* Initialization (polarized, diagonal): & &display vector and norm" write (u, "(A)") "* transform back" write (u, "(A)") write (u, "(A)") "* s = 0" call bloch_diagonal (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call bloch_diagonal (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call bloch_diagonal (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call bloch_diagonal (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call bloch_diagonal (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: bloch_vectors_2" contains subroutine bloch_diagonal (s) integer, intent(in) :: s type(bloch_vector_t) :: pol real(default), dimension(:), allocatable :: a real(default), dimension(:), allocatable :: rd complex(default), dimension(:,:), allocatable :: r integer :: i, j, d real(default) :: rj real, parameter :: tolerance = 1.E-14_default d = fundamental_dimension (s) do i = 1, d allocate (rd (d), source = 0._default) rd(i) = 1 call pol%init (s, rd) call pol%to_array (a) write (u, *) write (u, "(A,1X,I2)") "h:", helicity_value (s, i) write (u, 1, advance="no") a write (u, "(1X,L1)") pol%is_diagonal () write (u, 1) pol%get_norm () call pol%to_matrix (r) do j = 1, d rj = real (r(j,j)) if (abs (rj) < tolerance) rj = 0 write (u, 1, advance="no") rj end do write (u, "(1X,L1)") matrix_is_diagonal (r) deallocate (a, rd, r) end do 1 format (99(1X,F7.4,:)) end subroutine bloch_diagonal function matrix_is_diagonal (r) result (diagonal) complex(default), dimension(:,:), intent(in) :: r logical :: diagonal integer :: i, j diagonal = .true. do j = 1, size (r, 2) do i = 1, size (r, 1) if (i == j) cycle if (r(i,j) /= 0) then diagonal = .false. return end if end do end do end function matrix_is_diagonal end subroutine bloch_vectors_2 @ %def bloch_vectors_2 @ \subsubsection{Pure state (arbitrary)} Initialize the Bloch vector with an arbitrarily chosen pure state, check the normalization, and transform back to the density matrix. <>= call test (bloch_vectors_3, "bloch_vectors_3", & "pure state (arbitrary)", & u, results) <>= public :: bloch_vectors_3 <>= subroutine bloch_vectors_3 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: bloch_vectors_3" write (u, "(A)") "* Purpose: test Bloch-vector & &polarization implementation" write (u, "(A)") write (u, "(A)") "* Initialization (pure polarized, arbitrary):" write (u, "(A)") "* input matrix, transform, display norm, transform back" write (u, "(A)") write (u, "(A)") "* s = 0" call bloch_arbitrary (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call bloch_arbitrary (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call bloch_arbitrary (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call bloch_arbitrary (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call bloch_arbitrary (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: bloch_vectors_3" contains subroutine bloch_arbitrary (s) integer, intent(in) :: s type(bloch_vector_t) :: pol complex(default), dimension(:,:), allocatable :: r integer :: d d = fundamental_dimension (s) write (u, *) call init_matrix (d, r) call write_matrix (d, r) call pol%init (s, r) write (u, *) write (u, 2) pol%get_norm (), pol%is_diagonal () write (u, *) call pol%to_matrix (r) call write_matrix (d, r) 2 format (1X,F7.4,1X,L1) end subroutine bloch_arbitrary subroutine init_matrix (d, r) integer, intent(in) :: d complex(default), dimension(:,:), allocatable, intent(out) :: r complex(default), dimension(:), allocatable :: a real(default) :: norm integer :: i, j allocate (a (d)) norm = 0 do i = 1, d a(i) = cmplx (2*i-1, 2*i, kind=default) norm = norm + conjg (a(i)) * a(i) end do a = a / sqrt (norm) allocate (r (d,d)) do i = 1, d do j = 1, d r(i,j) = conjg (a(i)) * a(j) end do end do end subroutine init_matrix subroutine write_matrix (d, r) integer, intent(in) :: d complex(default), dimension(:,:), intent(in) :: r integer :: i, j do i = 1, d do j = 1, d write (u, 1, advance="no") r(i,j) end do write (u, *) end do 1 format (99(1X,'(',F7.4,',',F7.4,')',:)) end subroutine write_matrix end subroutine bloch_vectors_3 @ %def bloch_vectors_3 @ \subsubsection{Raw I/O} Check correct input/output in raw format. <>= call test (bloch_vectors_4, "bloch_vectors_4", & "raw I/O", & u, results) <>= public :: bloch_vectors_4 <>= subroutine bloch_vectors_4 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: bloch_vectors_4" write (u, "(A)") "* Purpose: test Bloch-vector & &polarization implementation" write (u, "(A)") write (u, "(A)") "* Raw I/O" write (u, "(A)") write (u, "(A)") "* s = 0" call bloch_io (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call bloch_io (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call bloch_io (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call bloch_io (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call bloch_io (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: bloch_vectors_4" contains subroutine bloch_io (s) integer, intent(in) :: s type(bloch_vector_t) :: pol real(default), dimension(:), allocatable :: a integer :: n, i, utmp, iostat n = algebra_dimension (s) allocate (a (n)) a(:) = [(real (mod (i, 10), kind=default), i = 1, size (a))] write (u, *) write (u, "(*(F7.4))") a call pol%init (s) call pol%from_array (a) open (newunit = utmp, status = "scratch", action = "readwrite", & form = "unformatted") call pol%write_raw (utmp) rewind (utmp) call pol%read_raw (utmp, iostat=iostat) close (utmp) call pol%to_array (a) write (u, "(*(F7.4))") a end subroutine bloch_io end subroutine bloch_vectors_4 @ %def bloch_vectors_4 @ \subsubsection{Convenience Methods} Check some further TBP that are called by the [[polarizations]] module. <>= call test (bloch_vectors_5, "bloch_vectors_5", & "massless state (unpolarized)", & u, results) <>= public :: bloch_vectors_5 <>= subroutine bloch_vectors_5 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: bloch_vectors_5" write (u, "(A)") "* Purpose: test Bloch-vector & &polarization implementation" write (u, "(A)") write (u, "(A)") "* Massless states: equipartition" write (u, "(A)") write (u, "(A)") "* s = 0" call bloch_massless_unpol (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call bloch_massless_unpol (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call bloch_massless_unpol (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call bloch_massless_unpol (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call bloch_massless_unpol (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: bloch_vectors_5" contains subroutine bloch_massless_unpol (s) integer, intent(in) :: s type(bloch_vector_t) :: pol complex(default), dimension(:,:), allocatable :: r real(default), dimension(:), allocatable :: a integer :: d d = fundamental_dimension (s) call pol%init_max_weight (s) call pol%to_matrix (r, only_max_weight = .false.) write (u, *) where (abs (r) < 1.e-14_default) r = 0 call write_matrix (d, r) call pol%to_matrix (r, only_max_weight = .true.) write (u, *) call write_matrix (d, r) end subroutine bloch_massless_unpol subroutine write_matrix (d, r) integer, intent(in) :: d complex(default), dimension(:,:), intent(in) :: r integer :: i, j do i = 1, d do j = 1, d write (u, 1, advance="no") r(i,j) end do write (u, *) end do 1 format (99(1X,'(',F7.4,',',F7.4,')',:)) end subroutine write_matrix end subroutine bloch_vectors_5 @ %def bloch_vectors_5 @ \subsubsection{Massless state (arbitrary)} Initialize the Bloch vector with an arbitrarily chosen pure state which consists only of highest-weight components. Transform back to the density matrix. <>= call test (bloch_vectors_6, "bloch_vectors_6", & "massless state (arbitrary)", & u, results) <>= public :: bloch_vectors_6 <>= subroutine bloch_vectors_6 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: bloch_vectors_6" write (u, "(A)") "* Purpose: test Bloch-vector & &polarization implementation" write (u, "(A)") write (u, "(A)") "* Initialization (pure polarized massless, arbitrary):" write (u, "(A)") "* input matrix, transform, display norm, transform back" write (u, "(A)") write (u, "(A)") "* s = 0" call bloch_massless (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call bloch_massless (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call bloch_massless (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call bloch_massless (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call bloch_massless (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: bloch_vectors_6" contains subroutine bloch_massless (s) integer, intent(in) :: s type(bloch_vector_t) :: pol complex(default), dimension(:,:), allocatable :: r integer :: d d = fundamental_dimension (s) write (u, *) call init_matrix (d, r) call write_matrix (d, r) call pol%init (s, r) write (u, *) write (u, 2) pol%get_norm (), pol%is_diagonal () write (u, *) call pol%to_matrix (r, only_max_weight = .true.) call write_matrix (d, r) 2 format (1X,F7.4,1X,L1) end subroutine bloch_massless subroutine init_matrix (d, r) integer, intent(in) :: d complex(default), dimension(:,:), allocatable, intent(out) :: r complex(default), dimension(:), allocatable :: a real(default) :: norm integer :: i, j allocate (a (d), source = (0._default, 0._default)) norm = 0 do i = 1, d, max (d-1, 1) a(i) = cmplx (2*i-1, 2*i, kind=default) norm = norm + conjg (a(i)) * a(i) end do a = a / sqrt (norm) allocate (r (d,d), source = (0._default, 0._default)) do i = 1, d, max (d-1, 1) do j = 1, d, max (d-1, 1) r(i,j) = conjg (a(i)) * a(j) end do end do end subroutine init_matrix subroutine write_matrix (d, r) integer, intent(in) :: d complex(default), dimension(:,:), intent(in) :: r integer :: i, j do i = 1, d do j = 1, d write (u, 1, advance="no") r(i,j) end do write (u, *) end do 1 format (99(1X,'(',F7.4,',',F7.4,')',:)) end subroutine write_matrix end subroutine bloch_vectors_6 @ %def bloch_vectors_6 @ \subsubsection{Massless state (Bloch vector)} Initialize the (generalized) Bloch vector with an ordinary three-component Bloch vector that applies to the highest-weight part only. <>= call test (bloch_vectors_7, "bloch_vectors_7", & "massless state (vector)", & u, results) <>= public :: bloch_vectors_7 <>= subroutine bloch_vectors_7 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: bloch_vectors_7" write (u, "(A)") "* Purpose: test Bloch-vector & &polarization implementation" write (u, "(A)") write (u, "(A)") "* Initialization & &(pure polarized massless, arbitrary Bloch vector):" write (u, "(A)") "* input vector, transform, display norm, & &transform back" write (u, "(A)") write (u, "(A)") "* s = 0" call bloch_massless_vector (SCALAR) write (u, "(A)") write (u, "(A)") "* s = 1/2" call bloch_massless_vector (SPINOR) write (u, "(A)") write (u, "(A)") "* s = 1" call bloch_massless_vector (VECTOR) write (u, "(A)") write (u, "(A)") "* s = 3/2" call bloch_massless_vector (VECTORSPINOR) write (u, "(A)") write (u, "(A)") "* s = 2" call bloch_massless_vector (TENSOR) write (u, "(A)") write (u, "(A)") "* Test output end: bloch_vectors_7" contains subroutine bloch_massless_vector (s) integer, intent(in) :: s type(bloch_vector_t) :: pol real(default), dimension(3) :: a complex(default), dimension(:,:), allocatable :: r write (u, *) a = [1._default, 2._default, 4._default] a = a / sqrt (sum (a ** 2)) write (u, 2) a call pol%init_vector (s, a) write (u, 2) pol%get_norm () call pol%to_vector (a) write (u, 2) a call pol%to_matrix (r, only_max_weight = .false.) write (u, *) where (abs (r) < 1.e-14_default) r = 0 call write_matrix (r) call pol%to_matrix (r, only_max_weight = .true.) write (u, *) call write_matrix (r) 2 format (99(1X,F7.4,:)) end subroutine bloch_massless_vector subroutine write_matrix (r) complex(default), dimension(:,:), intent(in) :: r integer :: i, j do i = 1, size (r, 1) do j = 1, size (r, 2) write (u, 1, advance="no") r(i,j) end do write (u, *) end do 1 format (99(1X,'(',F7.4,',',F7.4,')',:)) end subroutine write_matrix end subroutine bloch_vectors_7 @ %def bloch_vectors_7 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Polarization} Using generalized Bloch vectors and the $su(N)$ algebra (see above) for the internal representation, we can define various modes of polarization. For spin-1/2, and analogously for massless spin-$s$ particles, we introduce \begin{enumerate} \item Trivial polarization: $\vec\alpha=0$. [This is unpolarized, but distinct from the particular undefined polarization matrix which has the same meaning.] \item Circular polarization: $\vec\alpha$ points in $\pm z$ direction. \item Transversal polarization: $\vec\alpha$ points orthogonal to the $z$ direction, with a phase $\phi$ that is $0$ for the $x$ axis, and $\pi/2=90^\circ$ for the $y$ axis. For antiparticles, the phase switches sign, corresponding to complex conjugation. \item Axis polarization, where we explicitly give $\vec\alpha$. \end{enumerate} For higher spin, we retain this definition, but apply it to the two components with maximum and minimum weight. In effect, we concentrate on the first three entries in the $\alpha^a$ array. For massless particles, this is sufficient. For massive particles, we then add the possibilities: \begin{enumerate}\setcounter{enumi}{4} \item Longitudinal polarization: Only the 0-component is set. This is possible only for bosons. \item Diagonal polarization: Explicitly specify all components in the helicity basis. The $su(N)$ representation consists of diagonal generators only, the Cartan subalgebra. \end{enumerate} Obviously, this does not exhaust the possible density matrices for higher spin, but it should cover practical applications. <<[[polarizations.f90]]>>= <> module polarizations <> use io_units use format_defs, only: FMT_19 use diagnostics use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR use flavors use helicities use quantum_numbers use state_matrices use bloch_vectors <> <> <> <> contains <> end module polarizations @ %def polarizations @ \subsection{The polarization type} Polarization is active whenever the coefficient array is allocated. For convenience, we store the spin type ($2s$) and the multiplicity ($N$) together with the coefficient array ($\alpha$). We have to allow for the massless case where $s$ is arbitrary $>0$ but $N=2$, and furthermore the chiral massless case where $N=1$. In the latter case, the array remains deallocated but the chirality is set to $\pm 1$. There is a convention that an antiparticle transforms according to the complex conjugate representation. We apply this only when transforming from/to polarization defined by a three-vector. For antiparticles, the two-component flips sign in that case. When transforming from/to a state matrix or [[pmatrix]] representation, we do not apply this sign flip. <>= public :: polarization_t <>= type :: polarization_t private integer :: spin_type = SCALAR integer :: multiplicity = 1 integer :: chirality = 0 logical :: anti = .false. type(bloch_vector_t) :: bv contains <> end type polarization_t @ %def polarization_t @ \subsection{Basic initializer and finalizer} We need the particle flavor for determining the allowed helicity values. The Bloch vector is left undefined, so this initializer (in two versions) creates an unpolarized particle. Exception: a chiral particle is always polarized with definite helicity, it doesn't need a Bloch vector. This is private. <>= generic, private :: init => polarization_init, polarization_init_flv procedure, private :: polarization_init procedure, private :: polarization_init_flv <>= subroutine polarization_init (pol, spin_type, multiplicity, & anti, left_handed, right_handed) class(polarization_t), intent(out) :: pol integer, intent(in) :: spin_type integer, intent(in) :: multiplicity logical, intent(in) :: anti logical, intent(in) :: left_handed logical, intent(in) :: right_handed pol%spin_type = spin_type pol%multiplicity = multiplicity pol%anti = anti select case (pol%multiplicity) case (1) if (left_handed) then pol%chirality = -1 else if (right_handed) then pol%chirality = 1 end if end select select case (pol%chirality) case (0) call pol%bv%init_unpolarized (spin_type) end select end subroutine polarization_init subroutine polarization_init_flv (pol, flv) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv call pol%init ( & spin_type = flv%get_spin_type (), & multiplicity = flv%get_multiplicity (), & anti = flv%is_antiparticle (), & left_handed = flv%is_left_handed (), & right_handed = flv%is_right_handed ()) end subroutine polarization_init_flv @ %def polarization_init polarization_init_flv @ Generic polarization: as before, but create a polarized particle (Bloch vector defined) with initial polarization zero. <>= generic :: init_generic => & polarization_init_generic, & polarization_init_generic_flv procedure, private :: polarization_init_generic procedure, private :: polarization_init_generic_flv <>= subroutine polarization_init_generic (pol, spin_type, multiplicity, & anti, left_handed, right_handed) class(polarization_t), intent(out) :: pol integer, intent(in) :: spin_type integer, intent(in) :: multiplicity logical, intent(in) :: anti logical, intent(in) :: left_handed logical, intent(in) :: right_handed call pol%init (spin_type, multiplicity, & anti, left_handed, right_handed) select case (pol%chirality) case (0) if (pol%multiplicity == pol%bv%get_n_states ()) then call pol%bv%init (spin_type) else call pol%bv%init_max_weight (spin_type) end if end select end subroutine polarization_init_generic subroutine polarization_init_generic_flv (pol, flv) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv call pol%init_generic ( & spin_type = flv%get_spin_type (), & multiplicity = flv%get_multiplicity (), & anti = flv%is_antiparticle (), & left_handed = flv%is_left_handed (), & right_handed = flv%is_right_handed ()) end subroutine polarization_init_generic_flv @ %def polarization_init_generic @ A finalizer is no longer necessary. \subsection{I/O} The default setting produces a tabular output of the polarization vector entries. Optionally, we can create a state matrix and write its contents, emulating the obsolete original implementation. If [[all_states]] is true (default), we generate all helity combinations regardless of the matrix-element value. Otherwise, skip helicities with zero entry, or absolute value less than [[tolerance]], if also given. <>= procedure :: write => polarization_write <>= subroutine polarization_write (pol, unit, state_matrix, all_states, tolerance) class(polarization_t), intent(in) :: pol integer, intent(in), optional :: unit logical, intent(in), optional :: state_matrix, all_states real(default), intent(in), optional :: tolerance logical :: state_m type(state_matrix_t) :: state real(default), dimension(:), allocatable :: a integer :: u, i u = given_output_unit (unit); if (u < 0) return state_m = .false.; if (present (state_matrix)) state_m = state_matrix if (pol%anti) then write (u, "(1x,A,I1,A,I1,A,L1,A)") & "Polarization: [spin_type = ", pol%spin_type, & ", mult = ", pol%multiplicity, ", anti = ", pol%anti, "]" else write (u, "(1x,A,I1,A,I1,A)") & "Polarization: [spin_type = ", pol%spin_type, & ", mult = ", pol%multiplicity, "]" end if if (state_m) then call pol%to_state (state, all_states, tolerance) call state%write (unit=unit) call state%final () else if (pol%chirality == 1) then write (u, "(1x,A)") "chirality = +" else if (pol%chirality == -1) then write (u, "(1x,A)") "chirality = -" else if (pol%bv%is_polarized ()) then call pol%bv%to_array (a) do i = 1, size (a) write (u, "(1x,I2,':',1x,F10.7)") i, a(i) end do else write (u, "(1x,A)") "[unpolarized]" end if end subroutine polarization_write @ %def polarization_write @ Binary I/O. <>= procedure :: write_raw => polarization_write_raw procedure :: read_raw => polarization_read_raw <>= subroutine polarization_write_raw (pol, u) class(polarization_t), intent(in) :: pol integer, intent(in) :: u write (u) pol%spin_type write (u) pol%multiplicity write (u) pol%chirality write (u) pol%anti call pol%bv%write_raw (u) end subroutine polarization_write_raw subroutine polarization_read_raw (pol, u, iostat) class(polarization_t), intent(out) :: pol integer, intent(in) :: u integer, intent(out), optional :: iostat read (u, iostat=iostat) pol%spin_type read (u, iostat=iostat) pol%multiplicity read (u, iostat=iostat) pol%chirality read (u, iostat=iostat) pol%anti call pol%bv%read_raw (u, iostat) end subroutine polarization_read_raw @ %def polarization_read_raw @ \subsection{Accessing contents} Return true if the particle is technically polarized. The particle is either chiral, or its Bloch vector has been defined. The function returns true even if the Bloch vector is zero or the particle is scalar. <>= procedure :: is_polarized => polarization_is_polarized <>= function polarization_is_polarized (pol) result (polarized) class(polarization_t), intent(in) :: pol logical :: polarized polarized = pol%chirality /= 0 .or. pol%bv%is_polarized () end function polarization_is_polarized @ %def polarization_is_polarized @ Return true if the polarization is diagonal, i.e., all entries in the density matrix are diagonal. For an unpolarized particle, we also return [[.true.]] since the density matrix is proportional to the unit matrix. <>= procedure :: is_diagonal => polarization_is_diagonal <>= function polarization_is_diagonal (pol) result (diagonal) class(polarization_t), intent(in) :: pol logical :: diagonal select case (pol%chirality) case (0) diagonal = pol%bv%is_diagonal () case default diagonal = .true. end select end function polarization_is_diagonal @ %def polarization_is_diagonal @ \subsection{Mapping between polarization and state matrix} Create the polarization object that corresponds to a state matrix. The state matrix is not necessarily normalized. The result will be either unpolarized, or a generalized Bloch vector that we compute in terms of the appropriate spin generator basis. To this end, we first construct the complete density matrix, then set the Bloch vector with this input. For a naturally chiral particle (i.e., neutrino), we do not set the polarization vector, it is implied. Therefore, we cannot account for any sign flip and transform as-is. <>= procedure :: init_state_matrix => polarization_init_state_matrix <>= subroutine polarization_init_state_matrix (pol, state) class(polarization_t), intent(out) :: pol type(state_matrix_t), intent(in), target :: state type(state_iterator_t) :: it type(flavor_t) :: flv type(helicity_t) :: hel integer :: d, h1, h2, i, j complex(default), dimension(:,:), allocatable :: r complex(default) :: me real(default) :: trace call it%init (state) flv = it%get_flavor (1) hel = it%get_helicity (1) if (hel%is_defined ()) then call pol%init_generic (flv) select case (pol%chirality) case (0) trace = 0 d = pol%bv%get_n_states () allocate (r (d, d), source = (0._default, 0._default)) do while (it%is_valid ()) hel = it%get_helicity (1) call hel%get_indices (h1, h2) i = pol%bv%hel_index (h1) j = pol%bv%hel_index (h2) me = it%get_matrix_element () r(i,j) = me if (i == j) trace = trace + real (me) call it%advance () end do if (trace /= 0) call pol%bv%set (r / trace) end select else call pol%init (flv) end if end subroutine polarization_init_state_matrix @ %def polarization_init_state_matrix @ Create the state matrix that corresponds to a given polarization. We make use of the polarization iterator as defined below, which should iterate according to the canonical helicity ordering. <>= procedure :: to_state => polarization_to_state_matrix <>= subroutine polarization_to_state_matrix (pol, state, all_states, tolerance) class(polarization_t), intent(in), target :: pol type(state_matrix_t), intent(out) :: state logical, intent(in), optional :: all_states real(default), intent(in), optional :: tolerance type(polarization_iterator_t) :: it type(quantum_numbers_t), dimension(1) :: qn complex(default) :: value call it%init (pol, all_states, tolerance) call state%init (store_values = .true.) do while (it%is_valid ()) value = it%get_value () qn(1) = it%get_quantum_numbers () call state%add_state (qn, value = value) call it%advance () end do call state%freeze () end subroutine polarization_to_state_matrix @ %def polarization_to_state_matrix @ \subsection{Specific initializers} Unpolarized particle, no nontrivial entries in the density matrix. This is the default initialization mode. <>= procedure :: init_unpolarized => polarization_init_unpolarized <>= subroutine polarization_init_unpolarized (pol, flv) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv call pol%init (flv) end subroutine polarization_init_unpolarized @ %def polarization_init_unpolarized @ The following three modes are useful mainly for spin-1/2 particle and massless particles of any nonzero spin. Only the highest-weight components are filled. Circular polarization: The density matrix of the two highest-weight states is \begin{equation*} \rho(f) = \frac{1-|f|}{2}\mathbf{1} + |f| \times \begin{cases} \begin{pmatrix} 1 & 0 \\ 0 & 0 \end{pmatrix}, & f > 0; \\[6pt] \begin{pmatrix} 0 & 0 \\ 0 & 1 \end{pmatrix}, & f < 0, \end{cases} \end{equation*} In the generalized Bloch representation, this is an entry for the $T^3$ generator only, regardless of the spin representation. A chiral particle is not affected. <>= procedure :: init_circular => polarization_init_circular <>= subroutine polarization_init_circular (pol, flv, f) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv real(default), intent(in) :: f call pol%init (flv) select case (pol%chirality) case (0) call pol%bv%init_vector (pol%spin_type, & [0._default, 0._default, f]) end select end subroutine polarization_init_circular @ %def polarization_init_circular @ Transversal polarization is analogous to circular, but we get a density matrix \begin{equation*} \rho(f,\phi) = \frac{1-|f|}{2}\mathbf{1} + \frac{|f|}{2} \begin{pmatrix} 1 & e^{-i\phi} \\ e^{i\phi} & 1 \end{pmatrix}. \end{equation*} for the highest-weight subspace. The lower weights are unaffected. The phase is $\phi=0$ for the $x$-axis, $\phi=90^\circ$ for the $y$ axis as polarization vector. For an antiparticle, the phase switches sign, and for $f<0$, the off-diagonal elements switch sign. A chiral particle is not affected. <>= procedure :: init_transversal => polarization_init_transversal <>= subroutine polarization_init_transversal (pol, flv, phi, f) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv real(default), intent(in) :: phi, f call pol%init (flv) select case (pol%chirality) case (0) if (pol%anti) then call pol%bv%init_vector (pol%spin_type, & [f * cos (phi), f * sin (phi), 0._default]) else call pol%bv%init_vector (pol%spin_type, & [f * cos (phi),-f * sin (phi), 0._default]) end if end select end subroutine polarization_init_transversal @ %def polarization_init_transversal @ For axis polarization, we again set only the entries with maximum weight, which for spin $1/2$ means \begin{equation*} \rho(f,\phi) = \frac{1}{2} \begin{pmatrix} 1 + \alpha_3 & \alpha_1 - i\alpha_2 \\ \alpha_1 + i\alpha_2 & 1 - \alpha_3 \end{pmatrix}. \end{equation*} For an antiparticle, the imaginary part proportional to $\alpha_2$ switches sign (complex conjugate). A chiral particle is not affected. In the generalized Bloch representation, this translates into coefficients for $T^{1,2,3}$, all others stay zero. <>= procedure :: init_axis => polarization_init_axis <>= subroutine polarization_init_axis (pol, flv, alpha) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv real(default), dimension(3), intent(in) :: alpha call pol%init (flv) select case (pol%chirality) case (0) if (pol%anti) then call pol%bv%init_vector (pol%spin_type, & [alpha(1), alpha(2), alpha(3)]) else call pol%bv%init_vector (pol%spin_type, & [alpha(1),-alpha(2), alpha(3)]) end if end select end subroutine polarization_init_axis @ %def polarization_init_axis @ This version specifies the polarization axis in terms of $r$ (polarization degree) and $\theta,\phi$ (polar and azimuthal angles). If one of the angles is a nonzero multiple of $\pi$, roundoff errors typically will result in tiny contributions to unwanted components. Therefore, include a catch for small numbers. <>= procedure :: init_angles => polarization_init_angles <>= subroutine polarization_init_angles (pol, flv, r, theta, phi) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv real(default), intent(in) :: r, theta, phi real(default), dimension(3) :: alpha real(default), parameter :: eps = 10 * epsilon (1._default) alpha(1) = r * sin (theta) * cos (phi) alpha(2) = r * sin (theta) * sin (phi) alpha(3) = r * cos (theta) where (abs (alpha) < eps) alpha = 0 call pol%init_axis (flv, alpha) end subroutine polarization_init_angles @ %def polarization_init_angles @ Longitudinal polarization is defined only for massive bosons. Only the zero component is filled. Otherwise, unpolarized. In the generalized Bloch representation, the zero component corresponds to a linear combination of all diagonal (Cartan) generators. <>= procedure :: init_longitudinal => polarization_init_longitudinal <>= subroutine polarization_init_longitudinal (pol, flv, f) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv real(default), intent(in) :: f real(default), dimension(:), allocatable :: rd integer :: s, d s = flv%get_spin_type () select case (s) case (VECTOR, TENSOR) call pol%init_generic (flv) if (pol%bv%is_polarized ()) then d = pol%bv%get_n_states () allocate (rd (d), source = 0._default) rd(pol%bv%hel_index (0)) = f call pol%bv%set (rd) end if case default call pol%init_unpolarized (flv) end select end subroutine polarization_init_longitudinal @ %def polarization_init_longitudinal @ This is diagonal polarization: we specify all components explicitly. [[rd]] is the array of diagonal elements of the density matrix. We assume that the length of [[rd]] is equal to the particle multiplicity. <>= procedure :: init_diagonal => polarization_init_diagonal <>= subroutine polarization_init_diagonal (pol, flv, rd) class(polarization_t), intent(out) :: pol type(flavor_t), intent(in) :: flv real(default), dimension(:), intent(in) :: rd real(default) :: trace call pol%init_generic (flv) if (pol%bv%is_polarized ()) then trace = sum (rd) if (trace /= 0) call pol%bv%set (rd / trace) end if end subroutine polarization_init_diagonal @ %def polarization_init_diagonal @ \subsection{Operations} Combine polarization states by computing the outer product of the state matrices. <>= public :: combine_polarization_states <>= subroutine combine_polarization_states (pol, state) type(polarization_t), dimension(:), intent(in), target :: pol type(state_matrix_t), intent(out) :: state type(state_matrix_t), dimension(size(pol)), target :: pol_state integer :: i do i = 1, size (pol) call pol(i)%to_state (pol_state(i)) end do call outer_multiply (pol_state, state) do i = 1, size (pol) call pol_state(i)%final () end do end subroutine combine_polarization_states @ %def combine_polarization_states @ Transform a polarization density matrix into a polarization vector. This is possible without information loss only for spin-1/2 and for massless particles. To get a unique answer in all cases, we consider only the components with highest weight. Obviously, this loses the longitudinal component of a massive vector, for instance. The norm of the returned axis is the polarization fraction for the highest-weight subspace. For a scalar particle, we return a zero vector. The same result applies if the highest-weight component vanishes. This is the inverse operation of [[polarization_init_axis]] above, where the polarization fraction is set to unity. For an antiparticle, the [[alpha(2)]] coefficient flips sign. <>= procedure :: get_axis => polarization_get_axis <>= function polarization_get_axis (pol) result (alpha) class(polarization_t), intent(in), target :: pol real(default), dimension(3) :: alpha select case (pol%chirality) case (0) call pol%bv%to_vector (alpha) if (.not. pol%anti) alpha(2) = - alpha(2) case (-1) alpha = [0._default, 0._default, -1._default] case (1) alpha = [0._default, 0._default, 1._default] end select end function polarization_get_axis @ %def polarization_get_axis @ This function returns polarization degree and polar and azimuthal angles ($\theta,\phi$) of the polarization axis. The same restrictions apply as above. Since we call the [[get_axis]] method, the phase flips sign for an antiparticle. <>= procedure :: to_angles => polarization_to_angles <>= subroutine polarization_to_angles (pol, r, theta, phi) class(polarization_t), intent(in) :: pol real(default), intent(out) :: r, theta, phi real(default), dimension(3) :: alpha real(default) :: norm, r12 alpha = pol%get_axis () norm = sum (alpha**2) r = sqrt (norm) if (norm > 0) then r12 = sqrt (alpha(1)**2 + alpha(2)**2) theta = atan2 (r12, alpha(3)) if (any (alpha(1:2) /= 0)) then phi = atan2 (alpha(2), alpha(1)) else phi = 0 end if else theta = 0 phi = 0 end if end subroutine polarization_to_angles @ %def polarization_to_angles @ \subsection{Polarization Iterator} The iterator acts like a state matrix iterator, i.e., it points to one helicity combination at a time and can return the corresponding helicity object and matrix-element value. Since the polarization is stored as a Bloch vector, we recover the whole density matrix explicitly upon initialization, store it inside the iterator object, and then just return its elements one at a time. For an unpolarized particle, the iterator returns a single state with undefined helicity. The value is the value of any diagonal density matrix element, $1/n$ where $n$ is the multiplicity. <>= public :: polarization_iterator_t <>= type :: polarization_iterator_t private type(polarization_t), pointer :: pol => null () logical :: polarized = .false. integer :: h1 = 0 integer :: h2 = 0 integer :: i = 0 integer :: j = 0 complex(default), dimension(:,:), allocatable :: r complex(default) :: value = 1._default real(default) :: tolerance = -1._default logical :: valid = .false. contains <> end type polarization_iterator_t @ %def polarization_iterator_t @ Output for debugging purposes only, therefore no format for real/complex. <>= procedure :: write => polarization_iterator_write <>= subroutine polarization_iterator_write (it, unit) class(polarization_iterator_t), intent(in) :: it integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1X,A)") "Polarization iterator:" write (u, "(3X,A,L1)") "assigned = ", associated (it%pol) write (u, "(3X,A,L1)") "valid = ", it%valid if (it%valid) then write (u, "(3X,A,2(1X,I2))") "i, j = ", it%i, it%j write (u, "(3X,A,2(1X,I2))") "h1, h2 = ", it%h1, it%h2 write (u, "(3X,A)", advance="no") "value = " write (u, *) it%value if (allocated (it%r)) then do i = 1, size (it%r, 2) write (u, *) it%r(i,:) end do end if end if end subroutine polarization_iterator_write @ %def polarization_iterator_write @ Initialize, i.e., (virtually) point to the first helicity state supported by the polarization object. If the density matrix is nontrivial, we calculate it here. Following the older state-matrix conventions, the iterator sequence starts at the lowest helicity value. In the current internal representation, this corresponds to the highest index value. If the current matrix-element value is zero, advance the iterator. Advancing will stop at a nonzero value or if the iterator becomes invalid. If [[tolerance]] is given, any state matrix entry less or equal will be treated as zero, causing the iterator to skip an entry. By default, the value is negative, so no entry is skipped. <>= procedure :: init => polarization_iterator_init <>= subroutine polarization_iterator_init (it, pol, all_states, tolerance) class(polarization_iterator_t), intent(out) :: it type(polarization_t), intent(in), target :: pol logical, intent(in), optional :: all_states real(default), intent(in), optional :: tolerance integer :: d logical :: only_max_weight it%pol => pol if (present (all_states)) then if (.not. all_states) then if (present (tolerance)) then it%tolerance = tolerance else it%tolerance = 0 end if end if end if select case (pol%chirality) case (0) d = pol%bv%get_n_states () only_max_weight = pol%multiplicity < d it%polarized = pol%bv%is_polarized () if (it%polarized) then it%i = d it%j = it%i it%h1 = pol%bv%hel_value (it%i) it%h2 = it%h1 call pol%bv%to_matrix (it%r, only_max_weight) it%value = it%r(it%i, it%j) else it%value = 1._default / d end if it%valid = .true. case (1,-1) it%polarized = .true. select case (pol%spin_type) case (SPINOR) it%h1 = pol%chirality case (VECTORSPINOR) it%h1 = 2 * pol%chirality end select it%h2 = it%h1 it%valid = .true. end select if (it%valid .and. abs (it%value) <= it%tolerance) call it%advance () end subroutine polarization_iterator_init @ %def polarization_iterator_init @ Advance to the next valid helicity state. Repeat if the returned value is zero. For an unpolarized object, we iterate through the diagonal helicity states with a constant value. <>= procedure :: advance => polarization_iterator_advance <>= recursive subroutine polarization_iterator_advance (it) class(polarization_iterator_t), intent(inout) :: it if (it%valid) then select case (it%pol%chirality) case (0) if (it%polarized) then if (it%j > 1) then it%j = it%j - 1 it%h2 = it%pol%bv%hel_value (it%j) it%value = it%r(it%i, it%j) else if (it%i > 1) then it%j = it%pol%bv%get_n_states () it%h2 = it%pol%bv%hel_value (it%j) it%i = it%i - 1 it%h1 = it%pol%bv%hel_value (it%i) it%value = it%r(it%i, it%j) else it%valid = .false. end if else it%valid = .false. end if case default it%valid = .false. end select if (it%valid .and. abs (it%value) <= it%tolerance) call it%advance () end if end subroutine polarization_iterator_advance @ %def polarization_iterator_advance @ This is true as long as the iterator points to a valid helicity state. <>= procedure :: is_valid => polarization_iterator_is_valid <>= function polarization_iterator_is_valid (it) result (is_valid) logical :: is_valid class(polarization_iterator_t), intent(in) :: it is_valid = it%valid end function polarization_iterator_is_valid @ %def polarization_iterator_is_valid @ Return the matrix element value for the helicity that we are currently pointing at. <>= procedure :: get_value => polarization_iterator_get_value <>= function polarization_iterator_get_value (it) result (value) complex(default) :: value class(polarization_iterator_t), intent(in) :: it if (it%valid) then value = it%value else value = 0 end if end function polarization_iterator_get_value @ %def polarization_iterator_get_value @ Return a quantum number object for the helicity that we are currently pointing at. This is a single quantum number object, not an array. Note that the [[init]] method of the helicity object has the order reversed. <>= procedure :: get_quantum_numbers => polarization_iterator_get_quantum_numbers <>= function polarization_iterator_get_quantum_numbers (it) result (qn) class(polarization_iterator_t), intent(in) :: it type(helicity_t) :: hel type(quantum_numbers_t) :: qn if (it%polarized) then call hel%init (it%h2, it%h1) end if call qn%init (hel) end function polarization_iterator_get_quantum_numbers @ %def polarization_iterator_get_quantum_numbers @ \subsection{Sparse Matrix} We introduce a simple implementation of a sparse matrix that can represent polarization (or similar concepts) for transfer to I/O within the program. It consists of an integer array that represents the index values, and a complex array that represents the nonvanishing entries. The number of nonvanishing entries must be known for initialization, but the entries are filled one at a time. Here is a base type without the special properties of a spin-density matrix. <>= public :: smatrix_t <>= type :: smatrix_t private integer :: dim = 0 integer :: n_entry = 0 integer, dimension(:,:), allocatable :: index complex(default), dimension(:), allocatable :: value contains <> end type smatrix_t @ %def smatrix_t @ Output. <>= procedure :: write => smatrix_write <>= subroutine smatrix_write (object, unit, indent) class(smatrix_t), intent(in) :: object integer, intent(in), optional :: unit, indent integer :: u, i, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent if (allocated (object%value)) then if (size (object%value) > 0) then do i = 1, object%n_entry write (u, "(1x,A,'@(')", advance="no") repeat (" ", ind) write (u, "(SP,9999(I2.1,':',1x))", advance="no") & object%index(:,i) write (u, "('('," // FMT_19 // ",','," // FMT_19 // & ",'))')") object%value(i) end do else write (u, "(1x,A)", advance="no") repeat (" ", ind) write (u, "(A)") "[empty matrix]" end if else write (u, "(1x,A)", advance="no") repeat (" ", ind) write (u, "(A)") "[undefined matrix]" end if end subroutine smatrix_write @ %def smatrix_write @ Initialization: allocate arrays to the correct size. We specify both the dimension of the matrix (if different from two, this is rather a generic tensor) and the number of nonvanishing entries. <>= procedure :: init => smatrix_init <>= subroutine smatrix_init (smatrix, dim, n_entry) class(smatrix_t), intent(out) :: smatrix integer, intent(in) :: dim integer, intent(in) :: n_entry smatrix%dim = dim smatrix%n_entry = n_entry allocate (smatrix%index (dim, n_entry)) allocate (smatrix%value (n_entry)) end subroutine smatrix_init @ %def smatrix_init @ Fill: one entry at a time. <>= procedure :: set_entry => smatrix_set_entry <>= subroutine smatrix_set_entry (smatrix, i, index, value) class(smatrix_t), intent(inout) :: smatrix integer, intent(in) :: i integer, dimension(:), intent(in) :: index complex(default), intent(in) :: value smatrix%index(:,i) = index smatrix%value(i) = value end subroutine smatrix_set_entry @ %def smatrix_set_entry @ <>= procedure :: exists => smatrix_exists <>= elemental function smatrix_exists (smatrix) result (exist) logical :: exist class(smatrix_t), intent(in) :: smatrix exist = .not. all (smatrix%value == 0) end function smatrix_exists @ %def smatrix_exists @ \subsection{Polarization Matrix} As an extension of the more generic [[smatrix]] type, we implement a proper spin-density matrix. After the matrix has been filled, we can fix spin type and multiplicity for a particle, check the matrix for consistency, and normalize it if necessary. This implementation does not have an antiparticle flag, just like the state matrix object. We therefore cannot account for sign flips when using this object. TODO: The [[pure]] flag is for informational purposes only, and it only represents a necessary condition if spin is greater than $1/2$. We may either check purity for all spins or drop this. <>= public :: pmatrix_t <>= type, extends (smatrix_t) :: pmatrix_t private integer :: spin_type = 0 integer :: multiplicity = 0 logical :: massive = .true. integer :: chirality = 0 real(default) :: degree = 1 logical :: pure = .false. contains <> end type pmatrix_t @ %def pmatrix_t @ Output, including extra data. (The [[indent]] argument is ignored.) <>= procedure :: write => pmatrix_write <>= subroutine pmatrix_write (object, unit, indent) class(pmatrix_t), intent(in) :: object integer, intent(in), optional :: unit, indent integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Polarization: spin density matrix" write (u, "(3x,A,I0)") "spin type = ", object%spin_type write (u, "(3x,A,I0)") "multiplicity = ", object%multiplicity write (u, "(3x,A,L1)") "massive = ", object%massive write (u, "(3x,A,I0)") "chirality = ", object%chirality write (u, "(3x,A,F10.7)") "pol.degree =", object%degree write (u, "(3x,A,L1)") "pure state = ", object%pure call object%smatrix_t%write (u, 1) end subroutine pmatrix_write @ %def pmatrix_write @ This assignment is trivial, but must be coded explicitly. <>= generic :: assignment(=) => pmatrix_assign_from_smatrix procedure, private :: pmatrix_assign_from_smatrix <>= subroutine pmatrix_assign_from_smatrix (pmatrix, smatrix) class(pmatrix_t), intent(out) :: pmatrix type(smatrix_t), intent(in) :: smatrix pmatrix%smatrix_t = smatrix end subroutine pmatrix_assign_from_smatrix @ %def pmatrix_assign_from_smatrix @ Declare spin, multiplicity, and polarization degree. Check whether all entries fit, and whether this is a valid matrix. The required properties are: \begin{enumerate} \item all entries apply to the given spin and mass type \item the diagonal is real \item only the upper of corresponding off-diagonal elements is specified, i.e., the row index is less than the column index \item the trace is nonnegative and equal to the polarization degree (the remainder, proportional to the unit matrix, is understood to be present) \item the trace of the matrix square is positive and less or equal to the trace of the matrix itself, which is the polarization degree. \item If the trace of the matrix square and the trace of the matrix are unity, we may have a pure state. (For spin up to $1/2$, this is actually sufficient.) \end{enumerate} <>= procedure :: normalize => pmatrix_normalize <>= subroutine pmatrix_normalize (pmatrix, flv, degree, tolerance) class(pmatrix_t), intent(inout) :: pmatrix type(flavor_t), intent(in) :: flv real(default), intent(in), optional :: degree real(default), intent(in), optional :: tolerance integer :: i, hmax logical :: fermion, ok real(default) :: trace, trace_sq real(default) :: tol tol = 0; if (present (tolerance)) tol = tolerance pmatrix%spin_type = flv%get_spin_type () pmatrix%massive = flv%get_mass () /= 0 if (.not. pmatrix%massive) then if (flv%is_left_handed ()) then pmatrix%chirality = -1 else if (flv%is_right_handed ()) then pmatrix%chirality = +1 end if end if if (pmatrix%spin_type == SCALAR) then pmatrix%multiplicity = 1 else if (pmatrix%massive) then pmatrix%multiplicity = pmatrix%spin_type else if (pmatrix%chirality == 0) then pmatrix%multiplicity = 2 else pmatrix%multiplicity = 1 end if if (present (degree)) then if (degree < 0 .or. degree > 1) & call msg_error ("polarization degree must be between 0 and 1") pmatrix%degree = degree end if if (size (pmatrix%index, 1) /= 2) call error ("wrong array rank") fermion = mod (pmatrix%spin_type, 2) == 0 hmax = pmatrix%spin_type / 2 if (pmatrix%n_entry > 0) then if (fermion) then if (pmatrix%massive) then ok = all (pmatrix%index /= 0) & .and. all (abs (pmatrix%index) <= hmax) else if (pmatrix%chirality == -1) then ok = all (pmatrix%index == -hmax) else if (pmatrix%chirality == +1) then ok = all (pmatrix%index == +hmax) else ok = all (abs (pmatrix%index) == hmax) end if else if (pmatrix%massive) then ok = all (abs (pmatrix%index) <= hmax) else ok = all (abs (pmatrix%index) == hmax) end if end if if (.not. ok) call error ("illegal index value") else pmatrix%degree = 0 pmatrix%pure = pmatrix%multiplicity == 1 return end if trace = 0 do i = 1, pmatrix%n_entry associate (index => pmatrix%index(:,i), value => pmatrix%value(i)) if (index(1) == index(2)) then if (abs (aimag (value)) > tol) call error ("diagonal must be real") value = real (value, kind=default) trace = trace + value else if (any (pmatrix%index(1,:) == index(2) & .and. pmatrix%index(2,:) == index(1))) then call error ("redundant off-diagonal entry") else if (index(2) < index (1)) then index = index([2,1]) value = conjg (value) end if end associate end do if (abs (trace) <= tol) call error ("trace must not vanish") trace = real (trace, kind=default) pmatrix%value = pmatrix%value / trace * pmatrix%degree trace_sq = (1 - pmatrix%degree ** 2) / pmatrix%multiplicity do i = 1, pmatrix%n_entry associate (index => pmatrix%index(:,i), value => pmatrix%value(i)) if (index(1) == index(2)) then trace_sq = trace_sq + abs (value) ** 2 else trace_sq = trace_sq + 2 * abs (value) ** 2 end if end associate end do if (pmatrix%multiplicity == 1) then pmatrix%pure = .true. else if (abs (trace_sq - 1) <= tol) then pmatrix%pure = .true. else if (trace_sq - 1 > tol .or. trace_sq < -tol) then print *, "Trace of matrix square = ", trace_sq call error ("not permissible as density matrix") end if contains subroutine error (msg) character(*), intent(in) :: msg call pmatrix%write () call msg_fatal ("Spin density matrix: " // msg) end subroutine error end subroutine pmatrix_normalize @ %def pmatrix_normalize @ A polarized matrix is defined as one with a positive polarization degree, even if the actual matrix is trivial. <>= procedure :: is_polarized => pmatrix_is_polarized <>= elemental function pmatrix_is_polarized (pmatrix) result (flag) class(pmatrix_t), intent(in) :: pmatrix logical :: flag flag = pmatrix%degree > 0 end function pmatrix_is_polarized @ %def pmatrix_is_polarized @ Check if there are only diagonal entries. <>= procedure :: is_diagonal => pmatrix_is_diagonal <>= elemental function pmatrix_is_diagonal (pmatrix) result (flag) class(pmatrix_t), intent(in) :: pmatrix logical :: flag flag = all (pmatrix%index(1,:) == pmatrix%index(2,:)) end function pmatrix_is_diagonal @ %def pmatrix_is_diagonal @ Check if there are only diagonal entries. <>= procedure :: get_simple_pol => pmatrix_get_simple_pol <>= elemental function pmatrix_get_simple_pol (pmatrix) result (pol) class(pmatrix_t), intent(in) :: pmatrix real(default) :: pol if (pmatrix%is_polarized ()) then select case (size (pmatrix%value)) case (0) pol = 0 case (1) pol = pmatrix%index (1,1) * pmatrix%degree case (2) pol = 42 end select else pol = 0 end if end function pmatrix_get_simple_pol @ %def pmatrix_get_simple_pol @ \subsection{Data Transformation} Create a [[polarization_t]] object from the contents of a normalized [[pmatrix_t]] object. We scan the entries as present in [[pmatrix]] and transform them into a density matrix, if necessary. The density matrix then initializes the Bloch vector. This is analogous to [[polarization_init_state_matrix]]. There is a subtlety associated with massless particles. Since the [[pmatrix]] doesn't contain the full density matrix but just the nontrivial part, we have to initialize the polarization object with the massless equipartion, which contains nonzero entries for the Cartan generators. The [[set]] method therefore should not erase those initial contents. This is a constraint for the implementation of [[set]], as applied to the Bloch vector. As mentioned above, [[pmatrix_t]] does not support an antiparticle flag. <>= procedure :: init_pmatrix => polarization_init_pmatrix <>= subroutine polarization_init_pmatrix (pol, pmatrix) class(polarization_t), intent(out) :: pol type(pmatrix_t), intent(in) :: pmatrix integer :: d, i, j, k, h1, h2 complex(default), dimension(:,:), allocatable :: r call pol%init_generic ( & spin_type = pmatrix%spin_type, & multiplicity = pmatrix%multiplicity, & anti = .false., & !!! SUFFICIENT? left_handed = pmatrix%chirality < 0, & right_handed = pmatrix%chirality > 0) if (pol%bv%is_polarized ()) then d = pol%bv%get_n_states () allocate (r (d, d), source = (0._default, 0._default)) if (d == pmatrix%multiplicity) then do i = 1, d r(i,i) = (1 - pmatrix%degree) / d end do else if (d > pmatrix%multiplicity) then r(1,1) = (1 - pmatrix%degree) / 2 r(d,d) = r(1,1) end if do k = 1, size (pmatrix%value) h1 = pmatrix%index(1,k) h2 = pmatrix%index(2,k) i = pol%bv%hel_index (h1) j = pol%bv%hel_index (h2) r(i,j) = r(i,j) + pmatrix%value(k) r(j,i) = conjg (r(i,j)) end do call pol%bv%set (r) end if end subroutine polarization_init_pmatrix @ %def polarization_init_pmatrix @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[polarizations_ut.f90]]>>= <> module polarizations_ut use unit_tests use polarizations_uti <> <> contains <> end module polarizations_ut @ %def polarizations_ut @ <<[[polarizations_uti.f90]]>>= <> module polarizations_uti <> use flavors use model_data use polarizations <> <> contains <> end module polarizations_uti @ %def polarizations_ut @ API: driver for the unit tests below. <>= public :: polarizations_test <>= subroutine polarizations_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine polarizations_test @ %def polarizations_test @ \subsubsection{Polarization type} Checking the setup for polarization. <>= call test (polarization_1, "polarization_1", & "check polarization setup", & u, results) <>= public :: polarization_1 <>= subroutine polarization_1 (u) use os_interface integer, intent(in) :: u type(model_data_t), target :: model type(polarization_t) :: pol type(flavor_t) :: flv real(default), dimension(3) :: alpha real(default) :: r, theta, phi real(default), parameter :: tolerance = 1.E-14_default write (u, "(A)") "* Test output: polarization_1" write (u, "(A)") "* Purpose: test polarization setup" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call model%init_sm_test () write (u, "(A)") "* Unpolarized fermion" write (u, "(A)") call flv%init (1, model) call pol%init_unpolarized (flv) call pol%write (u, state_matrix = .true.) write (u, "(A,L1)") " diagonal =", pol%is_diagonal () write (u, "(A)") write (u, "(A)") "* Unpolarized fermion" write (u, "(A)") call pol%init_circular (flv, 0._default) call pol%write (u, state_matrix = .true., all_states = .false.) write (u, "(A)") write (u, "(A)") "* Transversally polarized fermion, phi=0" write (u, "(A)") call pol%init_transversal (flv, 0._default, 1._default) call pol%write (u, state_matrix = .true.) write (u, "(A,L1)") " diagonal =", pol%is_diagonal () write (u, "(A)") write (u, "(A)") "* Transversally polarized fermion, phi=0.9, frac=0.8" write (u, "(A)") call pol%init_transversal (flv, 0.9_default, 0.8_default) call pol%write (u, state_matrix = .true.) write (u, "(A,L1)") " diagonal =", pol%is_diagonal () write (u, "(A)") write (u, "(A)") "* All polarization directions of a fermion" write (u, "(A)") call pol%init_generic (flv) call pol%write (u, state_matrix = .true.) call flv%init (21, model) write (u, "(A)") write (u, "(A)") "* Circularly polarized gluon, frac=0.3" write (u, "(A)") call pol%init_circular (flv, 0.3_default) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) call flv%init (23, model) write (u, "(A)") write (u, "(A)") "* Circularly polarized massive vector, frac=-0.7" write (u, "(A)") call pol%init_circular (flv, -0.7_default) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) write (u, "(A)") write (u, "(A)") "* Circularly polarized massive vector" write (u, "(A)") call pol%init_circular (flv, 1._default) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) write (u, "(A)") write (u, "(A)") "* Longitudinally polarized massive vector, frac=0.4" write (u, "(A)") call pol%init_longitudinal (flv, 0.4_default) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) write (u, "(A)") write (u, "(A)") "* Longitudinally polarized massive vector" write (u, "(A)") call pol%init_longitudinal (flv, 1._default) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) write (u, "(A)") write (u, "(A)") "* Diagonally polarized massive vector" write (u, "(A)") call pol%init_diagonal & (flv, [2._default, 1._default, 0._default]) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) write (u, "(A)") write (u, "(A)") "* All polarization directions of a massive vector" write (u, "(A)") call pol%init_generic (flv) call pol%write (u, state_matrix = .true.) call flv%init (21, model) write (u, "(A)") write (u, "(A)") "* Axis polarization (0.2, 0.4, 0.6)" write (u, "(A)") alpha = [0.2_default, 0.4_default, 0.6_default] call pol%init_axis (flv, alpha) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) write (u, "(A)") write (u, "(1X,A)") "Recovered axis:" alpha = pol%get_axis () write (u, "(3(1X,F10.7))") alpha write (u, "(A)") write (u, "(A)") "* Angle polarization (0.5, 0.6, -1)" r = 0.5_default theta = 0.6_default phi = -1._default call pol%init_angles (flv, r, theta, phi) write (u, "(A)") call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) write (u, "(A)") write (u, "(1X,A)") "Recovered parameters (r, theta, phi):" call pol%to_angles (r, theta, phi) write (u, "(3(1x,F10.7))") r, theta, phi call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: polarization_1" end subroutine polarization_1 @ %def polarization_1 @ \subsubsection{Sparse-Matrix type} Use a sparse density matrix universally as the input for setting up polarization. <>= call test (polarization_2, "polarization_2", & "matrix polarization setup", & u, results) <>= public :: polarization_2 <>= subroutine polarization_2 (u) use os_interface integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(polarization_t) :: pol real(default), dimension(3) :: alpha type(pmatrix_t) :: pmatrix real(default), parameter :: tolerance = 1e-8_default write (u, "(A)") "* Test output: polarization_2" write (u, "(A)") "* Purpose: matrix polarization setup" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call model%init_sm_test () write (u, "(A)") "* Unpolarized fermion" write (u, "(A)") call flv%init (1, model) call pmatrix%init (2, 0) call pmatrix%normalize (flv, 0._default, tolerance) call pmatrix%write (u) write (u, *) write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized () write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal () write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Transversally polarized fermion, phi=0" write (u, "(A)") call pmatrix%init (2, 3) call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default)) call pmatrix%set_entry (2, [+1,+1], (1._default, 0._default)) call pmatrix%set_entry (3, [-1,+1], (1._default, 0._default)) call pmatrix%normalize (flv, 1._default, tolerance) call pmatrix%write (u) write (u, *) write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized () write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal () write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Transversally polarized fermion, phi=0.9, frac=0.8" write (u, "(A)") call pmatrix%init (2, 3) call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default)) call pmatrix%set_entry (2, [+1,+1], (1._default, 0._default)) call pmatrix%set_entry (3, [-1,+1], exp ((0._default, -0.9_default))) call pmatrix%normalize (flv, 0.8_default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true.) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Left-handed massive fermion, frac=1" write (u, "(A)") call flv%init (11, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default)) call pmatrix%normalize (flv, 1._default, tolerance) call pmatrix%write (u) write (u, *) write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized () write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal () write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Left-handed massive fermion, frac=0.8" write (u, "(A)") call flv%init (11, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default)) call pmatrix%normalize (flv, 0.8_default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Left-handed massless fermion" write (u, "(A)") call flv%init (12, model) call pmatrix%init (2, 0) call pmatrix%normalize (flv, 1._default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true.) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Right-handed massless fermion, frac=0.5" write (u, "(A)") call flv%init (-12, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [1,1], (1._default, 0._default)) call pmatrix%normalize (flv, 0.5_default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true.) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Circularly polarized gluon, frac=0.3" write (u, "(A)") call flv%init (21, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [1,1], (1._default, 0._default)) call pmatrix%normalize (flv, 0.3_default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Circularly polarized massive vector, frac=0.7" write (u, "(A)") call flv%init (23, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [1,1], (1._default, 0._default)) call pmatrix%normalize (flv, 0.7_default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Circularly polarized massive vector" write (u, "(A)") call flv%init (23, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [1,1], (1._default, 0._default)) call pmatrix%normalize (flv, 1._default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Longitudinally polarized massive vector, frac=0.4" write (u, "(A)") call flv%init (23, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [0,0], (1._default, 0._default)) call pmatrix%normalize (flv, 0.4_default, tolerance) call pmatrix%write (u) write (u, *) write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized () write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal () write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Longitudinally polarized massive vector" write (u, "(A)") call flv%init (23, model) call pmatrix%init (2, 1) call pmatrix%set_entry (1, [0,0], (1._default, 0._default)) call pmatrix%normalize (flv, 1._default, tolerance) call pmatrix%write (u) write (u, *) write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized () write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal () write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true., & all_states = .false., tolerance = tolerance) ! call pol%final () write (u, "(A)") write (u, "(A)") "* Axis polarization (0.2, 0.4, 0.6)" write (u, "(A)") call flv%init (11, model) alpha = [0.2_default, 0.4_default, 0.6_default] alpha = alpha / sqrt (sum (alpha**2)) call pmatrix%init (2, 3) call pmatrix%set_entry (1, [-1,-1], cmplx (1 - alpha(3), kind=default)) call pmatrix%set_entry (2, [1,-1], & cmplx (alpha(1),-alpha(2), kind=default)) call pmatrix%set_entry (3, [1,1], cmplx (1 + alpha(3), kind=default)) call pmatrix%normalize (flv, 1._default, tolerance) call pmatrix%write (u) write (u, *) call pol%init_pmatrix (pmatrix) call pol%write (u, state_matrix = .true.) ! call pol%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: polarization_2" end subroutine polarization_2 @ %def polarization_2 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Particles} This module defines the [[particle_t]] object type, and the methods and operations that deal with it. <<[[particles.f90]]>>= <> module particles <> <> <> use io_units use format_utils, only: write_compressed_integer_array, write_separator use format_utils, only: pac_fmt use format_defs, only: FMT_16, FMT_19 use numeric_utils use diagnostics use lorentz use phs_points, only: phs_point_t, assignment(=) use model_data use flavors use colors use helicities use quantum_numbers use state_matrices use interactions use subevents use polarizations use pdg_arrays, only: is_quark, is_gluon <> <> <> <> <> contains <> end module particles @ %def particles @ \subsection{The particle type} \subsubsection{Particle status codes} The overall status codes (incoming/outgoing etc.) are inherited from the module [[subevents]]. Polarization status: <>= integer, parameter, public :: PRT_UNPOLARIZED = 0 integer, parameter, public :: PRT_DEFINITE_HELICITY = 1 integer, parameter, public :: PRT_GENERIC_POLARIZATION = 2 @ %def PRT_UNPOLARIZED PRT_DEFINITE_HELICITY PRT_GENERIC_POLARIZATION @ \subsubsection{Definition} The quantum numbers are flavor (from which invariant particle properties can be derived), color, and polarization. The particle may be unpolarized. In this case, [[hel]] and [[pol]] are unspecified. If it has a definite helicity, the [[hel]] component is defined. If it has a generic polarization, the [[pol]] component is defined. For each particle we store the four-momentum and the invariant mass squared, i.e., the squared norm of the four-momentum. There is also an optional list of parent and child particles, for bookkeeping in physical events. The [[vertex]] is an optional component that consists of a Lorentz 4-vector, denoting the position and time of the vertex (displaced vertex/time). [[lifetime]] is an optional component that accounts for the finite lifetime $\tau$ of a decaying particle. In case there is no magnetic field etc., the true decay vertex of a particle in the detector would be $\vec{v}^\prime = \vec{v} + \tau \times \vec{p}/p^0$, where $p^0$ and $\vec{p}$ are the energy and 3-momentum of the particle. <>= public :: particle_t <>= type :: particle_t !private integer :: status = PRT_UNDEFINED integer :: polarization = PRT_UNPOLARIZED type(flavor_t) :: flv type(color_t) :: col type(helicity_t) :: hel type(polarization_t) :: pol type(vector4_t) :: p = vector4_null real(default) :: p2 = 0 type(vector4_t), allocatable :: vertex real(default), allocatable :: lifetime integer, dimension(:), allocatable :: parent integer, dimension(:), allocatable :: child contains <> end type particle_t @ %def particle_t @ Copy a particle. (Deep copy) This excludes the parent-child relations. <>= generic :: init => init_particle procedure :: init_particle => particle_init_particle <>= subroutine particle_init_particle (prt_out, prt_in) class(particle_t), intent(out) :: prt_out type(particle_t), intent(in) :: prt_in prt_out%status = prt_in%status prt_out%polarization = prt_in%polarization prt_out%flv = prt_in%flv prt_out%col = prt_in%col prt_out%hel = prt_in%hel prt_out%pol = prt_in%pol prt_out%p = prt_in%p prt_out%p2 = prt_in%p2 if (allocated (prt_in%vertex)) & allocate (prt_out%vertex, source=prt_in%vertex) if (allocated (prt_in%lifetime)) & allocate (prt_out%lifetime, source=prt_in%lifetime) end subroutine particle_init_particle @ %def particle_init_particle @ Initialize a particle using external information. <>= generic :: init => init_external procedure :: init_external => particle_init_external <>= subroutine particle_init_external & (particle, status, pdg, model, col, anti_col, mom) class(particle_t), intent(out) :: particle integer, intent(in) :: status, pdg, col, anti_col class(model_data_t), pointer, intent(in) :: model type(vector4_t), intent(in) :: mom type(flavor_t) :: flavor type(color_t) :: color call flavor%init (pdg, model) call particle%set_flavor (flavor) call color%init_col_acl (col, anti_col) call particle%set_color (color) call particle%set_status (status) call particle%set_momentum (mom) end subroutine particle_init_external @ %def particle_init_external @ Initialize a particle using a single-particle state matrix which determines flavor, color, and polarization. The state matrix must have unique flavor and color. The factorization mode determines whether the particle is unpolarized, has definite helicity, or generic polarization. This mode is translated into the polarization status. <>= generic :: init => init_state procedure :: init_state => particle_init_state <>= subroutine particle_init_state (prt, state, status, mode) class(particle_t), intent(out) :: prt type(state_matrix_t), intent(in), target :: state integer, intent(in) :: status, mode type(state_iterator_t) :: it prt%status = status call it%init (state) prt%flv = it%get_flavor (1) if (prt%flv%is_radiated ()) prt%status = PRT_BEAM_REMNANT prt%col = it%get_color (1) select case (mode) case (FM_SELECT_HELICITY) prt%hel = it%get_helicity (1) if (prt%hel%is_defined ()) then prt%polarization = PRT_DEFINITE_HELICITY end if case (FM_FACTOR_HELICITY) call prt%pol%init_state_matrix (state) prt%polarization = PRT_GENERIC_POLARIZATION end select end subroutine particle_init_state @ %def particle_init_state @ Finalizer. <>= procedure :: final => particle_final <>= subroutine particle_final (prt) class(particle_t), intent(inout) :: prt if (allocated (prt%vertex)) deallocate (prt%vertex) if (allocated (prt%lifetime)) deallocate (prt%lifetime) end subroutine particle_final @ %def particle_final @ \subsubsection{I/O} <>= procedure :: write => particle_write <>= subroutine particle_write (prt, unit, testflag, compressed, polarization) class(particle_t), intent(in) :: prt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag, compressed, polarization logical :: comp, pacified, pol integer :: u, h1, h2 real(default) :: pp2 character(len=7) :: fmt character(len=20) :: buffer comp = .false.; if (present (compressed)) comp = compressed pacified = .false.; if (present (testflag)) pacified = testflag pol = .true.; if (present (polarization)) pol = polarization call pac_fmt (fmt, FMT_19, FMT_16, testflag) u = given_output_unit (unit); if (u < 0) return pp2 = prt%p2 if (pacified) call pacify (pp2, tolerance = 1E-10_default) select case (prt%status) case (PRT_UNDEFINED); write (u, "(1x, A)", advance="no") "[-]" case (PRT_BEAM); write (u, "(1x, A)", advance="no") "[b]" case (PRT_INCOMING); write (u, "(1x, A)", advance="no") "[i]" case (PRT_OUTGOING); write (u, "(1x, A)", advance="no") "[o]" case (PRT_VIRTUAL); write (u, "(1x, A)", advance="no") "[v]" case (PRT_RESONANT); write (u, "(1x, A)", advance="no") "[r]" case (PRT_BEAM_REMNANT); write (u, "(1x, A)", advance="no") "[x]" end select write (u, "(1x)", advance="no") if (comp) then write (u, "(A7,1X)", advance="no") char (prt%flv%get_name ()) if (pol) then select case (prt%polarization) case (PRT_DEFINITE_HELICITY) ! Integer helicity, assumed diagonal call prt%hel%get_indices (h1, h2) write (u, "(I2,1X)", advance="no") h1 case (PRT_GENERIC_POLARIZATION) ! No space for full density matrix here write (u, "(A2,1X)", advance="no") "*" case default ! Blank entry if helicity is undefined write (u, "(A2,1X)", advance="no") " " end select end if write (u, "(2(I4,1X))", advance="no") & prt%col%get_col (), prt%col%get_acl () call write_compressed_integer_array (buffer, prt%parent) write (u, "(A,1X)", advance="no") buffer call write_compressed_integer_array (buffer, prt%child) write (u, "(A,1X)", advance="no") buffer call prt%p%write(u, testflag = testflag, compressed = comp) write (u, "(F12.3)") pp2 else call prt%flv%write (unit) if (prt%col%is_nonzero ()) then call color_write (prt%col, unit) end if if (pol) then select case (prt%polarization) case (PRT_DEFINITE_HELICITY) call prt%hel%write (unit) write (u, *) case (PRT_GENERIC_POLARIZATION) write (u, *) call prt%pol%write (unit, state_matrix = .true.) case default write (u, *) end select else write (u, *) end if call prt%p%write (unit, testflag = testflag) write (u, "(1x,A,1x," // fmt // ")") "T = ", pp2 if (allocated (prt%parent)) then if (size (prt%parent) /= 0) then write (u, "(1x,A,40(1x,I0))") "Parents: ", prt%parent end if end if if (allocated (prt%child)) then if (size (prt%child) /= 0) then write (u, "(1x,A,40(1x,I0))") "Children:", prt%child end if end if if (allocated (prt%vertex)) then write (u, "(1x,A,1x," // fmt // ")") "Vtx t = ", prt%vertex%p(0) write (u, "(1x,A,1x," // fmt // ")") "Vtx x = ", prt%vertex%p(1) write (u, "(1x,A,1x," // fmt // ")") "Vtx y = ", prt%vertex%p(2) write (u, "(1x,A,1x," // fmt // ")") "Vtx z = ", prt%vertex%p(3) end if if (allocated (prt%lifetime)) then write (u, "(1x,A,1x," // fmt // ")") "Lifetime = ", & prt%lifetime end if end if end subroutine particle_write @ %def particle_write @ Binary I/O: <>= procedure :: write_raw => particle_write_raw procedure :: read_raw => particle_read_raw <>= subroutine particle_write_raw (prt, u) class(particle_t), intent(in) :: prt integer, intent(in) :: u write (u) prt%status, prt%polarization call prt%flv%write_raw (u) call prt%col%write_raw (u) select case (prt%polarization) case (PRT_DEFINITE_HELICITY) call prt%hel%write_raw (u) case (PRT_GENERIC_POLARIZATION) call prt%pol%write_raw (u) end select call vector4_write_raw (prt%p, u) write (u) prt%p2 write (u) allocated (prt%parent) if (allocated (prt%parent)) then write (u) size (prt%parent) write (u) prt%parent end if write (u) allocated (prt%child) if (allocated (prt%child)) then write (u) size (prt%child) write (u) prt%child end if write (u) allocated (prt%vertex) if (allocated (prt%vertex)) then call vector4_write_raw (prt%vertex, u) end if write (u) allocated (prt%lifetime) if (allocated (prt%lifetime)) then write (u) prt%lifetime end if end subroutine particle_write_raw subroutine particle_read_raw (prt, u, iostat) class(particle_t), intent(out) :: prt integer, intent(in) :: u integer, intent(out) :: iostat logical :: allocated_parent, allocated_child logical :: allocated_vertex, allocated_lifetime integer :: size_parent, size_child read (u, iostat=iostat) prt%status, prt%polarization call prt%flv%read_raw (u, iostat=iostat) call prt%col%read_raw (u, iostat=iostat) select case (prt%polarization) case (PRT_DEFINITE_HELICITY) call prt%hel%read_raw (u, iostat=iostat) case (PRT_GENERIC_POLARIZATION) call prt%pol%read_raw (u, iostat=iostat) end select call vector4_read_raw (prt%p, u, iostat=iostat) read (u, iostat=iostat) prt%p2 read (u, iostat=iostat) allocated_parent if (allocated_parent) then read (u, iostat=iostat) size_parent allocate (prt%parent (size_parent)) read (u, iostat=iostat) prt%parent end if read (u, iostat=iostat) allocated_child if (allocated_child) then read (u, iostat=iostat) size_child allocate (prt%child (size_child)) read (u, iostat=iostat) prt%child end if read (u, iostat=iostat) allocated_vertex if (allocated_vertex) then allocate (prt%vertex) read (u, iostat=iostat) prt%vertex%p end if read (u, iostat=iostat) allocated_lifetime if (allocated_lifetime) then allocate (prt%lifetime) read (u, iostat=iostat) prt%lifetime end if end subroutine particle_read_raw @ %def particle_write_raw particle_read_raw @ \subsubsection{Setting contents} Reset the status code. Where applicable, set $p^2$ assuming that the particle is on-shell. <>= procedure :: reset_status => particle_reset_status <>= elemental subroutine particle_reset_status (prt, status) class(particle_t), intent(inout) :: prt integer, intent(in) :: status prt%status = status select case (status) case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING) prt%p2 = prt%flv%get_mass () ** 2 end select end subroutine particle_reset_status @ %def particle_reset_status @ The color can be given explicitly. <>= procedure :: set_color => particle_set_color <>= elemental subroutine particle_set_color (prt, col) class(particle_t), intent(inout) :: prt type(color_t), intent(in) :: col prt%col = col end subroutine particle_set_color @ %def particle_set_color @ The flavor can be given explicitly. <>= procedure :: set_flavor => particle_set_flavor <>= subroutine particle_set_flavor (prt, flv) class(particle_t), intent(inout) :: prt type(flavor_t), intent(in) :: flv prt%flv = flv end subroutine particle_set_flavor @ %def particle_set_flavor @ As can the helicity. <>= procedure :: set_helicity => particle_set_helicity <>= subroutine particle_set_helicity (prt, hel) class(particle_t), intent(inout) :: prt type(helicity_t), intent(in) :: hel prt%hel = hel end subroutine particle_set_helicity @ %def particle_set_helicity @ And the polarization. <>= procedure :: set_pol => particle_set_pol <>= subroutine particle_set_pol (prt, pol) class(particle_t), intent(inout) :: prt type(polarization_t), intent(in) :: pol prt%pol = pol end subroutine particle_set_pol @ %def particle_set_pol @ Manually set the model for the particle flavor. This is required, e.g., if the particle has been read from file. <>= procedure :: set_model => particle_set_model <>= subroutine particle_set_model (prt, model) class(particle_t), intent(inout) :: prt class(model_data_t), intent(in), target :: model call prt%flv%set_model (model) end subroutine particle_set_model @ %def particle_set_model @ The momentum is set independent of the quantum numbers. <>= procedure :: set_momentum => particle_set_momentum <>= elemental subroutine particle_set_momentum (prt, p, p2, on_shell) class(particle_t), intent(inout) :: prt type(vector4_t), intent(in) :: p real(default), intent(in), optional :: p2 logical, intent(in), optional :: on_shell prt%p = p if (present (on_shell)) then if (on_shell) then if (prt%flv%is_associated ()) then prt%p2 = prt%flv%get_mass () ** 2 return end if end if end if if (present (p2)) then prt%p2 = p2 else prt%p2 = p ** 2 end if end subroutine particle_set_momentum @ %def particle_set_momentum @ Set resonance information. This should be done after momentum assignment, because we need to know wheter the particle is spacelike or timelike. The resonance flag is defined only for virtual particles. <>= procedure :: set_resonance_flag => particle_set_resonance_flag <>= elemental subroutine particle_set_resonance_flag (prt, resonant) class(particle_t), intent(inout) :: prt logical, intent(in) :: resonant select case (prt%status) case (PRT_VIRTUAL) if (resonant) prt%status = PRT_RESONANT end select end subroutine particle_set_resonance_flag @ %def particle_set_resonance_flag @ Set children and parents information. <>= procedure :: set_children => particle_set_children procedure :: set_parents => particle_set_parents <>= subroutine particle_set_children (prt, idx) class(particle_t), intent(inout) :: prt integer, dimension(:), intent(in) :: idx if (allocated (prt%child)) deallocate (prt%child) allocate (prt%child (count (idx /= 0))) prt%child = pack (idx, idx /= 0) end subroutine particle_set_children subroutine particle_set_parents (prt, idx) class(particle_t), intent(inout) :: prt integer, dimension(:), intent(in) :: idx if (allocated (prt%parent)) deallocate (prt%parent) allocate (prt%parent (count (idx /= 0))) prt%parent = pack (idx, idx /= 0) end subroutine particle_set_parents @ %def particle_set_children particle_set_parents @ <>= procedure :: add_child => particle_add_child <>= subroutine particle_add_child (prt, new_child) class(particle_t), intent(inout) :: prt integer, intent(in) :: new_child integer, dimension(:), allocatable :: idx integer :: n, i n = prt%get_n_children() if (n == 0) then call prt%set_children ([new_child]) else do i = 1, n if (prt%child(i) == new_child) then return end if end do allocate (idx (1:n+1)) idx(1:n) = prt%get_children () idx(n+1) = new_child call prt%set_children (idx) end if end subroutine particle_add_child @ %def particle_add_child @ <>= procedure :: add_children => particle_add_children <>= subroutine particle_add_children (prt, new_child) class(particle_t), intent(inout) :: prt integer, dimension(:), intent(in) :: new_child integer, dimension(:), allocatable :: idx integer :: n n = prt%get_n_children() if (n == 0) then call prt%set_children (new_child) else allocate (idx (1:n+size(new_child))) idx(1:n) = prt%get_children () idx(n+1:n+size(new_child)) = new_child call prt%set_children (idx) end if end subroutine particle_add_children @ %def particle_add_children @ <>= procedure :: set_status => particle_set_status <>= elemental subroutine particle_set_status (prt, status) class(particle_t), intent(inout) :: prt integer, intent(in) :: status prt%status = status end subroutine particle_set_status @ %def particle_set_status @ <>= procedure :: set_polarization => particle_set_polarization <>= subroutine particle_set_polarization (prt, polarization) class(particle_t), intent(inout) :: prt integer, intent(in) :: polarization prt%polarization = polarization end subroutine particle_set_polarization @ %def particle_set_polarization @ <>= generic :: set_vertex => set_vertex_from_vector3, set_vertex_from_xyz, & set_vertex_from_vector4, set_vertex_from_xyzt procedure :: set_vertex_from_vector4 => particle_set_vertex_from_vector4 procedure :: set_vertex_from_vector3 => particle_set_vertex_from_vector3 procedure :: set_vertex_from_xyzt => particle_set_vertex_from_xyzt procedure :: set_vertex_from_xyz => particle_set_vertex_from_xyz <>= subroutine particle_set_vertex_from_vector4 (prt, vertex) class(particle_t), intent(inout) :: prt type(vector4_t), intent(in) :: vertex if (allocated (prt%vertex)) deallocate (prt%vertex) allocate (prt%vertex, source=vertex) end subroutine particle_set_vertex_from_vector4 subroutine particle_set_vertex_from_vector3 (prt, vertex) class(particle_t), intent(inout) :: prt type(vector3_t), intent(in) :: vertex type(vector4_t) :: vtx vtx = vector4_moving (0._default, vertex) if (allocated (prt%vertex)) deallocate (prt%vertex) allocate (prt%vertex, source=vtx) end subroutine particle_set_vertex_from_vector3 subroutine particle_set_vertex_from_xyzt (prt, vx, vy, vz, t) class(particle_t), intent(inout) :: prt real(default), intent(in) :: vx, vy, vz, t type(vector4_t) :: vertex if (allocated (prt%vertex)) deallocate (prt%vertex) vertex = vector4_moving (t, vector3_moving ([vx, vy, vz])) allocate (prt%vertex, source=vertex) end subroutine particle_set_vertex_from_xyzt subroutine particle_set_vertex_from_xyz (prt, vx, vy, vz) class(particle_t), intent(inout) :: prt real(default), intent(in) :: vx, vy, vz type(vector4_t) :: vertex if (allocated (prt%vertex)) deallocate (prt%vertex) vertex = vector4_moving (0._default, vector3_moving ([vx, vy, vz])) allocate (prt%vertex, source=vertex) end subroutine particle_set_vertex_from_xyz @ %def particle_set_vertex_from_vector3 @ %def particle_set_vertex_from_vector4 @ %def particle_set_vertex_from_xyz @ %def particle_set_vertex_from_xyzt @ Set the lifetime of a particle. <>= procedure :: set_lifetime => particle_set_lifetime <>= elemental subroutine particle_set_lifetime (prt, lifetime) class(particle_t), intent(inout) :: prt real(default), intent(in) :: lifetime if (allocated (prt%lifetime)) deallocate (prt%lifetime) allocate (prt%lifetime, source=lifetime) end subroutine particle_set_lifetime @ %def particle_set_lifetime @ \subsubsection{Accessing contents} The status code. <>= procedure :: get_status => particle_get_status <>= elemental function particle_get_status (prt) result (status) integer :: status class(particle_t), intent(in) :: prt status = prt%status end function particle_get_status @ %def particle_get_status @ Return true if the status is either [[INCOMING]], [[OUTGOING]] or [[RESONANT]]. [[BEAM]] is kept, if [[keep_beams]] is set true. <>= procedure :: is_real => particle_is_real <>= elemental function particle_is_real (prt, keep_beams) result (flag) logical :: flag, kb class(particle_t), intent(in) :: prt logical, intent(in), optional :: keep_beams kb = .false. if (present (keep_beams)) kb = keep_beams select case (prt%status) case (PRT_INCOMING, PRT_OUTGOING, PRT_RESONANT) flag = .true. case (PRT_BEAM) flag = kb case default flag = .false. end select end function particle_is_real @ %def particle_is_real @ <>= procedure :: is_colored => particle_is_colored <>= elemental function particle_is_colored (particle) result (flag) logical :: flag class(particle_t), intent(in) :: particle flag = particle%col%is_nonzero () end function particle_is_colored @ %def particle_is_colored @ $[90,100]$ hopefully catches all of them and not too many. <>= procedure :: is_hadronic_beam_remnant => particle_is_hadronic_beam_remnant <>= elemental function particle_is_hadronic_beam_remnant (particle) result (flag) class(particle_t), intent(in) :: particle logical :: flag integer :: pdg pdg = particle%flv%get_pdg () flag = particle%status == PRT_BEAM_REMNANT .and. & abs(pdg) >= 90 .and. abs(pdg) <= 100 end function particle_is_hadronic_beam_remnant @ %def particle_is_hadronic_beam_remnant @ <>= procedure :: is_beam_remnant => particle_is_beam_remnant <>= elemental function particle_is_beam_remnant (particle) result (flag) class(particle_t), intent(in) :: particle logical :: flag flag = particle%status == PRT_BEAM_REMNANT end function particle_is_beam_remnant @ %def particle_is_beam_remnant @ Polarization status. <>= procedure :: get_polarization_status => particle_get_polarization_status <>= elemental function particle_get_polarization_status (prt) result (status) integer :: status class(particle_t), intent(in) :: prt status = prt%polarization end function particle_get_polarization_status @ %def particle_get_polarization_status @ Return the PDG code from the flavor component directly. <>= procedure :: get_pdg => particle_get_pdg <>= elemental function particle_get_pdg (prt) result (pdg) integer :: pdg class(particle_t), intent(in) :: prt pdg = prt%flv%get_pdg () end function particle_get_pdg @ %def particle_get_pdg @ Return the color and anticolor quantum numbers. <>= procedure :: get_color => particle_get_color <>= pure function particle_get_color (prt) result (col) integer, dimension(2) :: col class(particle_t), intent(in) :: prt col(1) = prt%col%get_col () col(2) = prt%col%get_acl () end function particle_get_color @ %def particle_get_color @ Return a copy of the polarization density matrix. <>= procedure :: get_polarization => particle_get_polarization <>= function particle_get_polarization (prt) result (pol) class(particle_t), intent(in) :: prt type(polarization_t) :: pol pol = prt%pol end function particle_get_polarization @ %def particle_get_polarization @ Return the flavor, color and helicity. <>= procedure :: get_flv => particle_get_flv procedure :: get_col => particle_get_col procedure :: get_hel => particle_get_hel <>= function particle_get_flv (prt) result (flv) class(particle_t), intent(in) :: prt type(flavor_t) :: flv flv = prt%flv end function particle_get_flv function particle_get_col (prt) result (col) class(particle_t), intent(in) :: prt type(color_t) :: col col = prt%col end function particle_get_col function particle_get_hel (prt) result (hel) class(particle_t), intent(in) :: prt type(helicity_t) :: hel hel = prt%hel end function particle_get_hel @ %def particle_get_flv particle_get_col particle_get_hel @ Return the helicity (if defined and diagonal). <>= procedure :: get_helicity => particle_get_helicity <>= elemental function particle_get_helicity (prt) result (hel) integer :: hel integer, dimension(2) :: hel_arr class(particle_t), intent(in) :: prt hel = 0 if (prt%hel%is_defined () .and. prt%hel%is_diagonal ()) then hel_arr = prt%hel%to_pair () hel = hel_arr (1) end if end function particle_get_helicity @ %def particle_get_helicity @ Return the number of children/parents <>= procedure :: get_n_parents => particle_get_n_parents procedure :: get_n_children => particle_get_n_children <>= elemental function particle_get_n_parents (prt) result (n) integer :: n class(particle_t), intent(in) :: prt if (allocated (prt%parent)) then n = size (prt%parent) else n = 0 end if end function particle_get_n_parents elemental function particle_get_n_children (prt) result (n) integer :: n class(particle_t), intent(in) :: prt if (allocated (prt%child)) then n = size (prt%child) else n = 0 end if end function particle_get_n_children @ %def particle_get_n_parents particle_get_n_children @ Return the array of parents/children. <>= procedure :: get_parents => particle_get_parents procedure :: get_children => particle_get_children <>= function particle_get_parents (prt) result (parent) class(particle_t), intent(in) :: prt integer, dimension(:), allocatable :: parent if (allocated (prt%parent)) then allocate (parent (size (prt%parent))) parent = prt%parent else allocate (parent (0)) end if end function particle_get_parents function particle_get_children (prt) result (child) class(particle_t), intent(in) :: prt integer, dimension(:), allocatable :: child if (allocated (prt%child)) then allocate (child (size (prt%child))) child = prt%child else allocate (child (0)) end if end function particle_get_children @ %def particle_get_children @ <>= procedure :: has_children => particle_has_children <>= elemental function particle_has_children (prt) result (has_children) logical :: has_children class(particle_t), intent(in) :: prt has_children = .false. if (allocated (prt%child)) then has_children = size (prt%child) > 0 end if end function particle_has_children @ %def particle_has_children @ <>= procedure :: has_parents => particle_has_parents <>= elemental function particle_has_parents (prt) result (has_parents) logical :: has_parents class(particle_t), intent(in) :: prt has_parents = .false. if (allocated (prt%parent)) then has_parents = size (prt%parent) > 0 end if end function particle_has_parents @ %def particle_has_parents @ Return momentum and momentum squared. <>= procedure :: get_momentum => particle_get_momentum procedure :: get_p2 => particle_get_p2 <>= elemental function particle_get_momentum (prt) result (p) type(vector4_t) :: p class(particle_t), intent(in) :: prt p = prt%p end function particle_get_momentum elemental function particle_get_p2 (prt) result (p2) real(default) :: p2 class(particle_t), intent(in) :: prt p2 = prt%p2 end function particle_get_p2 @ %def particle_get_momentum particle_get_p2 @ Return the particle vertex, if allocated. <>= procedure :: get_vertex => particle_get_vertex <>= elemental function particle_get_vertex (prt) result (vtx) type(vector4_t) :: vtx class(particle_t), intent(in) :: prt if (allocated (prt%vertex)) then vtx = prt%vertex else vtx = vector4_null end if end function particle_get_vertex @ %def particle_get_vertex @ Return the lifetime of a particle. <>= procedure :: get_lifetime => particle_get_lifetime <>= elemental function particle_get_lifetime (prt) result (lifetime) real(default) :: lifetime class(particle_t), intent(in) :: prt if (allocated (prt%lifetime)) then lifetime = prt%lifetime else lifetime = 0 end if end function particle_get_lifetime @ %def particle_get_lifetime @ <>= procedure :: momentum_to_pythia6 => particle_momentum_to_pythia6 <>= pure function particle_momentum_to_pythia6 (prt) result (p) real(double), dimension(1:5) :: p class(particle_t), intent(in) :: prt p = prt%p%to_pythia6 (sqrt (prt%p2)) end function particle_momentum_to_pythia6 @ %def particle_momentum_to_pythia6 @ \subsection{Particle sets} A particle set is what is usually called an event: an array of particles. The individual particle entries carry momentum, quantum numbers, polarization, and optionally connections. There is (also optionally) a correlated state-density matrix that maintains spin correlations that are lost in the individual particle entries. <>= public :: particle_set_t <>= type :: particle_set_t ! private !!! integer :: n_beam = 0 integer :: n_in = 0 integer :: n_vir = 0 integer :: n_out = 0 integer :: n_tot = 0 integer :: factorization_mode = FM_IGNORE_HELICITY type(particle_t), dimension(:), allocatable :: prt type(state_matrix_t) :: correlated_state contains <> end type particle_set_t @ %def particle_set_t @ A particle set can be initialized from an interaction or from a HepMC event record. <>= generic :: init => init_interaction procedure :: init_interaction => particle_set_init_interaction @ When a particle set is initialized from a given interaction, we have to determine the branch within the original state matrix that fixes the particle quantum numbers. This is done with the appropriate probabilities, based on a random number [[x]]. The [[mode]] determines whether the individual particles become unpolarized, or take a definite (diagonal) helicity, or acquire single-particle polarization matrices. The flag [[keep_correlations]] tells whether the spin-correlation matrix is to be calculated and stored in addition to the particles. The flag [[keep_virtual]] tells whether virtual particles should be dropped. Note that if virtual particles are dropped, the spin-correlation matrix makes no sense, and parent-child relations are not set. For a correct disentangling of color and flavor (in the presence of helicity), we consider two interactions. [[int]] has no color information, and is used to select a flavor state. Consequently, we trace over helicities here. [[int_flows]] contains color-flow and potentially helicity information, but is useful only after the flavor combination has been chosen. So this interaction is used to select helicity and color, but restricted to the selected flavor combination. [[int]] and [[int_flows]] may be identical if there is only a single (or no) color flow. If there is just a single flavor combination, [[x(1)]] can be set to zero. The current algorithm of evaluator convolution requires that the beam particles are assumed outgoing (in the beam interaction) and become virtual in all derived interactions. In the particle set they should be re-identified as incoming. The optional integer [[n_incoming]] can be used to perform this correction. The flag [[is_valid]] is false if factorization of the state is not possible, in particular if the squared matrix element is zero. <>= subroutine particle_set_init_interaction & (particle_set, is_valid, int, int_flows, mode, x, & keep_correlations, keep_virtual, n_incoming, qn_select) class(particle_set_t), intent(out) :: particle_set logical, intent(out) :: is_valid type(interaction_t), intent(in), target :: int, int_flows integer, intent(in) :: mode real(default), dimension(2), intent(in) :: x logical, intent(in) :: keep_correlations, keep_virtual integer, intent(in), optional :: n_incoming type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_select type(state_matrix_t), dimension(:), allocatable, target :: flavor_state type(state_matrix_t), dimension(:), allocatable, target :: single_state integer :: n_in, n_vir, n_out, n_tot type(quantum_numbers_t), dimension(:,:), allocatable :: qn logical :: ok integer :: i, j if (present (n_incoming)) then n_in = n_incoming n_vir = int%get_n_vir () - n_incoming else n_in = int%get_n_in () n_vir = int%get_n_vir () end if n_out = int%get_n_out () n_tot = int%get_n_tot () particle_set%n_in = n_in particle_set%n_out = n_out if (keep_virtual) then particle_set%n_vir = n_vir particle_set%n_tot = n_tot else particle_set%n_vir = 0 particle_set%n_tot = n_in + n_out end if particle_set%factorization_mode = mode allocate (qn (n_tot, 1)) if (.not. present (qn_select)) then call int%factorize & (FM_IGNORE_HELICITY, x(1), is_valid, flavor_state) do i = 1, n_tot qn(i,:) = flavor_state(i)%get_quantum_number (1) end do else do i = 1, n_tot qn(i,:) = qn_select(i) end do is_valid = .true. end if if (keep_correlations .and. keep_virtual) then call particle_set%correlated_state%final () call int_flows%factorize (mode, x(2), ok, & single_state, particle_set%correlated_state, qn(:,1)) else call int_flows%factorize (mode, x(2), ok, & single_state, qn_in=qn(:,1)) end if is_valid = is_valid .and. ok allocate (particle_set%prt (particle_set%n_tot)) j = 1 do i = 1, n_tot if (i <= n_in) then call particle_set%prt(j)%init (single_state(i), PRT_INCOMING, mode) call particle_set%prt(j)%set_momentum (int%get_momentum (i)) else if (i <= n_in + n_vir) then if (.not. keep_virtual) cycle call particle_set%prt(j)%init & (single_state(i), PRT_VIRTUAL, mode) call particle_set%prt(j)%set_momentum (int%get_momentum (i)) else call particle_set%prt(j)%init (single_state(i), PRT_OUTGOING, mode) call particle_set%prt(j)%set_momentum & (int%get_momentum (i), on_shell = .true.) end if if (keep_virtual) then - call particle_set%prt(j)%set_children & - (interaction_get_children (int, i)) - call particle_set%prt(j)%set_parents & - (interaction_get_parents (int, i)) + call particle_set%prt(j)%set_children (int%get_children (i)) + call particle_set%prt(j)%set_parents (int%get_parents (i)) end if j = j + 1 end do if (keep_virtual) then call particle_set_resonance_flag & (particle_set%prt, int%get_resonance_flags ()) end if if (allocated (flavor_state)) then do i = 1, size(flavor_state) call flavor_state(i)%final () end do end if do i = 1, size(single_state) call single_state(i)%final () end do end subroutine particle_set_init_interaction @ %def particle_set_init_interaction @ Duplicate generic binding, to make sure that assignment works as it should. <>= generic :: assignment(=) => init_particle_set generic :: init => init_particle_set procedure :: init_particle_set => particle_set_init_particle_set <>= subroutine particle_set_init_particle_set (pset_out, pset_in) class(particle_set_t), intent(out) :: pset_out type(particle_set_t), intent(in) :: pset_in integer :: i pset_out%n_beam = pset_in%n_beam pset_out%n_in = pset_in%n_in pset_out%n_vir = pset_in%n_vir pset_out%n_out = pset_in%n_out pset_out%n_tot = pset_in%n_tot pset_out%factorization_mode = pset_in%factorization_mode if (allocated (pset_in%prt)) then allocate (pset_out%prt (size (pset_in%prt))) do i = 1, size (pset_in%prt) pset_out%prt(i) = pset_in%prt(i) end do end if pset_out%correlated_state = pset_in%correlated_state end subroutine particle_set_init_particle_set @ %def particle_set_init_particle_set @ Manually set the model for the stored particles. <>= procedure :: set_model => particle_set_set_model <>= subroutine particle_set_set_model (particle_set, model) class(particle_set_t), intent(inout) :: particle_set class(model_data_t), intent(in), target :: model integer :: i do i = 1, particle_set%n_tot call particle_set%prt(i)%set_model (model) end do call particle_set%correlated_state%set_model (model) end subroutine particle_set_set_model @ %def particle_set_set_model @ Pointer components are hidden inside the particle polarization, and in the correlated state matrix. <>= procedure :: final => particle_set_final <>= subroutine particle_set_final (particle_set) class(particle_set_t), intent(inout) :: particle_set integer :: i if (allocated (particle_set%prt)) then do i = 1, size(particle_set%prt) call particle_set%prt(i)%final () end do deallocate (particle_set%prt) end if call particle_set%correlated_state%final () end subroutine particle_set_final @ %def particle_set_final @ \subsection{Manual build} Basic initialization. Just allocate with a given number of beam, incoming, virtual, and outgoing particles. <>= procedure :: basic_init => particle_set_basic_init <>= subroutine particle_set_basic_init (particle_set, n_beam, n_in, n_vir, n_out) class(particle_set_t), intent(out) :: particle_set integer, intent(in) :: n_beam, n_in, n_vir, n_out particle_set%n_beam = n_beam particle_set%n_in = n_in particle_set%n_vir = n_vir particle_set%n_out = n_out particle_set%n_tot = n_beam + n_in + n_vir + n_out allocate (particle_set%prt (particle_set%n_tot)) end subroutine particle_set_basic_init @ %def particle_set_basic_init @ Build a particle set from scratch. This is used for testing purposes. The ordering of particles in the result is beam-incoming-remnant-virtual-outgoing. Parent-child relations: \begin{itemize} \item Beams are parents of incoming and beam remnants. The assignment is alternating (first beam, second beam). \item Incoming are parents of virtual and outgoing, collectively. \end{itemize} More specific settings, such as resonance histories, cannot be set this way. Beam-remnant particles are counted as virtual, but have a different status code. We assume that the [[pdg]] array has the correct size. <>= procedure :: init_direct => particle_set_init_direct <>= subroutine particle_set_init_direct (particle_set, & n_beam, n_in, n_rem, n_vir, n_out, pdg, model) class(particle_set_t), intent(out) :: particle_set integer, intent(in) :: n_beam integer, intent(in) :: n_in integer, intent(in) :: n_rem integer, intent(in) :: n_vir integer, intent(in) :: n_out integer, dimension(:), intent(in) :: pdg class(model_data_t), intent(in), target :: model type(flavor_t), dimension(:), allocatable :: flv integer :: i, k, n call particle_set%basic_init (n_beam, n_in, n_rem+n_vir, n_out) n = 0 call particle_set%prt(n+1:n+n_beam)%reset_status (PRT_BEAM) do i = n+1, n+n_beam call particle_set%prt(i)%set_children & ([(k, k=i+n_beam, n+n_beam+n_in+n_rem, 2)]) end do n = n + n_beam call particle_set%prt(n+1:n+n_in)%reset_status (PRT_INCOMING) do i = n+1, n+n_in if (n_beam > 0) then call particle_set%prt(i)%set_parents & ([i-n_beam]) end if call particle_set%prt(i)%set_children & ([(k, k=n+n_in+n_rem+1, n+n_in+n_rem+n_vir+n_out)]) end do n = n + n_in call particle_set%prt(n+1:n+n_rem)%reset_status (PRT_BEAM_REMNANT) do i = n+1, n+n_rem if (n_beam > 0) then call particle_set%prt(i)%set_parents & ([i-n_in-n_beam]) end if end do n = n + n_rem call particle_set%prt(n+1:n+n_vir)%reset_status (PRT_VIRTUAL) do i = n+1, n+n_vir call particle_set%prt(i)%set_parents & ([(k, k=n-n_rem-n_in+1, n-n_rem)]) end do n = n + n_vir call particle_set%prt(n+1:n+n_out)%reset_status (PRT_OUTGOING) do i = n+1, n+n_out call particle_set%prt(i)%set_parents & ([(k, k=n-n_vir-n_rem-n_in+1, n-n_vir-n_rem)]) end do allocate (flv (particle_set%n_tot)) call flv%init (pdg, model) do k = n_beam+n_in+1, n_beam+n_in+n_rem call flv(k)%tag_radiated () end do do i = 1, particle_set%n_tot call particle_set%prt(i)%set_flavor (flv(i)) end do end subroutine particle_set_init_direct @ %def particle_set_init_direct @ Copy a particle set into a new, extended one. Use the mapping array to determine the new positions of particles. The new set contains [[n_new]] additional entries. Count the new, undefined particles as virtual. <>= procedure :: transfer => particle_set_transfer <>= subroutine particle_set_transfer (pset, source, n_new, map) class(particle_set_t), intent(out) :: pset class(particle_set_t), intent(in) :: source integer, intent(in) :: n_new integer, dimension(:), intent(in) :: map integer :: i call pset%basic_init & (source%n_beam, source%n_in, source%n_vir + n_new, source%n_out) pset%factorization_mode = source%factorization_mode do i = 1, source%n_tot call pset%prt(map(i))%reset_status (source%prt(i)%get_status ()) call pset%prt(map(i))%set_flavor (source%prt(i)%get_flv ()) call pset%prt(map(i))%set_color (source%prt(i)%get_col ()) call pset%prt(map(i))%set_parents (map (source%prt(i)%get_parents ())) call pset%prt(map(i))%set_children (map (source%prt(i)%get_children ())) call pset%prt(map(i))%set_polarization & (source%prt(i)%get_polarization_status ()) select case (source%prt(i)%get_polarization_status ()) case (PRT_DEFINITE_HELICITY) call pset%prt(map(i))%set_helicity (source%prt(i)%get_hel ()) case (PRT_GENERIC_POLARIZATION) call pset%prt(map(i))%set_pol (source%prt(i)%get_polarization ()) end select end do end subroutine particle_set_transfer @ %def particle_set_transfer @ Insert a new particle as an intermediate into a previously empty position. Flavor and status are just set. Color is not set (but see below). The complicated part is reassigning parent-child relations. The inserted particle comes with an array [[child]] of its children which are supposed to be existing particles. We first scan all particles that come before the new insertion. Whenever a particle has children that coincide with the children of the new particle, those child entries are removed. (a) If the new particle has no parent entry yet, those child entries are replaced by the index of the new particle and simultaneously, the particle is registered as a parent of the new particle. (b) If the current particle already has a parent entry, those child entries are removed. When this is done, the new particle is registered as the (only) parent of its children. <>= procedure :: insert => particle_set_insert <>= subroutine particle_set_insert (pset, i, status, flv, child) class(particle_set_t), intent(inout) :: pset integer, intent(in) :: i integer, intent(in) :: status type(flavor_t), intent(in) :: flv integer, dimension(:), intent(in) :: child integer, dimension(:), allocatable :: p_child, parent integer :: j, k, c, n_parent logical :: no_match call pset%prt(i)%reset_status (status) call pset%prt(i)%set_flavor (flv) call pset%prt(i)%set_children (child) n_parent = pset%prt(i)%get_n_parents () do j = 1, i - 1 p_child = pset%prt(j)%get_children () no_match = .true. do k = 1, size (p_child) if (any (p_child(k) == child)) then if (n_parent == 0 .and. no_match) then if (.not. allocated (parent)) then parent = [j] else parent = [parent, j] end if p_child(k) = i else p_child(k) = 0 end if no_match = .false. end if end do if (.not. no_match) then p_child = pack (p_child, p_child /= 0) call pset%prt(j)%set_children (p_child) end if end do if (n_parent == 0) then call pset%prt(i)%set_parents (parent) end if do j = 1, size (child) c = child(j) call pset%prt(c)%set_parents ([i]) end do end subroutine particle_set_insert @ %def particle_set_insert @ This should be done after completing all insertions: recover color assignments for the inserted particles, working backwards from children to parents. A single call to the routine recovers the color and anticolor line indices for a single particle. <>= procedure :: recover_color => particle_set_recover_color <>= subroutine particle_set_recover_color (pset, i) class(particle_set_t), intent(inout) :: pset integer, intent(in) :: i type(color_t) :: col integer, dimension(:), allocatable :: child integer :: j child = pset%prt(i)%get_children () if (size (child) > 0) then col = pset%prt(child(1))%get_col () do j = 2, size (child) col = col .fuse. pset%prt(child(j))%get_col () end do call pset%prt(i)%set_color (col) end if end subroutine particle_set_recover_color @ %def particle_set_recover_color @ \subsection{Extract/modify contents} <>= generic :: get_color => get_color_all generic :: get_color => get_color_indices procedure :: get_color_all => particle_set_get_color_all procedure :: get_color_indices => particle_set_get_color_indices <>= function particle_set_get_color_all (particle_set) result (col) class(particle_set_t), intent(in) :: particle_set type(color_t), dimension(:), allocatable :: col allocate (col (size (particle_set%prt))) col = particle_set%prt%col end function particle_set_get_color_all @ %def particle_set_get_color_all @ <>= function particle_set_get_color_indices (particle_set, indices) result (col) type(color_t), dimension(:), allocatable :: col class(particle_set_t), intent(in) :: particle_set integer, intent(in), dimension(:), allocatable :: indices integer :: i allocate (col (size (indices))) do i = 1, size (indices) col(i) = particle_set%prt(indices(i))%col end do end function particle_set_get_color_indices @ %def particle_set_get_color_indices @ Set a single or all color components. This is a wrapper around the corresponding [[particle_t]] method, with the same options. We assume that the particle array is allocated. <>= generic :: set_color => set_color_single generic :: set_color => set_color_indices generic :: set_color => set_color_all procedure :: set_color_single => particle_set_set_color_single procedure :: set_color_indices => particle_set_set_color_indices procedure :: set_color_all => particle_set_set_color_all <>= subroutine particle_set_set_color_single (particle_set, i, col) class(particle_set_t), intent(inout) :: particle_set integer, intent(in) :: i type(color_t), intent(in) :: col call particle_set%prt(i)%set_color (col) end subroutine particle_set_set_color_single subroutine particle_set_set_color_indices (particle_set, indices, col) class(particle_set_t), intent(inout) :: particle_set integer, dimension(:), intent(in) :: indices type(color_t), dimension(:), intent(in) :: col integer :: i do i = 1, size (indices) call particle_set%prt(indices(i))%set_color (col(i)) end do end subroutine particle_set_set_color_indices subroutine particle_set_set_color_all (particle_set, col) class(particle_set_t), intent(inout) :: particle_set type(color_t), dimension(:), intent(in) :: col call particle_set%prt%set_color (col) end subroutine particle_set_set_color_all @ %def particle_set_set_color @ Assigning particles manually may result in color mismatches. This is checked here for all particles in the set. The color object is compared against the color type that belongs to the flavor object. The return value is an allocatable array which consists of the particles with invalid color assignments. If the array size is zero, all is fine. <>= procedure :: find_prt_invalid_color => particle_set_find_prt_invalid_color <>= subroutine particle_set_find_prt_invalid_color (particle_set, index, prt) class(particle_set_t), intent(in) :: particle_set integer, dimension(:), allocatable, intent(out) :: index type(particle_t), dimension(:), allocatable, intent(out), optional :: prt type(flavor_t) :: flv type(color_t) :: col logical, dimension(:), allocatable :: mask integer :: i, n, n_invalid n = size (particle_set%prt) allocate (mask (n)) do i = 1, n associate (prt => particle_set%prt(i)) flv = prt%get_flv () col = prt%get_col () mask(i) = flv%get_color_type () /= col%get_type () end associate end do index = pack ([(i, i = 1, n)], mask) if (present (prt)) prt = pack (particle_set%prt, mask) end subroutine particle_set_find_prt_invalid_color @ %def particle_set_find_prt_invalid_color @ <>= generic :: get_momenta => get_momenta_all generic :: get_momenta => get_momenta_indices procedure :: get_momenta_all => particle_set_get_momenta_all procedure :: get_momenta_indices => particle_set_get_momenta_indices <>= function particle_set_get_momenta_all (particle_set) result (p) class(particle_set_t), intent(in) :: particle_set type(vector4_t), dimension(:), allocatable :: p allocate (p (size (particle_set%prt))) p = particle_set%prt%p end function particle_set_get_momenta_all @ %def particle_set_get_momenta_all @ <>= function particle_set_get_momenta_indices (particle_set, indices) result (p) type(vector4_t), dimension(:), allocatable :: p class(particle_set_t), intent(in) :: particle_set integer, intent(in), dimension(:), allocatable :: indices integer :: i allocate (p (size (indices))) do i = 1, size (indices) p(i) = particle_set%prt(indices(i))%p end do end function particle_set_get_momenta_indices @ %def particle_set_get_momenta_indices @ Replace a single or all momenta. This is a wrapper around the corresponding [[particle_t]] method, with the same options. We assume that the particle array is allocated. <>= generic :: set_momentum => set_momentum_single generic :: set_momentum => set_momentum_indices generic :: set_momentum => set_momentum_all procedure :: set_momentum_single => particle_set_set_momentum_single procedure :: set_momentum_indices => particle_set_set_momentum_indices procedure :: set_momentum_all => particle_set_set_momentum_all <>= subroutine particle_set_set_momentum_single & (particle_set, i, p, p2, on_shell) class(particle_set_t), intent(inout) :: particle_set integer, intent(in) :: i type(vector4_t), intent(in) :: p real(default), intent(in), optional :: p2 logical, intent(in), optional :: on_shell call particle_set%prt(i)%set_momentum (p, p2, on_shell) end subroutine particle_set_set_momentum_single subroutine particle_set_set_momentum_indices & (particle_set, indices, p, p2, on_shell) class(particle_set_t), intent(inout) :: particle_set integer, dimension(:), intent(in) :: indices type(vector4_t), dimension(:), intent(in) :: p real(default), dimension(:), intent(in), optional :: p2 logical, intent(in), optional :: on_shell integer :: i if (present (p2)) then do i = 1, size (indices) call particle_set%prt(indices(i))%set_momentum (p(i), p2(i), on_shell) end do else do i = 1, size (indices) call particle_set%prt(indices(i))%set_momentum & (p(i), on_shell=on_shell) end do end if end subroutine particle_set_set_momentum_indices subroutine particle_set_set_momentum_all (particle_set, p, p2, on_shell) class(particle_set_t), intent(inout) :: particle_set type(vector4_t), dimension(:), intent(in) :: p real(default), dimension(:), intent(in), optional :: p2 logical, intent(in), optional :: on_shell call particle_set%prt%set_momentum (p, p2, on_shell) end subroutine particle_set_set_momentum_all @ %def particle_set_set_momentum @ Recover a momentum by recombining from children, assuming that this is possible. The reconstructed momentum is not projected on-shell. <>= procedure :: recover_momentum => particle_set_recover_momentum <>= subroutine particle_set_recover_momentum (particle_set, i) class(particle_set_t), intent(inout) :: particle_set integer, intent(in) :: i type(vector4_t), dimension(:), allocatable :: p integer, dimension(:), allocatable :: index index = particle_set%prt(i)%get_children () p = particle_set%get_momenta (index) call particle_set%set_momentum (i, sum (p)) end subroutine particle_set_recover_momentum @ %def particle_set_recover_momentum @ <>= procedure :: replace_incoming_momenta => particle_set_replace_incoming_momenta <>= subroutine particle_set_replace_incoming_momenta (particle_set, p) class(particle_set_t), intent(inout) :: particle_set type(vector4_t), intent(in), dimension(:) :: p integer :: i, j i = 1 do j = 1, particle_set%get_n_tot () if (particle_set%prt(j)%get_status () == PRT_INCOMING) then particle_set%prt(j)%p = p(i) i = i + 1 if (i > particle_set%n_in) exit end if end do end subroutine particle_set_replace_incoming_momenta @ %def particle_set_replace_incoming_momenta @ <>= procedure :: replace_outgoing_momenta => particle_set_replace_outgoing_momenta <>= subroutine particle_set_replace_outgoing_momenta (particle_set, p) class(particle_set_t), intent(inout) :: particle_set type(vector4_t), intent(in), dimension(:) :: p integer :: i, j i = particle_set%n_in + 1 do j = 1, particle_set%n_tot if (particle_set%prt(j)%get_status () == PRT_OUTGOING) then particle_set%prt(j)%p = p(i) i = i + 1 end if end do end subroutine particle_set_replace_outgoing_momenta @ %def particle_set_replace_outgoing_momenta @ <>= procedure :: get_outgoing_momenta => particle_set_get_outgoing_momenta <>= function particle_set_get_outgoing_momenta (particle_set) result (p) class(particle_set_t), intent(in) :: particle_set type(vector4_t), dimension(:), allocatable :: p integer :: i, k allocate (p (count (particle_set%prt%get_status () == PRT_OUTGOING))) k = 0 do i = 1, size (particle_set%prt) if (particle_set%prt(i)%get_status () == PRT_OUTGOING) then k = k + 1 p(k) = particle_set%prt(i)%get_momentum () end if end do end function particle_set_get_outgoing_momenta @ %def particle_set_get_outgoing_momenta @ <>= procedure :: parent_add_child => particle_set_parent_add_child <>= subroutine particle_set_parent_add_child (particle_set, parent, child) class(particle_set_t), intent(inout) :: particle_set integer, intent(in) :: parent, child call particle_set%prt(child)%set_parents ([parent]) call particle_set%prt(parent)%add_child (child) end subroutine particle_set_parent_add_child @ %def particle_set_parent_add_child @ Given the [[particle_set]] before radiation, the new momenta [[p_radiated]], the [[emitter]] and the [[flv_radiated]] as well as the [[model]] and a random number [[r_color]] for chosing a color, we update the [[particle_set]]. <>= procedure :: build_radiation => particle_set_build_radiation <>= subroutine particle_set_build_radiation (particle_set, p_radiated, & emitter, flv_radiated, model, r_color) class(particle_set_t), intent(inout) :: particle_set type(vector4_t), intent(in), dimension(:) :: p_radiated integer, intent(in) :: emitter integer, intent(in), dimension(:) :: flv_radiated class(model_data_t), intent(in), target :: model real(default), intent(in) :: r_color type(particle_set_t) :: new_particle_set type(particle_t) :: new_particle integer :: i integer :: pdg_index_emitter, pdg_index_radiation integer, dimension(:), allocatable :: parents, children type(flavor_t) :: new_flv logical, dimension(:), allocatable :: status_mask integer, dimension(:), allocatable :: & i_in1, i_beam1, i_remnant1, i_virt1, i_out1 integer, dimension(:), allocatable :: & i_in2, i_beam2, i_remnant2, i_virt2, i_out2 integer :: n_in1, n_beam1, n_remnant1, n_virt1, n_out1 integer :: n_in2, n_beam2, n_remnant2, n_virt2, n_out2 integer :: n, n_tot integer :: i_emitter n = particle_set%get_n_tot () allocate (status_mask (n)) do i = 1, n status_mask(i) = particle_set%prt(i)%get_status () == PRT_INCOMING end do n_in1 = count (status_mask) allocate (i_in1 (n_in1)) i_in1 = particle_set%get_indices (status_mask) do i = 1, n status_mask(i) = particle_set%prt(i)%get_status () == PRT_BEAM end do n_beam1 = count (status_mask) allocate (i_beam1 (n_beam1)) i_beam1 = particle_set%get_indices (status_mask) do i = 1, n status_mask(i) = particle_set%prt(i)%get_status () == PRT_BEAM_REMNANT end do n_remnant1 = count (status_mask) allocate (i_remnant1 (n_remnant1)) i_remnant1 = particle_set%get_indices (status_mask) do i = 1, n status_mask(i) = particle_set%prt(i)%get_status () == PRT_VIRTUAL end do n_virt1 = count (status_mask) allocate (i_virt1 (n_virt1)) i_virt1 = particle_set%get_indices (status_mask) do i = 1, n status_mask(i) = particle_set%prt(i)%get_status () == PRT_OUTGOING end do n_out1 = count (status_mask) allocate (i_out1 (n_out1)) i_out1 = particle_set%get_indices (status_mask) n_in2 = n_in1; n_beam2 = n_beam1; n_remnant2 = n_remnant1 n_virt2 = n_virt1 + n_out1 n_out2 = n_out1 + 1 n_tot = n_in2 + n_beam2 + n_remnant2 + n_virt2 + n_out2 allocate (i_in2 (n_in2), i_beam2 (n_beam2), i_remnant2 (n_remnant2)) i_in2 = i_in1; i_beam2 = i_beam1; i_remnant2 = i_remnant1 allocate (i_virt2 (n_virt2)) i_virt2(1 : n_virt1) = i_virt1 i_virt2(n_virt1 + 1 : n_virt2) = i_out1 allocate (i_out2 (n_out2)) i_out2(1 : n_out1) = i_out1(1 : n_out1) + n_out1 i_out2(n_out2) = n_tot new_particle_set%n_beam = n_beam2 new_particle_set%n_in = n_in2 new_particle_set%n_vir = n_virt2 new_particle_set%n_out = n_out2 new_particle_set%n_tot = n_tot new_particle_set%correlated_state = particle_set%correlated_state allocate (new_particle_set%prt (n_tot)) if (size (i_beam1) > 0) new_particle_set%prt(i_beam2) = particle_set%prt(i_beam1) if (size (i_remnant1) > 0) new_particle_set%prt(i_remnant2) = particle_set%prt(i_remnant1) do i = 1, n_virt1 new_particle_set%prt(i_virt2(i)) = particle_set%prt(i_virt1(i)) end do do i = n_virt1 + 1, n_virt2 new_particle_set%prt(i_virt2(i)) = particle_set%prt(i_out1(i - n_virt1)) call new_particle_set%prt(i_virt2(i))%reset_status (PRT_VIRTUAL) end do do i = 1, n_in2 new_particle_set%prt(i_in2(i)) = particle_set%prt(i_in1(i)) new_particle_set%prt(i_in2(i))%p = p_radiated (i) end do do i = 1, n_out2 - 1 new_particle_set%prt(i_out2(i)) = particle_set%prt(i_out1(i)) new_particle_set%prt(i_out2(i))%p = p_radiated(i + n_in2) call new_particle_set%prt(i_out2(i))%reset_status (PRT_OUTGOING) end do call new_particle%reset_status (PRT_OUTGOING) call new_particle%set_momentum (p_radiated (n_in2 + n_out2)) !!! Helicity and polarization handling is missing at this point !!! Also, no helicities or polarizations yet pdg_index_emitter = flv_radiated (emitter) pdg_index_radiation = flv_radiated (n_in2 + n_out2) call new_flv%init (pdg_index_radiation, model) i_emitter = emitter + n_virt2 + n_remnant2 + n_beam2 call reassign_colors (new_particle, new_particle_set%prt(i_emitter), & pdg_index_radiation, pdg_index_emitter, r_color) call new_particle%set_flavor (new_flv) new_particle_set%prt(n_tot) = new_particle allocate (children (n_out2)) children = i_out2 do i = n_in2 + n_beam2 + n_remnant2 + n_virt1 + 1, n_in2 + n_beam2 + n_remnant2 + n_virt2 call new_particle_set%prt(i)%set_children (children) end do !!! Set proper parents for outgoing particles allocate (parents (n_out1)) parents = i_out1 do i = n_in2 + n_beam2 + n_remnant2 + n_virt2 + 1, n_tot call new_particle_set%prt(i)%set_parents (parents) end do call particle_set%init (new_particle_set) contains <> subroutine reassign_colors (prt_radiated, prt_emitter, i_rad, i_em, r_col) type(particle_t), intent(inout) :: prt_radiated, prt_emitter integer, intent(in) :: i_rad, i_em real(default), intent(in) :: r_col type(color_t) :: col_rad, col_em if (is_quark (i_em) .and. is_gluon (i_rad)) then call reassign_colors_qg (prt_emitter, col_rad, col_em) else if (is_gluon (i_em) .and. is_gluon (i_rad)) then call reassign_colors_gg (prt_emitter, r_col, col_rad, col_em) else if (is_gluon (i_em) .and. is_quark (i_rad)) then call reassign_colors_qq (prt_emitter, i_em, col_rad, col_em) else call msg_fatal ("Invalid splitting") end if call prt_emitter%set_color (col_em) call prt_radiated%set_color (col_rad) end subroutine reassign_colors subroutine reassign_colors_qg (prt_emitter, col_rad, col_em) type(particle_t), intent(in) :: prt_emitter type(color_t), intent(out) :: col_rad, col_em integer, dimension(2) :: color_rad, color_em integer :: i1, i2 integer :: new_color_index logical :: is_anti_quark color_em = prt_emitter%get_color () i1 = 1; i2 = 2 is_anti_quark = color_em(2) /= 0 if (is_anti_quark) then i1 = 2; i2 = 1 end if new_color_index = color_em(i1)+1 color_rad(i1) = color_em(i1) color_rad(i2) = new_color_index color_em(i1) = new_color_index call col_em%init_col_acl (color_em(1), color_em(2)) call col_rad%init_col_acl (color_rad(1), color_rad(2)) end subroutine reassign_colors_qg subroutine reassign_colors_gg (prt_emitter, random, col_rad, col_em) !!! NOT TESTED YET type(particle_t), intent(in) :: prt_emitter real(default), intent(in) :: random type(color_t), intent(out) :: col_rad, col_em integer, dimension(2) :: color_rad, color_em integer :: i1, i2 integer :: new_color_index color_em = prt_emitter%get_color () new_color_index = maxval (abs (color_em)) i1 = 1; i2 = 2 if (random < 0.5) then i1 = 2; i2 = 1 end if color_rad(i1) = new_color_index color_rad(i2) = color_em(i2) color_em(i2) = new_color_index call col_em%init_col_acl (color_em(1), color_em(2)) call col_rad%init_col_acl (color_rad(1), color_rad(2)) end subroutine reassign_colors_gg subroutine reassign_colors_qq (prt_emitter, pdg_emitter, col_rad, col_em) !!! NOT TESTED YET type(particle_t), intent(in) :: prt_emitter integer, intent(in) :: pdg_emitter type(color_t), intent(out) :: col_rad, col_em integer, dimension(2) :: color_rad, color_em integer :: i1, i2 logical :: is_anti_quark color_em = prt_emitter%get_color () i1 = 1; i2 = 2 is_anti_quark = pdg_emitter < 0 if (is_anti_quark) then i1 = 2; i1 = 1 end if color_em(i2) = 0 color_rad(i1) = 0 color_rad(i2) = color_em(i1) call col_em%init_col_acl (color_em(1), color_em(2)) call col_rad%init_col_acl (color_rad(1), color_rad(2)) end subroutine reassign_colors_qq end subroutine particle_set_build_radiation @ %def particle_set_build_radiation @ Increments the color indices of all particles by their maximal value to distinguish them from the record-keeping Born particles in the LHE-output if the virtual entries are kept. <>= subroutine set_color_offset (particle_set) type(particle_set_t), intent(inout) :: particle_set integer, dimension(2) :: color integer :: i, i_color_max type(color_t) :: new_color i_color_max = 0 do i = 1, size (particle_set%prt) associate (prt => particle_set%prt(i)) if (prt%get_status () <= PRT_INCOMING) cycle color = prt%get_color () i_color_max = maxval([i_color_max, color(1), color(2)]) end associate end do do i = 1, size (particle_set%prt) associate (prt => particle_set%prt(i)) if (prt%get_status () /= PRT_OUTGOING) cycle color = prt%get_color () where (color /= 0) color = color + i_color_max call new_color%init_col_acl (color(1), color(2)) call prt%set_color (new_color) end associate end do end subroutine set_color_offset @ %def set_color_offset @ Output (default format) <>= procedure :: write => particle_set_write <>= subroutine particle_set_write & (particle_set, unit, testflag, summary, compressed) class(particle_set_t), intent(in) :: particle_set integer, intent(in), optional :: unit logical, intent(in), optional :: testflag, summary, compressed logical :: summ, comp, pol type(vector4_t) :: sum_vec integer :: u, i u = given_output_unit (unit); if (u < 0) return summ = .false.; if (present (summary)) summ = summary comp = .false.; if (present (compressed)) comp = compressed pol = particle_set%factorization_mode /= FM_IGNORE_HELICITY write (u, "(1x,A)") "Particle set:" call write_separator (u) if (comp) then if (pol) then write (u, & "((A4,1X),(A6,1X),(A7,1X),(A3),2(A4,1X),2(A20,1X),5(A12,1X))") & "Nr", "Status", "Flavor", "Hel", "Col", "ACol", & "Parents", "Children", & "P(0)", "P(1)", "P(2)", "P(3)", "P^2" else write (u, & "((A4,1X),(A6,1X),(A7,1X),2(A4,1X),2(A20,1X),5(A12,1X))") & "Nr", "Status", "Flavor", "Col", "ACol", & "Parents", "Children", & "P(0)", "P(1)", "P(2)", "P(3)", "P^2" end if end if if (particle_set%n_tot /= 0) then do i = 1, particle_set%n_tot if (comp) then write (u, "(I4,1X,2X)", advance="no") i else write (u, "(1x,A,1x,I0)", advance="no") "Particle", i end if call particle_set%prt(i)%write (u, testflag = testflag, & compressed = comp, polarization = pol) end do if (particle_set%correlated_state%is_defined ()) then call write_separator (u) write (u, *) "Correlated state density matrix:" call particle_set%correlated_state%write (u) end if if (summ) then call write_separator (u) write (u, "(A)", advance="no") & "Sum of incoming momenta: p(0:3) = " sum_vec = sum (particle_set%prt%p, & mask=particle_set%prt%get_status () == PRT_INCOMING) call pacify (sum_vec, tolerance = 1E-3_default) call sum_vec%write (u, compressed=.true.) write (u, *) write (u, "(A)", advance="no") & "Sum of beam remnant momenta: p(0:3) = " sum_vec = sum (particle_set%prt%p, & mask=particle_set%prt%get_status () == PRT_BEAM_REMNANT) call pacify (sum_vec, tolerance = 1E-3_default) call sum_vec%write (u, compressed=.true.) write (u, *) write (u, "(A)", advance="no") & "Sum of outgoing momenta: p(0:3) = " sum_vec = sum (particle_set%prt%p, & mask=particle_set%prt%get_status () == PRT_OUTGOING) call pacify (sum_vec, tolerance = 1E-3_default) call sum_vec%write (u, compressed=.true.) write (u, "(A)") "" end if else write (u, "(3x,A)") "[empty]" end if end subroutine particle_set_write @ %def particle_set_write @ \subsection{I/O formats} Here, we define input/output of particle sets in various formats. This is the right place since particle sets contain most of the event information. All write/read routines take as first argument the object, as second argument the I/O unit which in this case is a mandatory argument. Then follow further event data. \subsubsection{Internal binary format} This format is supposed to contain the complete information, so the particle data set can be fully reconstructed. The exception is the model part of the particle flavors; this is unassigned for the flavor values read from file. <>= procedure :: write_raw => particle_set_write_raw procedure :: read_raw => particle_set_read_raw <>= subroutine particle_set_write_raw (particle_set, u) class(particle_set_t), intent(in) :: particle_set integer, intent(in) :: u integer :: i write (u) & particle_set%n_beam, particle_set%n_in, & particle_set%n_vir, particle_set%n_out write (u) particle_set%factorization_mode write (u) particle_set%n_tot do i = 1, particle_set%n_tot call particle_set%prt(i)%write_raw (u) end do call particle_set%correlated_state%write_raw (u) end subroutine particle_set_write_raw subroutine particle_set_read_raw (particle_set, u, iostat) class(particle_set_t), intent(out) :: particle_set integer, intent(in) :: u integer, intent(out) :: iostat integer :: i read (u, iostat=iostat) & particle_set%n_beam, particle_set%n_in, & particle_set%n_vir, particle_set%n_out read (u, iostat=iostat) particle_set%factorization_mode read (u, iostat=iostat) particle_set%n_tot allocate (particle_set%prt (particle_set%n_tot)) do i = 1, size (particle_set%prt) call particle_set%prt(i)%read_raw (u, iostat=iostat) end do call particle_set%correlated_state%read_raw (u, iostat=iostat) end subroutine particle_set_read_raw @ %def particle_set_write_raw particle_set_read_raw @ \subsubsection{Get contents} Find parents/children of a particular particle recursively; the search terminates if a parent/child has status [[BEAM]], [[INCOMING]], [[OUTGOING]] or [[RESONANT]]. <>= procedure :: get_real_parents => particle_set_get_real_parents procedure :: get_real_children => particle_set_get_real_children <>= function particle_set_get_real_parents (pset, i, keep_beams) result (parent) integer, dimension(:), allocatable :: parent class(particle_set_t), intent(in) :: pset integer, intent(in) :: i logical, intent(in), optional :: keep_beams logical, dimension(:), allocatable :: is_real logical, dimension(:), allocatable :: is_parent, is_real_parent logical :: kb integer :: j, k kb = .false. if (present (keep_beams)) kb = keep_beams allocate (is_real (pset%n_tot)) is_real = pset%prt%is_real (kb) allocate (is_parent (pset%n_tot), is_real_parent (pset%n_tot)) is_real_parent = .false. is_parent = .false. is_parent(pset%prt(i)%get_parents()) = .true. do while (any (is_parent)) where (is_real .and. is_parent) is_real_parent = .true. is_parent = .false. end where mark_next_parent: do j = size (is_parent), 1, -1 if (is_parent(j)) then is_parent(pset%prt(j)%get_parents()) = .true. is_parent(j) = .false. exit mark_next_parent end if end do mark_next_parent end do allocate (parent (count (is_real_parent))) j = 0 do k = 1, size (is_parent) if (is_real_parent(k)) then j = j + 1 parent(j) = k end if end do end function particle_set_get_real_parents function particle_set_get_real_children (pset, i, keep_beams) result (child) integer, dimension(:), allocatable :: child class(particle_set_t), intent(in) :: pset integer, intent(in) :: i logical, dimension(:), allocatable :: is_real logical, dimension(:), allocatable :: is_child, is_real_child logical, intent(in), optional :: keep_beams integer :: j, k logical :: kb kb = .false. if (present (keep_beams)) kb = keep_beams allocate (is_real (pset%n_tot)) is_real = pset%prt%is_real (kb) is_real = pset%prt%is_real (kb) allocate (is_child (pset%n_tot), is_real_child (pset%n_tot)) is_real_child = .false. is_child = .false. is_child(pset%prt(i)%get_children()) = .true. do while (any (is_child)) where (is_real .and. is_child) is_real_child = .true. is_child = .false. end where mark_next_child: do j = 1, size (is_child) if (is_child(j)) then is_child(pset%prt(j)%get_children()) = .true. is_child(j) = .false. exit mark_next_child end if end do mark_next_child end do allocate (child (count (is_real_child))) j = 0 do k = 1, size (is_child) if (is_real_child(k)) then j = j + 1 child(j) = k end if end do end function particle_set_get_real_children @ %def particle_set_get_real_parents @ %def particle_set_get_real_children @ Get the [[n_tot]], [[n_in]], and [[n_out]] values out of the particle set. <>= procedure :: get_n_beam => particle_set_get_n_beam procedure :: get_n_in => particle_set_get_n_in procedure :: get_n_vir => particle_set_get_n_vir procedure :: get_n_out => particle_set_get_n_out procedure :: get_n_tot => particle_set_get_n_tot procedure :: get_n_remnants => particle_set_get_n_remnants <>= function particle_set_get_n_beam (pset) result (n_beam) class(particle_set_t), intent(in) :: pset integer :: n_beam n_beam = pset%n_beam end function particle_set_get_n_beam function particle_set_get_n_in (pset) result (n_in) class(particle_set_t), intent(in) :: pset integer :: n_in n_in = pset%n_in end function particle_set_get_n_in function particle_set_get_n_vir (pset) result (n_vir) class(particle_set_t), intent(in) :: pset integer :: n_vir n_vir = pset%n_vir end function particle_set_get_n_vir function particle_set_get_n_out (pset) result (n_out) class(particle_set_t), intent(in) :: pset integer :: n_out n_out = pset%n_out end function particle_set_get_n_out function particle_set_get_n_tot (pset) result (n_tot) class(particle_set_t), intent(in) :: pset integer :: n_tot n_tot = pset%n_tot end function particle_set_get_n_tot function particle_set_get_n_remnants (pset) result (n_remn) class(particle_set_t), intent(in) :: pset integer :: n_remn if (allocated (pset%prt)) then n_remn = count (pset%prt%get_status () == PRT_BEAM_REMNANT) else n_remn = 0 end if end function particle_set_get_n_remnants @ %def particle_set_get_n_beam @ %def particle_set_get_n_in @ %def particle_set_get_n_vir @ %def particle_set_get_n_out @ %def particle_set_get_n_tot @ %def particle_set_get_n_remnants @ Return a pointer to the particle corresponding to the number <>= procedure :: get_particle => particle_set_get_particle <>= function particle_set_get_particle (pset, index) result (particle) class(particle_set_t), intent(in) :: pset integer, intent(in) :: index type(particle_t) :: particle particle = pset%prt(index) end function particle_set_get_particle @ %def particle_set_get_particle @ <>= procedure :: get_indices => particle_set_get_indices <>= pure function particle_set_get_indices (pset, mask) result (finals) integer, dimension(:), allocatable :: finals class(particle_set_t), intent(in) :: pset logical, dimension(:), intent(in) :: mask integer, dimension(size(mask)) :: indices integer :: i allocate (finals (count (mask))) indices = [(i, i=1, pset%n_tot)] finals = pack (indices, mask) end function particle_set_get_indices @ %def particle_set_get_indices @ Copy the subset of physical momenta to a [[phs_point]] container. <>= procedure :: get_in_and_out_momenta => particle_set_get_in_and_out_momenta <>= function particle_set_get_in_and_out_momenta (pset) result (phs_point) type(phs_point_t) :: phs_point class(particle_set_t), intent(in) :: pset logical, dimension(:), allocatable :: mask integer, dimension(:), allocatable :: indices type(vector4_t), dimension(:), allocatable :: p allocate (mask (pset%get_n_tot ())) allocate (p (size (pset%prt))) mask = pset%prt%status == PRT_INCOMING .or. & pset%prt%status == PRT_OUTGOING allocate (indices (count (mask))) indices = pset%get_indices (mask) phs_point = pset%get_momenta (indices) end function particle_set_get_in_and_out_momenta @ %def particle_set_get_in_and_out_momenta @ \subsubsection{Tools} Build a new particles array without hadronic remnants but with [[n_extra]] additional spots. We also update the mother-daughter relations assuming the ordering [[b]], [[i]], [[r]], [[x]], [[o]]. <>= procedure :: without_hadronic_remnants => & particle_set_without_hadronic_remnants <>= subroutine particle_set_without_hadronic_remnants & (particle_set, particles, n_particles, n_extra) class(particle_set_t), intent(inout) :: particle_set type(particle_t), dimension(:), allocatable, intent(out) :: particles integer, intent(out) :: n_particles integer, intent(in) :: n_extra logical, dimension(:), allocatable :: no_hadronic_remnants, & no_hadronic_children integer, dimension(:), allocatable :: children, new_children integer :: i, j, k, first_remnant first_remnant = particle_set%n_tot do i = 1, particle_set%n_tot if (particle_set%prt(i)%is_hadronic_beam_remnant ()) then first_remnant = i exit end if end do n_particles = count (.not. particle_set%prt%is_hadronic_beam_remnant ()) allocate (no_hadronic_remnants (particle_set%n_tot)) no_hadronic_remnants = .not. particle_set%prt%is_hadronic_beam_remnant () allocate (particles (n_particles + n_extra)) k = 1 do i = 1, particle_set%n_tot if (no_hadronic_remnants(i)) then particles(k) = particle_set%prt(i) k = k + 1 end if end do if (n_particles /= particle_set%n_tot) then do i = 1, n_particles select case (particles(i)%get_status ()) case (PRT_BEAM) if (allocated (children)) deallocate (children) allocate (children (particles(i)%get_n_children ())) children = particles(i)%get_children () if (allocated (no_hadronic_children)) & deallocate (no_hadronic_children) allocate (no_hadronic_children (particles(i)%get_n_children ())) no_hadronic_children = .not. & particle_set%prt(children)%is_hadronic_beam_remnant () if (allocated (new_children)) deallocate (new_children) allocate (new_children (count (no_hadronic_children))) new_children = pack (children, no_hadronic_children) call particles(i)%set_children (new_children) case (PRT_INCOMING, PRT_RESONANT) <> case (PRT_OUTGOING, PRT_BEAM_REMNANT) case default end select end do end if end subroutine particle_set_without_hadronic_remnants @ %def particle_set_without_hadronic_remnants <>= if (allocated (children)) deallocate (children) allocate (children (particles(i)%get_n_children ())) children = particles(i)%get_children () do j = 1, size (children) if (children(j) > first_remnant) then children(j) = children (j) - & (particle_set%n_tot - n_particles) end if end do call particles(i)%set_children (children) @ Build a new particles array without remnants but with [[n_extra]] additional spots. We also update the mother-daughter relations assuming the ordering [[b]], [[i]], [[r]], [[x]], [[o]]. <>= procedure :: without_remnants => particle_set_without_remnants <>= subroutine particle_set_without_remnants & (particle_set, particles, n_particles, n_extra) class(particle_set_t), intent(inout) :: particle_set type(particle_t), dimension(:), allocatable, intent(out) :: particles integer, intent(in) :: n_extra integer, intent(out) :: n_particles logical, dimension(:), allocatable :: no_remnants, no_children integer, dimension(:), allocatable :: children, new_children integer :: i,j, k, first_remnant first_remnant = particle_set%n_tot do i = 1, particle_set%n_tot if (particle_set%prt(i)%is_beam_remnant ()) then first_remnant = i exit end if end do allocate (no_remnants (particle_set%n_tot)) no_remnants = .not. (particle_set%prt%is_beam_remnant ()) n_particles = count (no_remnants) allocate (particles (n_particles + n_extra)) k = 1 do i = 1, particle_set%n_tot if (no_remnants(i)) then particles(k) = particle_set%prt(i) k = k + 1 end if end do if (n_particles /= particle_set%n_tot) then do i = 1, n_particles select case (particles(i)%get_status ()) case (PRT_BEAM) if (allocated (children)) deallocate (children) allocate (children (particles(i)%get_n_children ())) children = particles(i)%get_children () if (allocated (no_children)) deallocate (no_children) allocate (no_children (particles(i)%get_n_children ())) no_children = .not. (particle_set%prt(children)%is_beam_remnant ()) if (allocated (new_children)) deallocate (new_children) allocate (new_children (count (no_children))) new_children = pack (children, no_children) call particles(i)%set_children (new_children) case (PRT_INCOMING, PRT_RESONANT) <> case (PRT_OUTGOING, PRT_BEAM_REMNANT) case default end select end do end if end subroutine particle_set_without_remnants @ %def particle_set_without_remnants @ <>= procedure :: find_particle => particle_set_find_particle <>= pure function particle_set_find_particle (particle_set, pdg, & momentum, abs_smallness, rel_smallness) result (idx) integer :: idx class(particle_set_t), intent(in) :: particle_set integer, intent(in) :: pdg type(vector4_t), intent(in) :: momentum real(default), intent(in), optional :: abs_smallness, rel_smallness integer :: i logical, dimension(0:3) :: equals idx = 0 do i = 1, size (particle_set%prt) if (particle_set%prt(i)%flv%get_pdg () == pdg) then equals = nearly_equal (particle_set%prt(i)%p%p, momentum%p, & abs_smallness, rel_smallness) if (all (equals)) then idx = i return end if end if end do end function particle_set_find_particle @ %def particle_set_find_particle <>= procedure :: reverse_find_particle => particle_set_reverse_find_particle <>= pure function particle_set_reverse_find_particle & (particle_set, pdg, momentum, abs_smallness, rel_smallness) result (idx) integer :: idx class(particle_set_t), intent(in) :: particle_set integer, intent(in) :: pdg type(vector4_t), intent(in) :: momentum real(default), intent(in), optional :: abs_smallness, rel_smallness integer :: i idx = 0 do i = size (particle_set%prt), 1, -1 if (particle_set%prt(i)%flv%get_pdg () == pdg) then if (all (nearly_equal (particle_set%prt(i)%p%p, momentum%p, & abs_smallness, rel_smallness))) then idx = i return end if end if end do end function particle_set_reverse_find_particle @ %def particle_set_reverse_find_particle @ This connects broken links of the form $\text{something} \to i \to \text{none or} j$ and $\text{none} \to j \to \text{something or none}$ where the particles $i$ and $j$ are \emph{identical}. It also works if $i \to j$, directly, and thus removes duplicates. We are removing $j$ and connect the possible daughters to $i$. <>= procedure :: remove_duplicates => particle_set_remove_duplicates <>= subroutine particle_set_remove_duplicates (particle_set, smallness) class(particle_set_t), intent(inout) :: particle_set real(default), intent(in) :: smallness integer :: n_removals integer, dimension(particle_set%n_tot) :: to_remove type(particle_t), dimension(:), allocatable :: particles type(vector4_t) :: p_i integer, dimension(:), allocatable :: map to_remove = 0 call find_duplicates () n_removals = count (to_remove > 0) if (n_removals > 0) then call strip_duplicates (particles) call particle_set%replace (particles) end if contains <> end subroutine particle_set_remove_duplicates @ %def particle_set_remove_duplicates @ This does not catch all cases. Missing are splittings of the type $i \to \text{something and} j$. <>= subroutine find_duplicates () integer :: pdg_i, child_i, i, j OUTER: do i = 1, particle_set%n_tot if (particle_set%prt(i)%status == PRT_OUTGOING .or. & particle_set%prt(i)%status == PRT_VIRTUAL .or. & particle_set%prt(i)%status == PRT_RESONANT) then if (allocated (particle_set%prt(i)%child)) then if (size (particle_set%prt(i)%child) > 1) cycle OUTER if (size (particle_set%prt(i)%child) == 1) then child_i = particle_set%prt(i)%child(1) else child_i = 0 end if else child_i = 0 end if pdg_i = particle_set%prt(i)%flv%get_pdg () p_i = particle_set%prt(i)%p do j = i + 1, particle_set%n_tot if (pdg_i == particle_set%prt(j)%flv%get_pdg ()) then if (all (nearly_equal (particle_set%prt(j)%p%p, p_i%p, & abs_smallness = smallness, & rel_smallness = 1E4_default * smallness))) then if (child_i == 0 .or. j == child_i) then to_remove(j) = i if (debug_on) call msg_debug2 (D_PARTICLES, & "Particles: Will remove duplicate of i", i) if (debug_on) call msg_debug2 (D_PARTICLES, & "Particles: j", j) end if cycle OUTER end if end if end do end if end do OUTER end subroutine find_duplicates @ <>= recursive function get_alive_index (try) result (alive) integer :: alive integer :: try if (map(try) > 0) then alive = map(try) else alive = get_alive_index (to_remove(try)) end if end function get_alive_index @ <>= subroutine strip_duplicates (particles) type(particle_t), dimension(:), allocatable, intent(out) :: particles integer :: kept, removed, i, j integer, dimension(:), allocatable :: old_children logical, dimension(:), allocatable :: parent_set if (debug_on) call msg_debug (D_PARTICLES, "Particles: Removing duplicates") if (debug_on) call msg_debug (D_PARTICLES, "Particles: n_removals", n_removals) if (debug2_active (D_PARTICLES)) then call msg_debug2 (D_PARTICLES, "Particles: Given set before removing:") call particle_set%write (summary=.true., compressed=.true.) end if allocate (particles (particle_set%n_tot - n_removals)) allocate (map (particle_set%n_tot)) allocate (parent_set (particle_set%n_tot)) parent_set = .false. map = 0 j = 0 do i = 1, particle_set%n_tot if (to_remove(i) == 0) then j = j + 1 map(i) = j call particles(j)%init (particle_set%prt(i)) end if end do do i = 1, particle_set%n_tot if (map(i) /= 0) then if (.not. parent_set(map(i))) then call particles(map(i))%set_parents & (map (particle_set%prt(i)%get_parents ())) end if call particles(map(i))%set_children & (map (particle_set%prt(i)%get_children ())) else removed = i kept = to_remove(i) if (particle_set%prt(removed)%has_children ()) then old_children = particle_set%prt(removed)%get_children () do j = 1, size (old_children) if (map(old_children(j)) > 0) then call particles(map(old_children(j)))%set_parents & ([get_alive_index (kept)]) parent_set(map(old_children(j))) = .true. call particles(get_alive_index (kept))%add_child & (map(old_children(j))) end if end do particles(get_alive_index (kept))%status = PRT_RESONANT else particles(get_alive_index (kept))%status = PRT_OUTGOING end if end if end do end subroutine strip_duplicates @ Given a subevent, reset status codes. If the new status is beam, incoming, or outgoing, we also make sure that the stored $p^2$ value is equal to the on-shell mass squared. <>= procedure :: reset_status => particle_set_reset_status <>= subroutine particle_set_reset_status (particle_set, index, status) class(particle_set_t), intent(inout) :: particle_set integer, dimension(:), intent(in) :: index integer, intent(in) :: status integer :: i if (allocated (particle_set%prt)) then do i = 1, size (index) call particle_set%prt(index(i))%reset_status (status) end do end if particle_set%n_beam = & count (particle_set%prt%get_status () == PRT_BEAM) particle_set%n_in = & count (particle_set%prt%get_status () == PRT_INCOMING) particle_set%n_out = & count (particle_set%prt%get_status () == PRT_OUTGOING) particle_set%n_vir = particle_set%n_tot & - particle_set%n_beam - particle_set%n_in - particle_set%n_out end subroutine particle_set_reset_status @ %def particle_set_reset_status @ Reduce a particle set to the essential entries. The entries kept are those with status [[INCOMING]], [[OUTGOING]] or [[RESONANT]]. [[BEAM]] is kept if [[keep_beams]] is true. Other entries are skipped. The correlated state matrix, if any, is also ignored. <>= procedure :: reduce => particle_set_reduce <>= subroutine particle_set_reduce (pset_in, pset_out, keep_beams) class(particle_set_t), intent(in) :: pset_in type(particle_set_t), intent(out) :: pset_out logical, intent(in), optional :: keep_beams integer, dimension(:), allocatable :: status, map integer :: i, j logical :: kb kb = .false.; if (present (keep_beams)) kb = keep_beams allocate (status (pset_in%n_tot)) pset_out%factorization_mode = pset_in%factorization_mode status = pset_in%prt%get_status () if (kb) pset_out%n_beam = count (status == PRT_BEAM) pset_out%n_in = count (status == PRT_INCOMING) pset_out%n_vir = count (status == PRT_RESONANT) pset_out%n_out = count (status == PRT_OUTGOING) pset_out%n_tot = & pset_out%n_beam + pset_out%n_in + pset_out%n_vir + pset_out%n_out allocate (pset_out%prt (pset_out%n_tot)) allocate (map (pset_in%n_tot)) map = 0 j = 0 if (kb) call copy_particles (PRT_BEAM) call copy_particles (PRT_INCOMING) call copy_particles (PRT_RESONANT) call copy_particles (PRT_OUTGOING) do i = 1, pset_in%n_tot if (map(i) == 0) cycle call pset_out%prt(map(i))%set_parents & (pset_in%get_real_parents (i, kb)) call pset_out%prt(map(i))%set_parents & (map (pset_out%prt(map(i))%parent)) call pset_out%prt(map(i))%set_children & (pset_in%get_real_children (i, kb)) call pset_out%prt(map(i))%set_children & (map (pset_out%prt(map(i))%child)) end do contains subroutine copy_particles (stat) integer, intent(in) :: stat integer :: i do i = 1, pset_in%n_tot if (status(i) == stat) then j = j + 1 map(i) = j call particle_init_particle (pset_out%prt(j), pset_in%prt(i)) end if end do end subroutine copy_particles end subroutine particle_set_reduce @ %def particles_set_reduce @ Remove the beam particles and beam remnants from the particle set if the keep beams flag is false. If keep beams is not given, the beam particles and the beam remnants are removed. The correlated state matrix, if any, is also ignored. <>= procedure :: filter_particles => particle_set_filter_particles <>= subroutine particle_set_filter_particles & (pset_in, pset_out, keep_beams, real_parents, keep_virtuals) class(particle_set_t), intent(in) :: pset_in type(particle_set_t), intent(out) :: pset_out logical, intent(in), optional :: keep_beams, real_parents, keep_virtuals integer, dimension(:), allocatable :: status, map logical, dimension(:), allocatable :: filter integer :: i, j logical :: kb, rp, kv kb = .false.; if (present (keep_beams)) kb = keep_beams rp = .false.; if (present (real_parents)) rp = real_parents kv = .true.; if (present (keep_virtuals)) kv = keep_virtuals if (debug_on) call msg_debug (D_PARTICLES, "filter_particles") if (debug2_active (D_PARTICLES)) then print *, 'keep_beams = ', kb print *, 'real_parents = ', rp print *, 'keep_virtuals = ', kv print *, '>>> pset_in : ' call pset_in%write(compressed=.true.) end if call count_and_allocate() map = 0 j = 0 filter = .false. if (.not. kb) filter = status == PRT_BEAM .or. status == PRT_BEAM_REMNANT if (.not. kv) filter = filter .or. status == PRT_VIRTUAL call copy_particles () do i = 1, pset_in%n_tot if (map(i) == 0) cycle if (rp) then call pset_out%prt(map(i))%set_parents & (map (pset_in%get_real_parents (i, kb))) call pset_out%prt(map(i))%set_children & (map (pset_in%get_real_children (i, kb))) else call pset_out%prt(map(i))%set_parents & (map (pset_in%prt(i)%get_parents ())) call pset_out%prt(map(i))%set_children & (map (pset_in%prt(i)%get_children ())) end if end do if (debug2_active (D_PARTICLES)) then print *, '>>> pset_out : ' call pset_out%write(compressed=.true.) end if contains <> end subroutine particle_set_filter_particles @ %def particles_set_filter_particles <>= subroutine copy_particles () integer :: i do i = 1, pset_in%n_tot if (.not. filter(i)) then j = j + 1 map(i) = j call particle_init_particle (pset_out%prt(j), pset_in%prt(i)) end if end do end subroutine copy_particles <>= subroutine count_and_allocate allocate (status (pset_in%n_tot)) status = particle_get_status (pset_in%prt) if (kb) pset_out%n_beam = count (status == PRT_BEAM) pset_out%n_in = count (status == PRT_INCOMING) if (kb .and. kv) then pset_out%n_vir = count (status == PRT_VIRTUAL) + & count (status == PRT_RESONANT) + & count (status == PRT_BEAM_REMNANT) else if (kb .and. .not. kv) then pset_out%n_vir = count (status == PRT_RESONANT) + & count (status == PRT_BEAM_REMNANT) else if (.not. kb .and. kv) then pset_out%n_vir = count (status == PRT_VIRTUAL) + & count (status == PRT_RESONANT) else pset_out%n_vir = count (status == PRT_RESONANT) end if pset_out%n_out = count (status == PRT_OUTGOING) pset_out%n_tot = & pset_out%n_beam + pset_out%n_in + pset_out%n_vir + pset_out%n_out allocate (pset_out%prt (pset_out%n_tot)) allocate (map (pset_in%n_tot)) allocate (filter (pset_in%n_tot)) end subroutine count_and_allocate @ Transform a particle set into HEPEVT-compatible form. In this form, for each particle, the parents and the children are contiguous in the particle array. Usually, this requires to clone some particles. We do not know in advance how many particles the canonical form will have. To be on the safe side, allocate four times the original size. <>= procedure :: to_hepevt_form => particle_set_to_hepevt_form <>= subroutine particle_set_to_hepevt_form (pset_in, pset_out) class(particle_set_t), intent(in) :: pset_in type(particle_set_t), intent(out) :: pset_out type :: particle_entry_t integer :: src = 0 integer :: status = 0 integer :: orig = 0 integer :: copy = 0 end type particle_entry_t type(particle_entry_t), dimension(:), allocatable :: prt integer, dimension(:), allocatable :: map1, map2 integer, dimension(:), allocatable :: parent, child integer :: n_tot, n_parents, n_children, i, j, c, n n_tot = pset_in%n_tot allocate (prt (4 * n_tot)) allocate (map1(4 * n_tot)) allocate (map2(4 * n_tot)) map1 = 0 map2 = 0 allocate (child (n_tot)) allocate (parent (n_tot)) n = 0 do i = 1, n_tot if (pset_in%prt(i)%get_n_parents () == 0) then call append (i) end if end do do i = 1, n_tot n_children = pset_in%prt(i)%get_n_children () if (n_children > 0) then child(1:n_children) = pset_in%prt(i)%get_children () c = child(1) if (map1(c) == 0) then n_parents = pset_in%prt(c)%get_n_parents () if (n_parents > 1) then parent(1:n_parents) = pset_in%prt(c)%get_parents () if (i == parent(1) .and. & any( [(map1(i)+j-1, j=1,n_parents)] /= & map1(parent(1:n_parents)))) then do j = 1, n_parents call append (parent(j)) end do end if else if (map1(i) == 0) then call append (i) end if do j = 1, n_children call append (child(j)) end do end if else if (map1(i) == 0) then call append (i) end if end do do i = n, 1, -1 if (prt(i)%status /= PRT_OUTGOING) then do j = 1, i-1 if (prt(j)%status == PRT_OUTGOING) then call append(prt(j)%src) end if end do exit end if end do pset_out%n_beam = count (prt(1:n)%status == PRT_BEAM) pset_out%n_in = count (prt(1:n)%status == PRT_INCOMING) pset_out%n_vir = count (prt(1:n)%status == PRT_RESONANT) pset_out%n_out = count (prt(1:n)%status == PRT_OUTGOING) pset_out%n_tot = n allocate (pset_out%prt (n)) do i = 1, n call particle_init_particle (pset_out%prt(i), pset_in%prt(prt(i)%src)) call pset_out%prt(i)%reset_status (prt(i)%status) if (prt(i)%orig == 0) then call pset_out%prt(i)%set_parents & (map2 (pset_in%prt(prt(i)%src)%get_parents ())) else call pset_out%prt(i)%set_parents ([ prt(i)%orig ]) end if if (prt(i)%copy == 0) then call pset_out%prt(i)%set_children & (map1 (pset_in%prt(prt(i)%src)%get_children ())) else call pset_out%prt(i)%set_children ([ prt(i)%copy ]) end if end do contains subroutine append (i) integer, intent(in) :: i n = n + 1 if (n > size (prt)) & call msg_bug ("Particle set transform to HEPEVT: insufficient space") prt(n)%src = i prt(n)%status = pset_in%prt(i)%get_status () if (map1(i) == 0) then map1(i) = n else prt(map2(i))%status = PRT_VIRTUAL prt(map2(i))%copy = n prt(n)%orig = map2(i) end if map2(i) = n end subroutine append end subroutine particle_set_to_hepevt_form @ %def particle_set_to_hepevt_form @ This procedure aims at reconstructing the momenta of an interaction, given a particle set. The main task is to find the original hard process, by following the event history. In-state: take those particles which are flagged as [[PRT_INCOMING]] Out-state: try to be smart by checking the immediate children of the incoming particles. If the [[state_flv]] table is present, check any [[PRT_RESONANT]] particles that we get this way, whether they are potential out-particles by their PDG codes. If not, replace them by their children, recursively. (Resonances may have been inserted by the corresponding event transform.) [WK 21-02-16] Revised the algorithm for the case [[recover_beams]] = false, i.e., the particle set contains beams and radiation. This does not mean that the particle set contains the complete radiation history. To make up for missing information, we follow the history in the interaction one step backwards and do a bit of guesswork to match this to the possibly incomplete history in the particle set. [The current implementation allows only for one stage of radiation; this could be improved by iterating the procedure!] [WK 21-03-21] Amended the [[find_hard_process_in_pset]] algorithm as follows: Occasionally, PYTHIA adds a stepchild to the decay of a resonance that WHIZARD has inserted, a shower object that also has other particles in the event as parents. Such objects must not enter the hard-process record. Therefore, resonance child particle objects are ignored if they have more than one parent. <>= procedure :: fill_interaction => particle_set_fill_interaction <>= subroutine particle_set_fill_interaction & (pset, int, n_in, recover_beams, check_match, state_flv, success) class(particle_set_t), intent(in) :: pset type(interaction_t), intent(inout) :: int integer, intent(in) :: n_in logical, intent(in), optional :: recover_beams, check_match type(state_flv_content_t), intent(in), optional :: state_flv logical, intent(out), optional :: success integer, dimension(:), allocatable :: map, pdg integer, dimension(:), allocatable :: i_in, i_out, p_in, p_out logical, dimension(:), allocatable :: i_set integer :: n_out, i, p logical :: r_beams, check r_beams = .false.; if (present (recover_beams)) r_beams = recover_beams check = .true.; if (present (check_match)) check = check_match if (check) then call find_hard_process_in_int (i_in, i_out) call find_hard_process_in_pset (p_in, p_out, state_flv, success) if (present (success)) then if (size (i_in) /= n_in) success = .false. if (size (p_in) /= n_in) success = .false. if (size (p_out) /= n_out) success = .false. if (.not. success) return else if (size (i_in) /= n_in) call err_int_n_in if (size (p_in) /= n_in) call err_pset_n_in if (size (p_out) /= n_out) call err_pset_n_out end if call extract_hard_process_from_pset (pdg) call determine_map_for_hard_process (map, state_flv, success) if (present (success)) then if (.not. success) return end if call map_handle_duplicates (map) if (.not. r_beams) then call determine_map_for_beams (map) call map_handle_duplicates (map) call determine_map_for_radiation (map, i_in, p_in) call map_handle_duplicates (map) end if else allocate (map (int%get_n_tot ())) map = [(i, i = 1, size (map))] r_beams = .false. end if allocate (i_set (int%get_n_tot ()), source = .false.) do p = 1, size (map) if (map(p) /= 0) then if (.not. i_set(map(p))) then call int%set_momentum (pset%prt(p)%get_momentum (), map(p)) i_set(map(p)) = .true. end if end if end do if (r_beams) then do i = 1, n_in call reconstruct_beam_and_radiation (i, i_set) end do else do i = int%get_n_tot (), 1, -1 if (.not. i_set(i)) call reconstruct_missing (i, i_set) end do end if if (any (.not. i_set)) then if (present (success)) then success = .false. else call err_map end if end if contains subroutine find_hard_process_in_int (i_in, i_out) integer, dimension(:), allocatable, intent(out) :: i_in, i_out integer :: n_in_i integer :: i i = int%get_n_tot () - n_in_i = interaction_get_n_parents (int, i) + n_in_i = int%get_n_parents (i) if (n_in_i /= n_in) call err_int_n_in allocate (i_in (n_in)) - i_in = interaction_get_parents (int, i) + i_in = int%get_parents (i) i = i_in(1) - n_out = interaction_get_n_children (int, i) + n_out = int%get_n_children (i) allocate (i_out (n_out)) - i_out = interaction_get_children (int, i) + i_out = int%get_children (i) end subroutine find_hard_process_in_int subroutine find_hard_process_in_pset (p_in, p_out, state_flv, success) integer, dimension(:), allocatable, intent(out) :: p_in, p_out type(state_flv_content_t), intent(in), optional :: state_flv logical, intent(out), optional :: success integer, dimension(:), allocatable :: p_status, p_idx, p_child integer :: n_out_p, n_child, n_shift integer :: i, k, c allocate (p_status (pset%n_tot), p_idx (pset%n_tot), p_child (pset%n_tot)) p_status = pset%prt%get_status () p_idx = [(i, i = 1, pset%n_tot)] allocate (p_in (n_in)) p_in = pack (p_idx, p_status == PRT_INCOMING) if (size (p_in) == 0) call err_pset_hard i = p_in(1) allocate (p_out (n_out)) - n_out_p = particle_get_n_children (pset%prt(i)) + n_out_p = pset%prt(i)%get_n_children () p_out(1:n_out_p) = particle_get_children (pset%prt(i)) do k = 1, size (p_out) i = p_out(k) if (present (state_flv)) then do while (pset%prt(i)%get_status () == PRT_RESONANT) if (state_flv%contains (pset%prt(i)%get_pdg ())) exit - n_child = particle_get_n_children (pset%prt(i)) + n_child = pset%prt(i)%get_n_children () p_child(1:n_child) = particle_get_children (pset%prt(i)) n_shift = -1 do c = 1, n_child - if (particle_get_n_parents (pset%prt(p_child(c))) == 1) then + if (pset%prt(p_child(c))%get_n_parents () == 1) then n_shift = n_shift + 1 else p_child(c) = 0 end if end do if (n_shift < 0) then if (present (success)) then success = .false. return else call err_mismatch end if end if p_out(k+1+n_shift:n_out_p+n_shift) = p_out(k+1:n_out_p) n_out_p = n_out_p + n_shift do c = 1, n_child if (p_child(c) /= 0) then p_out(k+c-1) = p_child(c) end if end do i = p_out(k) end do end if end do if (present (success)) success = .true. end subroutine find_hard_process_in_pset subroutine extract_hard_process_from_pset (pdg) integer, dimension(:), allocatable, intent(out) :: pdg integer, dimension(:), allocatable :: pdg_p logical, dimension(:), allocatable :: mask_p integer :: i allocate (pdg_p (pset%n_tot)) pdg_p = pset%prt%get_pdg () allocate (mask_p (pset%n_tot), source = .false.) mask_p (p_in) = .true. mask_p (p_out) = .true. allocate (pdg (n_in + n_out)) pdg = pack (pdg_p, mask_p) end subroutine extract_hard_process_from_pset subroutine determine_map_for_hard_process (map, state_flv, success) integer, dimension(:), allocatable, intent(out) :: map type(state_flv_content_t), intent(in), optional :: state_flv logical, intent(out), optional :: success integer, dimension(:), allocatable :: pdg_i, map_i integer :: n_tot logical, dimension(:), allocatable :: mask_i, mask_p logical :: match n_tot = int%get_n_tot () if (present (state_flv)) then allocate (mask_i (n_tot), source = .false.) mask_i (i_in) = .true. mask_i (i_out) = .true. allocate (pdg_i (n_tot), map_i (n_tot)) pdg_i = unpack (pdg, mask_i, 0) call state_flv%match (pdg_i, match, map_i) if (present (success)) then success = match end if if (.not. match) then if (present (success)) then return else call err_mismatch end if end if allocate (mask_p (pset%n_tot), source = .false.) mask_p (p_in) = .true. mask_p (p_out) = .true. allocate (map (size (mask_p)), & source = unpack (pack (map_i, mask_i), mask_p, 0)) else allocate (map (n_tot), source = 0) map(p_in) = i_in map(p_out) = i_out end if end subroutine determine_map_for_hard_process subroutine map_handle_duplicates (map) integer, dimension(:), intent(inout) :: map integer, dimension(1) :: p_parent, p_child integer :: p do p = 1, pset%n_tot if (map(p) == 0) then if (pset%prt(p)%get_n_parents () == 1) then p_parent = pset%prt(p)%get_parents () if (map(p_parent(1)) /= 0) then if (pset%prt(p_parent(1))%get_n_children () == 1) then map(p) = map(p_parent(1)) end if end if end if end if end do do p = pset%n_tot, 1, -1 if (map(p) == 0) then if (pset%prt(p)%get_n_children () == 1) then p_child = pset%prt(p)%get_children () if (map(p_child(1)) /= 0) then if (pset%prt(p_child(1))%get_n_parents () == 1) then map(p) = map(p_child(1)) end if end if end if end if end do end subroutine map_handle_duplicates subroutine determine_map_for_beams (map) integer, dimension(:), intent(inout) :: map select case (n_in) case (1); map(1) = 1 case (2); map(1:2) = [1,2] end select end subroutine determine_map_for_beams subroutine determine_map_for_radiation (map, i_in, p_in) integer, dimension(:), intent(inout) :: map integer, dimension(:), intent(in) :: i_in integer, dimension(:), intent(in) :: p_in integer, dimension(:), allocatable :: i_cur, p_cur integer, dimension(:), allocatable :: i_par, p_par, i_rad, p_rad integer :: i, p integer :: b, r i_cur = i_in p_cur = p_in do b = 1, n_in i = i_cur(b) p = p_cur(b) - i_par = interaction_get_parents (int, i) + i_par = int%get_parents (i) p_par = pset%prt(p)%get_parents () if (size (i_par) == 0 .or. size (p_par) == 0) cycle if (size (p_par) == 1) then if (pset%prt(p_par(1))%get_n_children () == 1) then p_par = pset%prt(p_par(1))%get_parents () ! copy of entry end if end if - i_rad = interaction_get_children (int, i_par(1)) + i_rad = int%get_children (i_par(1)) p_rad = pset%prt(p_par(1))%get_children () do r = 1, size (i_rad) if (any (map == i_rad(r))) i_rad(r) = 0 end do i_rad = pack (i_rad, i_rad /= 0) do r = 1, size (p_rad) if (map(p_rad(r)) /= 0) p_rad(r) = 0 end do p_rad = pack (p_rad, p_rad /= 0) do r = 1, min (size (i_rad), size (p_rad)) map(p_rad(r)) = i_rad(r) end do end do do b = 1, min (size (p_par), size (i_par)) if (map(p_par(b)) == 0 .and. all (map /= i_par(b))) then map(p_par(b)) = i_par(b) end if end do end subroutine determine_map_for_radiation subroutine reconstruct_beam_and_radiation (k, i_set) integer, intent(in) :: k logical, dimension(:), intent(inout) :: i_set integer :: k_src, k_pre, k_in, k_rad type(interaction_t), pointer :: int_src integer, dimension(2) :: i_child logical, dimension(2) :: is_final integer :: i call int%find_source (k, int_src, k_src) k_pre = 0 k_in = k do while (.not. i_set (k_in)) if (k_pre == 0) then call int%set_momentum (int_src%get_momentum (k_src), k_in) else call int%set_momentum (int%get_momentum (k_pre), k_in) end if i_set(k_in) = .true. if (n_in == 2) then k_pre = k_in - i_child = interaction_get_children (int, k_pre) + i_child = int%get_children (k_pre) do i = 1, 2 - is_final(i) = interaction_get_n_children (int, i_child(i)) == 0 + is_final(i) = int%get_n_children (i_child(i)) == 0 end do if (all (.not. is_final)) then k_in = i_child(k); k_rad = 0 else if (is_final(2)) then k_in = i_child(1); k_rad = i_child(2) else if (is_final(1)) then k_in = i_child(2); k_rad = i_child(1) else call err_beams end if if (k_rad /= 0) then if (i_set (k_in)) then call int%set_momentum & (int%get_momentum (k) - int%get_momentum (k_in), k_rad) i_set(k_rad) = .true. else call err_beams_norad end if end if end if end do end subroutine reconstruct_beam_and_radiation subroutine reconstruct_missing (i, i_set) integer, intent(in) :: i logical, dimension(:), intent(inout) :: i_set integer, dimension(:), allocatable :: i_child, i_parent, i_sibling integer :: s - i_child = interaction_get_children (int, i) - i_parent = interaction_get_parents (int, i) + i_child = int%get_children (i) + i_parent = int%get_parents (i) if (size (i_child) > 0 .and. all (i_set(i_child))) then call int%set_momentum (sum (int%get_momenta (i_child)), i) else if (size (i_parent) > 0 .and. all (i_set(i_parent))) then - i_sibling = interaction_get_children (int, i_parent(1)) + i_sibling = int%get_children (i_parent(1)) call int%set_momentum (sum (int%get_momenta (i_parent)), i) do s = 1, size (i_sibling) if (i_sibling(s) == i) cycle if (i_set(i_sibling(s))) then call int%set_momentum (int%get_momentum (i) & - int%get_momentum (i_sibling(s)), i) else call err_beams_norad end if end do else call err_beams_norad end if i_set(i) = .true. end subroutine reconstruct_missing subroutine err_pset_hard call msg_fatal ("Reading particle set: no particles marked as incoming") end subroutine err_pset_hard subroutine err_int_n_in integer :: n if (allocated (i_in)) then n = size (i_in) else n = 0 end if write (msg_buffer, "(A,I0,A,I0)") & "Filling hard process from particle set: expect ", n_in, & " incoming particle(s), found ", n call msg_bug end subroutine err_int_n_in subroutine err_pset_n_in write (msg_buffer, "(A,I0,A,I0)") & "Reading hard-process particle set: should contain ", n_in, & " incoming particle(s), found ", size (p_in) call msg_fatal end subroutine err_pset_n_in subroutine err_pset_n_out write (msg_buffer, "(A,I0,A,I0)") & "Reading hard-process particle set: should contain ", n_out, & " outgoing particle(s), found ", size (p_out) call msg_fatal end subroutine err_pset_n_out subroutine err_mismatch call pset%write () call state_flv%write () call msg_fatal ("Reading particle set: Flavor combination " & // "does not match requested process") end subroutine err_mismatch subroutine err_map call pset%write () call int%basic_write () call msg_fatal ("Reading hard-process particle set: " & // "Incomplete mapping from particle set to interaction") end subroutine err_map subroutine err_beams call pset%write () call int%basic_write () call msg_fatal ("Reading particle set: Beam structure " & // "does not match requested process") end subroutine err_beams subroutine err_beams_norad call pset%write () call int%basic_write () call msg_fatal ("Reading particle set: Beam structure " & // "cannot be reconstructed for this configuration") end subroutine err_beams_norad subroutine err_radiation call int%basic_write () call msg_bug ("Reading particle set: Interaction " & // "contains inconsistent radiation pattern.") end subroutine err_radiation end subroutine particle_set_fill_interaction @ %def particle_set_fill_interaction @ This procedure reconstructs an array of vertex indices from the parent-child information in the particle entries, according to the HepMC scheme. For each particle, we determine which vertex it comes from and which vertex it goes to. We return the two arrays and the maximum vertex index. For each particle in the list, we first check its parents. If for any parent the vertex where it goes to is already known, this vertex index is assigned as the current 'from' vertex. Otherwise, a new index is created, assigned as the current 'from' vertex, and as the 'to' vertex for all parents. Then, the analogous procedure is done for the children. Furthermore, we assign to each vertex the vertex position from the parent(s). We check that these vertex positions coincide, and if not return a null vector. <>= procedure :: assign_vertices => particle_set_assign_vertices <>= subroutine particle_set_assign_vertices & (particle_set, v_from, v_to, n_vertices) class(particle_set_t), intent(in) :: particle_set integer, dimension(:), intent(out) :: v_from, v_to integer, intent(out) :: n_vertices integer, dimension(:), allocatable :: parent, child integer :: n_parents, n_children, vf, vt integer :: i, j, v v_from = 0 v_to = 0 vf = 0 vt = 0 do i = 1, particle_set%n_tot n_parents = particle_set%prt(i)%get_n_parents () if (n_parents /= 0) then allocate (parent (n_parents)) parent = particle_set%prt(i)%get_parents () SCAN_PARENTS: do j = 1, size (parent) v = v_to(parent(j)) if (v /= 0) then v_from(i) = v; exit SCAN_PARENTS end if end do SCAN_PARENTS if (v_from(i) == 0) then vf = vf + 1; v_from(i) = vf v_to(parent) = vf end if deallocate (parent) end if n_children = particle_set%prt(i)%get_n_children () if (n_children /= 0) then allocate (child (n_children)) child = particle_set%prt(i)%get_children () SCAN_CHILDREN: do j = 1, size (child) v = v_from(child(j)) if (v /= 0) then v_to(i) = v; exit SCAN_CHILDREN end if end do SCAN_CHILDREN if (v_to(i) == 0) then vt = vt + 1; v_to(i) = vt v_from(child) = vt end if deallocate (child) end if end do n_vertices = max (vf, vt) end subroutine particle_set_assign_vertices @ %def particle_set_assign_vertices @ \subsection{Expression interface} This converts a [[particle_set]] object as defined here to a more concise [[subevt]] object that can be used as the event root of an expression. In particular, the latter lacks virtual particles, spin correlations and parent-child relations. We keep beam particles, incoming partons, and outgoing partons. Furthermore, we keep radiated particles (a.k.a.\ beam remnants) if they have no children in the current particle set, and mark them as outgoing particles. If [[colorize]] is set and true, mark all particles in the subevent as colorized, and set color/anticolor flow indices where they are defined. Colorless particles do not get indices but are still marked as colorized, for consistency. <>= procedure :: to_subevt => particle_set_to_subevt <>= subroutine particle_set_to_subevt (particle_set, subevt, colorize) class(particle_set_t), intent(in) :: particle_set type(subevt_t), intent(out) :: subevt logical, intent(in), optional :: colorize integer :: n_tot, n_beam, n_in, n_out, n_rad integer :: i, k, n_active integer, dimension(2) :: hel logical :: keep n_tot = particle_set_get_n_tot (particle_set) n_beam = particle_set_get_n_beam (particle_set) n_in = particle_set_get_n_in (particle_set) n_out = particle_set_get_n_out (particle_set) n_rad = particle_set_get_n_remnants (particle_set) call subevt_init (subevt, n_beam + n_rad + n_in + n_out) k = 0 do i = 1, n_tot associate (prt => particle_set%prt(i)) keep = .false. select case (particle_get_status (prt)) case (PRT_BEAM) k = k + 1 call subevt%set_beam (k, & particle_get_pdg (prt), & particle_get_momentum (prt), & particle_get_p2 (prt)) keep = .true. case (PRT_INCOMING) k = k + 1 call subevt%set_incoming (k, & particle_get_pdg (prt), & particle_get_momentum (prt), & particle_get_p2 (prt)) keep = .true. case (PRT_OUTGOING) k = k + 1 call subevt%set_outgoing (k, & particle_get_pdg (prt), & particle_get_momentum (prt), & particle_get_p2 (prt)) keep = .true. case (PRT_BEAM_REMNANT) - if (particle_get_n_children (prt) == 0) then + if (prt%get_n_children () == 0) then k = k + 1 call subevt%set_outgoing (k, & particle_get_pdg (prt), & particle_get_momentum (prt), & particle_get_p2 (prt)) keep = .true. end if end select if (keep) then if (prt%polarization == PRT_DEFINITE_HELICITY) then if (prt%hel%is_diagonal ()) then hel = prt%hel%to_pair () call subevt_polarize (subevt, k, hel(1)) end if end if end if if (present (colorize)) then if (colorize) then call subevt_colorize & (subevt, i, prt%col%get_col (), prt%col%get_acl ()) end if end if end associate n_active = k end do call subevt%reset (n_active) end subroutine particle_set_to_subevt @ %def particle_set_to_subevt @ This replaces the [[particle\_set\%prt array]] with a given array of particles <>= procedure :: replace => particle_set_replace <>= subroutine particle_set_replace (particle_set, newprt) class(particle_set_t), intent(inout) :: particle_set type(particle_t), intent(in), dimension(:), allocatable :: newprt if (allocated (particle_set%prt)) deallocate (particle_set%prt) allocate (particle_set%prt(size (newprt))) particle_set%prt = newprt particle_set%n_tot = size (newprt) particle_set%n_beam = count (particle_get_status (newprt) == PRT_BEAM) particle_set%n_in = count (particle_get_status (newprt) == PRT_INCOMING) particle_set%n_out = count (particle_get_status (newprt) == PRT_OUTGOING) particle_set%n_vir = particle_set%n_tot & - particle_set%n_beam - particle_set%n_in - particle_set%n_out end subroutine particle_set_replace @ %def particle_set_replace @ This routines orders the outgoing particles into clusters of colorless particles and such of particles ordered corresponding to the indices of the color lines. All outgoing particles in the ordered set appear as child of the corresponding outgoing particle in the unordered set, including colored beam remnants. We always start continue via the anti-color line, such that color flows within each Lund string system is always continued from the anticolor of one particle to the identical color index of another particle. <>= procedure :: order_color_lines => particle_set_order_color_lines <>= subroutine particle_set_order_color_lines (pset_out, pset_in) class(particle_set_t), intent(inout) :: pset_out type(particle_set_t), intent(in) :: pset_in integer :: i, n, n_col_rem n_col_rem = 0 do i = 1, pset_in%n_tot if (pset_in%prt(i)%get_status () == PRT_BEAM_REMNANT .and. & any (pset_in%prt(i)%get_color () /= 0)) then n_col_rem = n_col_rem + 1 end if end do pset_out%n_beam = pset_in%n_beam pset_out%n_in = pset_in%n_in pset_out%n_vir = pset_in%n_vir + pset_in%n_out + n_col_rem pset_out%n_out = pset_in%n_out pset_out%n_tot = pset_in%n_tot + pset_in%n_out + n_col_rem pset_out%correlated_state = pset_in%correlated_state pset_out%factorization_mode = pset_in%factorization_mode allocate (pset_out%prt (pset_out%n_tot)) do i = 1, pset_in%n_tot call pset_out%prt(i)%init (pset_in%prt(i)) call pset_out%prt(i)%set_children (pset_in%prt(i)%child) call pset_out%prt(i)%set_parents (pset_in%prt(i)%parent) end do n = pset_in%n_tot do i = 1, pset_in%n_tot if (pset_out%prt(i)%get_status () == PRT_OUTGOING .and. & all (pset_out%prt(i)%get_color () == 0) .and. & .not. pset_out%prt(i)%has_children ()) then n = n + 1 call pset_out%prt(n)%init (pset_out%prt(i)) call pset_out%prt(i)%reset_status (PRT_VIRTUAL) call pset_out%prt(i)%add_child (n) call pset_out%prt(i)%set_parents ([i]) end if end do if (n_col_rem > 0) then do i = 1, n_col_rem end do end if end subroutine particle_set_order_color_lines @ %def particle_set_order_color_lines @ Eliminate numerical noise <>= public :: pacify <>= interface pacify module procedure pacify_particle module procedure pacify_particle_set end interface pacify <>= subroutine pacify_particle (prt) class(particle_t), intent(inout) :: prt real(default) :: e e = epsilon (1._default) * energy (prt%p) call pacify (prt%p, 10 * e) call pacify (prt%p2, 1e4 * e) end subroutine pacify_particle subroutine pacify_particle_set (pset) class(particle_set_t), intent(inout) :: pset integer :: i do i = 1, pset%n_tot call pacify (pset%prt(i)) end do end subroutine pacify_particle_set @ %def pacify @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[particles_ut.f90]]>>= <> module particles_ut use unit_tests use particles_uti <> <> contains <> end module particles_ut @ %def particles_ut @ <<[[particles_uti.f90]]>>= <> module particles_uti <> use io_units use numeric_utils use constants, only: one, tiny_07 use lorentz use flavors use colors use helicities use quantum_numbers use state_matrices use interactions use evaluators use model_data use subevents use particles <> <> contains <> <> end module particles_uti @ %def particles_ut @ API: driver for the unit tests below. <>= public :: particles_test <>= subroutine particles_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine particles_test @ %def particles_test @ Check the basic setup of the [[particle_set_t]] type: Set up a chain of production and decay and factorize the result into particles. The process is $d\bar d \to Z \to q\bar q$. <>= call test (particles_1, "particles_1", & "check particle_set routines", & u, results) <>= public :: particles_1 <>= subroutine particles_1 (u) use os_interface integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(3) :: flv type(color_t), dimension(3) :: col type(helicity_t), dimension(3) :: hel type(quantum_numbers_t), dimension(3) :: qn type(vector4_t), dimension(3) :: p type(interaction_t), target :: int1, int2 type(quantum_numbers_mask_t) :: qn_mask_conn type(evaluator_t), target :: eval type(interaction_t) :: int type(particle_set_t) :: particle_set1, particle_set2 type(particle_set_t) :: particle_set3, particle_set4 type(subevt_t) :: subevt logical :: ok integer :: unit, iostat write (u, "(A)") "* Test output: Particles" write (u, "(A)") "* Purpose: test particle_set routines" write (u, "(A)") write (u, "(A)") "* Reading model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Initializing production process" call int1%basic_init (2, 0, 1, set_relations=.true.) call flv%init ([1, -1, 23], model) call col%init_col_acl ([0, 0, 0], [0, 0, 0]) call hel(3)%init (1, 1) call qn%init (flv, col, hel) call int1%add_state (qn, value=(0.25_default, 0._default)) call hel(3)%init (1,-1) call qn%init (flv, col, hel) call int1%add_state (qn, value=(0._default, 0.25_default)) call hel(3)%init (-1, 1) call qn%init (flv, col, hel) call int1%add_state (qn, value=(0._default,-0.25_default)) call hel(3)%init (-1,-1) call qn%init (flv, col, hel) call int1%add_state (qn, value=(0.25_default, 0._default)) call hel(3)%init (0, 0) call qn%init (flv, col, hel) call int1%add_state (qn, value=(0.5_default, 0._default)) call int1%freeze () p(1) = vector4_moving (45._default, 45._default, 3) p(2) = vector4_moving (45._default,-45._default, 3) p(3) = p(1) + p(2) call int1%set_momenta (p) write (u, "(A)") write (u, "(A)") "* Setup decay process" call int2%basic_init (1, 0, 2, set_relations=.true.) call flv%init ([23, 1, -1], model) call col%init_col_acl ([0, 501, 0], [0, 0, 501]) call hel%init ([1, 1, 1], [1, 1, 1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(1._default, 0._default)) call hel%init ([1, 1, 1], [-1,-1,-1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(0._default, 0.1_default)) call hel%init ([-1,-1,-1], [1, 1, 1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(0._default,-0.1_default)) call hel%init ([-1,-1,-1], [-1,-1,-1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(1._default, 0._default)) call hel%init ([0, 1,-1], [0, 1,-1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(4._default, 0._default)) call hel%init ([0,-1, 1], [0, 1,-1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(2._default, 0._default)) call hel%init ([0, 1,-1], [0,-1, 1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(2._default, 0._default)) call hel%init ([0,-1, 1], [0,-1, 1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(4._default, 0._default)) call flv%init ([23, 2, -2], model) call hel%init ([0, 1,-1], [0, 1,-1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(0.5_default, 0._default)) call hel%init ([0,-1, 1], [0,-1, 1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(0.5_default, 0._default)) call int2%freeze () p(2) = vector4_moving (45._default, 45._default, 2) p(3) = vector4_moving (45._default,-45._default, 2) call int2%set_momenta (p) call int2%set_source_link (1, int1, 3) call int1%basic_write (u) call int2%basic_write (u) write (u, "(A)") write (u, "(A)") "* Concatenate production and decay" call eval%init_product (int1, int2, qn_mask_conn, & connections_are_resonant=.true.) call eval%receive_momenta () call eval%evaluate () call eval%write (u) write (u, "(A)") write (u, "(A)") "* Factorize as subevent (complete, polarized)" write (u, "(A)") int = eval%interaction_t call particle_set1%init & (ok, int, int, FM_FACTOR_HELICITY, & [0.2_default, 0.2_default], .false., .true.) call particle_set1%write (u) write (u, "(A)") write (u, "(A)") "* Factorize as subevent (in/out only, selected helicity)" write (u, "(A)") int = eval%interaction_t call particle_set2%init & (ok, int, int, FM_SELECT_HELICITY, & [0.9_default, 0.9_default], .false., .false.) call particle_set2%write (u) call particle_set2%final () write (u, "(A)") write (u, "(A)") "* Factorize as subevent (complete, selected helicity)" write (u, "(A)") int = eval%interaction_t call particle_set2%init & (ok, int, int, FM_SELECT_HELICITY, & [0.7_default, 0.7_default], .false., .true.) call particle_set2%write (u) write (u, "(A)") write (u, "(A)") & "* Factorize (complete, polarized, correlated); write and read again" write (u, "(A)") int = eval%interaction_t call particle_set3%init & (ok, int, int, FM_FACTOR_HELICITY, & [0.7_default, 0.7_default], .true., .true.) call particle_set3%write (u) unit = free_unit () open (unit, action="readwrite", form="unformatted", status="scratch") call particle_set3%write_raw (unit) rewind (unit) call particle_set4%read_raw (unit, iostat=iostat) call particle_set4%set_model (model) close (unit) write (u, "(A)") write (u, "(A)") "* Result from reading" write (u, "(A)") call particle_set4%write (u) write (u, "(A)") write (u, "(A)") "* Transform to a subevt object" write (u, "(A)") call particle_set4%to_subevt (subevt) call subevt%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call particle_set1%final () call particle_set2%final () call particle_set3%final () call particle_set4%final () call eval%final () call int1%final () call int2%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: particles_1" end subroutine particles_1 @ %def particles_1 @ Reconstruct a hard interaction from a particle set. <>= call test (particles_2, "particles_2", & "reconstruct hard interaction", & u, results) <>= public :: particles_2 <>= subroutine particles_2 (u) integer, intent(in) :: u type(interaction_t) :: int type(state_flv_content_t) :: state_flv type(particle_set_t) :: pset type(flavor_t), dimension(:), allocatable :: flv type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: i, j write (u, "(A)") "* Test output: Particles" write (u, "(A)") "* Purpose: reconstruct simple interaction" write (u, "(A)") write (u, "(A)") "* Set up a 2 -> 3 interaction" write (u, "(A)") " + incoming partons marked as virtual" write (u, "(A)") " + no quantum numbers" write (u, "(A)") call reset_interaction_counter () call int%basic_init (0, 2, 3) do i = 1, 2 do j = 3, 5 call int%relate (i, j) end do end do allocate (qn (5)) call int%add_state (qn) call int%freeze () call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Manually set up a flavor-content record" write (u, "(A)") call state_flv%init (1, & mask = [.false., .false., .true., .true., .true.]) call state_flv%set_entry (1, & pdg = [11, 12, 3, 4, 5], & map = [1, 2, 3, 4, 5]) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Manually create a matching particle set" write (u, "(A)") pset%n_beam = 0 pset%n_in = 2 pset%n_vir = 0 pset%n_out = 3 pset%n_tot = 5 allocate (pset%prt (pset%n_tot)) do i = 1, 2 call pset%prt(i)%reset_status (PRT_INCOMING) call pset%prt(i)%set_children ([3,4,5]) end do do i = 3, 5 call pset%prt(i)%reset_status (PRT_OUTGOING) call pset%prt(i)%set_parents ([1,2]) end do call pset%prt(1)%set_momentum (vector4_at_rest (1._default)) call pset%prt(2)%set_momentum (vector4_at_rest (2._default)) call pset%prt(3)%set_momentum (vector4_at_rest (5._default)) call pset%prt(4)%set_momentum (vector4_at_rest (4._default)) call pset%prt(5)%set_momentum (vector4_at_rest (3._default)) allocate (flv (5)) call flv%init ([11,12,5,4,3]) do i = 1, 5 call pset%prt(i)%set_flavor (flv(i)) end do call pset%write (u) write (u, "(A)") write (u, "(A)") "* Fill interaction from particle set" write (u, "(A)") call pset%fill_interaction (int, 2, state_flv=state_flv) call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call int%final () call pset%final () write (u, "(A)") write (u, "(A)") "* Test output end: particles_2" end subroutine particles_2 @ %def particles_2 @ Reconstruct an interaction with beam structure, e.g., a hadronic interaction, from a particle set. <>= call test (particles_3, "particles_3", & "reconstruct interaction with beam structure", & u, results) <>= public :: particles_3 <>= subroutine particles_3 (u) integer, intent(in) :: u type(interaction_t) :: int type(state_flv_content_t) :: state_flv type(particle_set_t) :: pset type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: i, j write (u, "(A)") "* Test output: Particles" write (u, "(A)") "* Purpose: reconstruct simple interaction" write (u, "(A)") write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation" write (u, "(A)") " + no quantum numbers" write (u, "(A)") call reset_interaction_counter () call int%basic_init (0, 6, 3) call int%relate (1, 3) call int%relate (1, 4) call int%relate (2, 5) call int%relate (2, 6) do i = 4, 6, 2 do j = 7, 9 call int%relate (i, j) end do end do allocate (qn (9)) call int%add_state (qn) call int%freeze () call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Manually set up a flavor-content record" write (u, "(A)") call state_flv%init (1, & mask = [.false., .false., .false., .false., .false., .false., & .true., .true., .true.]) call state_flv%set_entry (1, & pdg = [2011, 2012, 91, 11, 92, 12, 3, 4, 5], & map = [1, 2, 3, 4, 5, 6, 7, 8, 9]) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Manually create a matching particle set" write (u, "(A)") call create_test_particle_set_1 (pset) call pset%write (u) write (u, "(A)") write (u, "(A)") "* Fill interaction from particle set" write (u, "(A)") call pset%fill_interaction (int, 2, state_flv=state_flv) call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call int%final () call pset%final () write (u, "(A)") write (u, "(A)") "* Test output end: particles_3" end subroutine particles_3 @ %def particles_3 @ <>= subroutine create_test_particle_set_1 (pset) type(particle_set_t), intent(out) :: pset type(flavor_t), dimension(:), allocatable :: flv integer :: i pset%n_beam = 2 pset%n_in = 2 pset%n_vir = 2 pset%n_out = 3 pset%n_tot = 9 allocate (pset%prt (pset%n_tot)) call pset%prt(1)%reset_status (PRT_BEAM) call pset%prt(2)%reset_status (PRT_BEAM) call pset%prt(3)%reset_status (PRT_INCOMING) call pset%prt(4)%reset_status (PRT_INCOMING) call pset%prt(5)%reset_status (PRT_BEAM_REMNANT) call pset%prt(6)%reset_status (PRT_BEAM_REMNANT) call pset%prt(7)%reset_status (PRT_OUTGOING) call pset%prt(8)%reset_status (PRT_OUTGOING) call pset%prt(9)%reset_status (PRT_OUTGOING) call pset%prt(1)%set_children ([3,5]) call pset%prt(2)%set_children ([4,6]) call pset%prt(3)%set_children ([7,8,9]) call pset%prt(4)%set_children ([7,8,9]) call pset%prt(3)%set_parents ([1]) call pset%prt(4)%set_parents ([2]) call pset%prt(5)%set_parents ([1]) call pset%prt(6)%set_parents ([2]) call pset%prt(7)%set_parents ([3,4]) call pset%prt(8)%set_parents ([3,4]) call pset%prt(9)%set_parents ([3,4]) call pset%prt(1)%set_momentum (vector4_at_rest (1._default)) call pset%prt(2)%set_momentum (vector4_at_rest (2._default)) call pset%prt(3)%set_momentum (vector4_at_rest (4._default)) call pset%prt(4)%set_momentum (vector4_at_rest (6._default)) call pset%prt(5)%set_momentum (vector4_at_rest (3._default)) call pset%prt(6)%set_momentum (vector4_at_rest (5._default)) call pset%prt(7)%set_momentum (vector4_at_rest (7._default)) call pset%prt(8)%set_momentum (vector4_at_rest (8._default)) call pset%prt(9)%set_momentum (vector4_at_rest (9._default)) allocate (flv (9)) call flv%init ([2011, 2012, 11, 12, 91, 92, 3, 4, 5]) do i = 1, 9 call pset%prt(i)%set_flavor (flv(i)) end do end subroutine create_test_particle_set_1 @ %def create_test_particle_set_1 @ Reconstruct an interaction with beam structure, e.g., a hadronic interaction, from a particle set that is missing the beam information. <>= call test (particles_4, "particles_4", & "reconstruct interaction with missing beams", & u, results) <>= public :: particles_4 <>= subroutine particles_4 (u) integer, intent(in) :: u type(interaction_t) :: int type(interaction_t), target :: int_beams type(state_flv_content_t) :: state_flv type(particle_set_t) :: pset type(flavor_t), dimension(:), allocatable :: flv type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: i, j write (u, "(A)") "* Test output: Particles" write (u, "(A)") "* Purpose: reconstruct beams" write (u, "(A)") call reset_interaction_counter () write (u, "(A)") "* Set up an interaction that contains beams only" write (u, "(A)") call int_beams%basic_init (0, 0, 2) call int_beams%set_momentum (vector4_at_rest (1._default), 1) call int_beams%set_momentum (vector4_at_rest (2._default), 2) allocate (qn (2)) call int_beams%add_state (qn) call int_beams%freeze () call int_beams%basic_write (u) write (u, "(A)") write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation" write (u, "(A)") " + no quantum numbers" write (u, "(A)") call int%basic_init (0, 6, 3) call int%relate (1, 3) call int%relate (1, 4) call int%relate (2, 5) call int%relate (2, 6) do i = 4, 6, 2 do j = 7, 9 call int%relate (i, j) end do end do do i = 1, 2 call int%set_source_link (i, int_beams, i) end do deallocate (qn) allocate (qn (9)) call int%add_state (qn) call int%freeze () call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Manually set up a flavor-content record" write (u, "(A)") call state_flv%init (1, & mask = [.false., .false., .false., .false., .false., .false., & .true., .true., .true.]) call state_flv%set_entry (1, & pdg = [2011, 2012, 91, 11, 92, 12, 3, 4, 5], & map = [1, 2, 3, 4, 5, 6, 7, 8, 9]) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Manually create a matching particle set" write (u, "(A)") pset%n_beam = 0 pset%n_in = 2 pset%n_vir = 0 pset%n_out = 3 pset%n_tot = 5 allocate (pset%prt (pset%n_tot)) call pset%prt(1)%reset_status (PRT_INCOMING) call pset%prt(2)%reset_status (PRT_INCOMING) call pset%prt(3)%reset_status (PRT_OUTGOING) call pset%prt(4)%reset_status (PRT_OUTGOING) call pset%prt(5)%reset_status (PRT_OUTGOING) call pset%prt(1)%set_children ([3,4,5]) call pset%prt(2)%set_children ([3,4,5]) call pset%prt(3)%set_parents ([1,2]) call pset%prt(4)%set_parents ([1,2]) call pset%prt(5)%set_parents ([1,2]) call pset%prt(1)%set_momentum (vector4_at_rest (6._default)) call pset%prt(2)%set_momentum (vector4_at_rest (6._default)) call pset%prt(3)%set_momentum (vector4_at_rest (3._default)) call pset%prt(4)%set_momentum (vector4_at_rest (4._default)) call pset%prt(5)%set_momentum (vector4_at_rest (5._default)) allocate (flv (5)) call flv%init ([11, 12, 3, 4, 5]) do i = 1, 5 call pset%prt(i)%set_flavor (flv(i)) end do call pset%write (u) write (u, "(A)") write (u, "(A)") "* Fill interaction from particle set" write (u, "(A)") call pset%fill_interaction (int, 2, state_flv=state_flv, & recover_beams = .true.) call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call int%final () call pset%final () write (u, "(A)") write (u, "(A)") "* Test output end: particles_4" end subroutine particles_4 @ %def particles_4 @ Reconstruct an interaction with beam structure and cloned particles (radiated particles repeated in the event record, to maintain some canonical ordering). <>= call test (particles_5, "particles_5", & "reconstruct interaction with beams and duplicate entries", & u, results) <>= public :: particles_5 <>= subroutine particles_5 (u) integer, intent(in) :: u type(interaction_t) :: int type(state_flv_content_t) :: state_flv type(particle_set_t) :: pset type(flavor_t), dimension(:), allocatable :: flv type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: i, j write (u, "(A)") "* Test output: Particles" write (u, "(A)") "* Purpose: reconstruct event with duplicate entries" write (u, "(A)") write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation" write (u, "(A)") " + no quantum numbers" write (u, "(A)") call reset_interaction_counter () call int%basic_init (0, 6, 3) call int%relate (1, 3) call int%relate (1, 4) call int%relate (2, 5) call int%relate (2, 6) do i = 4, 6, 2 do j = 7, 9 call int%relate (i, j) end do end do allocate (qn (9)) call int%add_state (qn) call int%freeze () call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Manually set up a flavor-content record" write (u, "(A)") call state_flv%init (1, & mask = [.false., .false., .false., .false., .false., .false., & .true., .true., .true.]) call state_flv%set_entry (1, & pdg = [2011, 2012, 91, 11, 92, 12, 3, 4, 5], & map = [1, 2, 3, 4, 5, 6, 7, 8, 9]) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Manually create a matching particle set" write (u, "(A)") pset%n_beam = 2 pset%n_in = 2 pset%n_vir = 4 pset%n_out = 5 pset%n_tot = 13 allocate (pset%prt (pset%n_tot)) call pset%prt(1)%reset_status (PRT_BEAM) call pset%prt(2)%reset_status (PRT_BEAM) call pset%prt(3)%reset_status (PRT_VIRTUAL) call pset%prt(4)%reset_status (PRT_VIRTUAL) call pset%prt(5)%reset_status (PRT_VIRTUAL) call pset%prt(6)%reset_status (PRT_VIRTUAL) call pset%prt(7)%reset_status (PRT_INCOMING) call pset%prt(8)%reset_status (PRT_INCOMING) call pset%prt( 9)%reset_status (PRT_OUTGOING) call pset%prt(10)%reset_status (PRT_OUTGOING) call pset%prt(11)%reset_status (PRT_OUTGOING) call pset%prt(12)%reset_status (PRT_OUTGOING) call pset%prt(13)%reset_status (PRT_OUTGOING) call pset%prt(1)%set_children ([3,4]) call pset%prt(2)%set_children ([5,6]) call pset%prt(3)%set_children ([ 7]) call pset%prt(4)%set_children ([ 9]) call pset%prt(5)%set_children ([ 8]) call pset%prt(6)%set_children ([10]) call pset%prt(7)%set_children ([11,12,13]) call pset%prt(8)%set_children ([11,12,13]) call pset%prt(3)%set_parents ([1]) call pset%prt(4)%set_parents ([1]) call pset%prt(5)%set_parents ([2]) call pset%prt(6)%set_parents ([2]) call pset%prt( 7)%set_parents ([3]) call pset%prt( 8)%set_parents ([5]) call pset%prt( 9)%set_parents ([4]) call pset%prt(10)%set_parents ([6]) call pset%prt(11)%set_parents ([7,8]) call pset%prt(12)%set_parents ([7,8]) call pset%prt(13)%set_parents ([7,8]) call pset%prt(1)%set_momentum (vector4_at_rest (1._default)) call pset%prt(2)%set_momentum (vector4_at_rest (2._default)) call pset%prt(3)%set_momentum (vector4_at_rest (4._default)) call pset%prt(4)%set_momentum (vector4_at_rest (3._default)) call pset%prt(5)%set_momentum (vector4_at_rest (6._default)) call pset%prt(6)%set_momentum (vector4_at_rest (5._default)) call pset%prt(7)%set_momentum (vector4_at_rest (4._default)) call pset%prt(8)%set_momentum (vector4_at_rest (6._default)) call pset%prt( 9)%set_momentum (vector4_at_rest (3._default)) call pset%prt(10)%set_momentum (vector4_at_rest (5._default)) call pset%prt(11)%set_momentum (vector4_at_rest (7._default)) call pset%prt(12)%set_momentum (vector4_at_rest (8._default)) call pset%prt(13)%set_momentum (vector4_at_rest (9._default)) allocate (flv (13)) call flv%init ([2011, 2012, 11, 91, 12, 92, 11, 12, 91, 92, 3, 4, 5]) do i = 1, 13 call pset%prt(i)%set_flavor (flv(i)) end do call pset%write (u) write (u, "(A)") write (u, "(A)") "* Fill interaction from particle set" write (u, "(A)") call pset%fill_interaction (int, 2, state_flv=state_flv) call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call int%final () call pset%final () write (u, "(A)") write (u, "(A)") "* Test output end: particles_5" end subroutine particles_5 @ %def particles_5 @ Reconstruct an interaction with pair spectrum, e.g., beamstrahlung from a particle set. <>= call test (particles_6, "particles_6", & "reconstruct interaction with pair spectrum", & u, results) <>= public :: particles_6 <>= subroutine particles_6 (u) integer, intent(in) :: u type(interaction_t) :: int type(state_flv_content_t) :: state_flv type(particle_set_t) :: pset type(flavor_t), dimension(:), allocatable :: flv type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: i, j write (u, "(A)") "* Test output: Particles" write (u, "(A)") "* Purpose: reconstruct interaction with pair spectrum" write (u, "(A)") write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation" write (u, "(A)") " + no quantum numbers" write (u, "(A)") call reset_interaction_counter () call int%basic_init (0, 6, 3) do i = 1, 2 do j = 3, 6 call int%relate (i, j) end do end do do i = 5, 6 do j = 7, 9 call int%relate (i, j) end do end do allocate (qn (9)) call int%add_state (qn) call int%freeze () call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Manually set up a flavor-content record" write (u, "(A)") call state_flv%init (1, & mask = [.false., .false., .false., .false., .false., .false., & .true., .true., .true.]) call state_flv%set_entry (1, & pdg = [1011, 1012, 21, 22, 11, 12, 3, 4, 5], & map = [1, 2, 3, 4, 5, 6, 7, 8, 9]) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Manually create a matching particle set" write (u, "(A)") pset%n_beam = 2 pset%n_in = 2 pset%n_vir = 2 pset%n_out = 3 pset%n_tot = 9 allocate (pset%prt (pset%n_tot)) call pset%prt(1)%reset_status (PRT_BEAM) call pset%prt(2)%reset_status (PRT_BEAM) call pset%prt(3)%reset_status (PRT_INCOMING) call pset%prt(4)%reset_status (PRT_INCOMING) call pset%prt(5)%reset_status (PRT_OUTGOING) call pset%prt(6)%reset_status (PRT_OUTGOING) call pset%prt(7)%reset_status (PRT_OUTGOING) call pset%prt(8)%reset_status (PRT_OUTGOING) call pset%prt(9)%reset_status (PRT_OUTGOING) call pset%prt(1)%set_children ([3,4,5,6]) call pset%prt(2)%set_children ([3,4,5,6]) call pset%prt(3)%set_children ([7,8,9]) call pset%prt(4)%set_children ([7,8,9]) call pset%prt(3)%set_parents ([1,2]) call pset%prt(4)%set_parents ([1,2]) call pset%prt(5)%set_parents ([1,2]) call pset%prt(6)%set_parents ([1,2]) call pset%prt(7)%set_parents ([3,4]) call pset%prt(8)%set_parents ([3,4]) call pset%prt(9)%set_parents ([3,4]) call pset%prt(1)%set_momentum (vector4_at_rest (1._default)) call pset%prt(2)%set_momentum (vector4_at_rest (2._default)) call pset%prt(3)%set_momentum (vector4_at_rest (5._default)) call pset%prt(4)%set_momentum (vector4_at_rest (6._default)) call pset%prt(5)%set_momentum (vector4_at_rest (3._default)) call pset%prt(6)%set_momentum (vector4_at_rest (4._default)) call pset%prt(7)%set_momentum (vector4_at_rest (7._default)) call pset%prt(8)%set_momentum (vector4_at_rest (8._default)) call pset%prt(9)%set_momentum (vector4_at_rest (9._default)) allocate (flv (9)) call flv%init ([1011, 1012, 11, 12, 21, 22, 3, 4, 5]) do i = 1, 9 call pset%prt(i)%set_flavor (flv(i)) end do call pset%write (u) write (u, "(A)") write (u, "(A)") "* Fill interaction from particle set" write (u, "(A)") call pset%fill_interaction (int, 2, state_flv=state_flv) call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call int%final () call pset%final () write (u, "(A)") write (u, "(A)") "* Test output end: particles_6" end subroutine particles_6 @ %def particles_6 @ Reconstruct a hard decay interaction from a shuffled particle set. <>= call test (particles_7, "particles_7", & "reconstruct decay interaction with reordering", & u, results) <>= public :: particles_7 <>= subroutine particles_7 (u) integer, intent(in) :: u type(interaction_t) :: int type(state_flv_content_t) :: state_flv type(particle_set_t) :: pset type(flavor_t), dimension(:), allocatable :: flv type(quantum_numbers_t), dimension(:), allocatable :: qn integer :: i, j write (u, "(A)") "* Test output: Particles" write (u, "(A)") "* Purpose: reconstruct decay interaction with reordering" write (u, "(A)") write (u, "(A)") "* Set up a 1 -> 3 interaction" write (u, "(A)") " + no quantum numbers" write (u, "(A)") call reset_interaction_counter () call int%basic_init (0, 1, 3) do j = 2, 4 call int%relate (1, j) end do allocate (qn (4)) call int%add_state (qn) call int%freeze () call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Manually set up a flavor-content record" write (u, "(A)") "* assumed interaction: 6 12 5 -11" write (u, "(A)") call state_flv%init (1, & mask = [.false., .true., .true., .true.]) call state_flv%set_entry (1, & pdg = [6, 5, -11, 12], & map = [1, 4, 2, 3]) call state_flv%write (u) write (u, "(A)") write (u, "(A)") "* Manually create a matching particle set" write (u, "(A)") pset%n_beam = 0 pset%n_in = 1 pset%n_vir = 0 pset%n_out = 3 pset%n_tot = 4 allocate (pset%prt (pset%n_tot)) do i = 1, 1 call pset%prt(i)%reset_status (PRT_INCOMING) call pset%prt(i)%set_children ([2,3,4]) end do do i = 2, 4 call pset%prt(i)%reset_status (PRT_OUTGOING) call pset%prt(i)%set_parents ([1]) end do call pset%prt(1)%set_momentum (vector4_at_rest (1._default)) call pset%prt(2)%set_momentum (vector4_at_rest (3._default)) call pset%prt(3)%set_momentum (vector4_at_rest (2._default)) call pset%prt(4)%set_momentum (vector4_at_rest (4._default)) allocate (flv (4)) call flv%init ([6,5,12,-11]) do i = 1, 4 call pset%prt(i)%set_flavor (flv(i)) end do call pset%write (u) write (u, "(A)") write (u, "(A)") "* Fill interaction from particle set" write (u, "(A)") call pset%fill_interaction (int, 1, state_flv=state_flv) call int%basic_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call int%final () call pset%final () write (u, "(A)") write (u, "(A)") "* Test output end: particles_7" end subroutine particles_7 @ %def particles_7 @ <>= call test (particles_8, "particles_8", & "Test functions on particle sets", u, results) <>= public :: particles_8 <>= subroutine particles_8 (u) integer, intent(in) :: u type(particle_set_t) :: particle_set type(particle_t), dimension(:), allocatable :: particles integer, allocatable, dimension(:) :: children, parents integer :: n_particles, i write (u, "(A)") "* Test output: particles_8" write (u, "(A)") "* Purpose: Test functions on particle sets" write (u, "(A)") call create_test_particle_set_1 (particle_set) call particle_set%write (u) call assert_equal (u, particle_set%n_tot, 9) call assert_equal (u, particle_set%n_beam, 2) allocate (children (particle_set%prt(3)%get_n_children ())) children = particle_set%prt(3)%get_children() call assert_equal (u, particle_set%prt(children(1))%get_pdg (), 3) call assert_equal (u, size (particle_set%prt(1)%get_children ()), 2) call assert_equal (u, size (particle_set%prt(2)%get_children ()), 2) call particle_set%without_hadronic_remnants & (particles, n_particles, 3) call particle_set%replace (particles) write (u, "(A)") call particle_set%write (u) call assert_equal (u, n_particles, 7) call assert_equal (u, size(particles), 10) call assert_equal (u, particle_set%n_tot, 10) call assert_equal (u, particle_set%n_beam, 2) do i = 3, 4 if (allocated (children)) deallocate (children) allocate (children (particle_set%prt(i)%get_n_children ())) children = particle_set%prt(i)%get_children() call assert_equal (u, particle_set%prt(children(1))%get_pdg (), 3) call assert_equal (u, particle_set%prt(children(2))%get_pdg (), 4) call assert_equal (u, particle_set%prt(children(3))%get_pdg (), 5) end do do i = 5, 7 if (allocated (parents)) deallocate (parents) allocate (parents (particle_set%prt(i)%get_n_parents ())) parents = particle_set%prt(i)%get_parents() call assert_equal (u, particle_set%prt(parents(1))%get_pdg (), 11) call assert_equal (u, particle_set%prt(parents(2))%get_pdg (), 12) end do call assert_equal (u, size (particle_set%prt(1)%get_children ()), & 1, "get children of 1") call assert_equal (u, size (particle_set%prt(2)%get_children ()), & 1, "get children of 2") call assert_equal (u, particle_set%find_particle & (particle_set%prt(1)%get_pdg (), particle_set%prt(1)%p), & 1, "find 1st particle") call assert_equal (u, particle_set%find_particle & (particle_set%prt(2)%get_pdg (), particle_set%prt(2)%p * & (one + tiny_07), rel_smallness=1.0E-6_default), & 2, "find 2nd particle fuzzy") write (u, "(A)") write (u, "(A)") "* Test output end: particles_8" end subroutine particles_8 @ %def particles_8 @ Order color lines into Lund string systems, without colored beam remnants first. <>= call test (particles_9, "particles_9", & "order into Lund strings, uncolored beam remnants", & u, results) <>= public :: particles_9 <>= subroutine particles_9 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: particles_9" write (u, "(A)") "* Purpose: Order into Lund strings, " write (u, "(A)") "* uncolored beam remnants" write (u, "(A)") end subroutine particles_9 @ %def particles_9 Index: trunk/src/transforms/transforms.nw =================================================================== --- trunk/src/transforms/transforms.nw (revision 8778) +++ trunk/src/transforms/transforms.nw (revision 8779) @@ -1,14495 +1,14495 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD event transforms and event API %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Event Implementation} \includemodulegraph{transforms} With a process object and the associated methods at hand, we can generate events for elementary processes and, by subsequent transformation, for complete physical processes. We have the following modules: \begin{description} \item[event\_transforms] Abstract base type for transforming a physical process with process instance and included evaluators, etc., into a new object. The following modules extend this base type. \item[resonance\_insertion] Insert a resonance history into an event record, based on kinematical and matrix-element information. \item[recoil\_kinematics] Common kinematics routines for the ISR and EPA handlers. \item[isr\_photon\_handler] Transform collinear kinematics, as it results from applying ISR radiation, to non-collinear kinematics with a reasonable transverse-momentum distribution of the radiated photons, and also of the recoiling partonic event. \item[epa\_beam\_handler] For photon-initiated processes where the effective photon approximation is used in integration, to add in beam-particle recoil. Analogous to the ISR handler. \item[decays] Combine the elementary process with elementary decay processes and thus transform the elementary event into a decayed event, still at the parton level. \item[showers] Create QED/QCD showers out of the partons that are emitted by elementary processes. This should be interleaved with showering of radiated particles (structure functions) and multiple interactions. \item[hadrons] (not implemented yet) Apply hadronization to the partonic events, interleaved with hadron decays. (The current setup relies on hadronizing partonic events externally.) \item[tau\_decays] (not implemented yet) Let $\tau$ leptons decay taking full spin correlations into account. \item[evt\_nlo] Handler for fixed-order NLO events. \item[events] Combine all pieces to generate full events. \item[eio\_raw] Raw I/O for complete events. \end{description} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Abstract Event Transforms} <<[[event_transforms.f90]]>>= <> module event_transforms <> <> use io_units use format_utils, only: write_separator use diagnostics use model_data use interactions use particles use subevents use rng_base use quantum_numbers, only: quantum_numbers_t use process, only: process_t use instances, only: process_instance_t use process_stacks <> <> <> <> contains <> end module event_transforms @ %def event_transforms @ \subsection{Abstract base type} Essentially, all methods are abstract, but some get minimal base versions. We know that there will be a random-number generator at top level, and that we will relate to an elementary process. The model is stored separately. It may contain modified settings that differ from the model instance stored in the process object. Each event transform contains a particle set that it can fill for further use. There is a flag that indicates this. We will collect event transforms in a list, therefore we include [[previous]] and [[next]] pointers. <>= public :: evt_t <>= type, abstract :: evt_t type(process_t), pointer :: process => null () type(process_instance_t), pointer :: process_instance => null () class(model_data_t), pointer :: model => null () class(rng_t), allocatable :: rng integer :: rejection_count = 0 logical :: particle_set_exists = .false. type(particle_set_t) :: particle_set class(evt_t), pointer :: previous => null () class(evt_t), pointer :: next => null () logical :: only_weighted_events = .false. contains <> end type evt_t @ %def evt_t @ Finalizer. In any case, we finalize the r.n.g. The process instance is a pointer and should not be finalized here. <>= procedure :: final => evt_final procedure :: base_final => evt_final <>= subroutine evt_final (evt) class(evt_t), intent(inout) :: evt if (allocated (evt%rng)) call evt%rng%final () if (evt%particle_set_exists) & call evt%particle_set%final () end subroutine evt_final @ %def evt_final @ Print out the type of the [[evt]]. <>= procedure (evt_write_name), deferred :: write_name <>= abstract interface subroutine evt_write_name (evt, unit) import class(evt_t), intent(in) :: evt integer, intent(in), optional :: unit end subroutine evt_write_name end interface @ %def evt_write_name @ <>= procedure (evt_write), deferred :: write <>= abstract interface subroutine evt_write (evt, unit, verbose, more_verbose, testflag) import class(evt_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag end subroutine evt_write end interface @ %def evt_write @ Output. We can print r.n.g. info. <>= procedure :: base_write => evt_base_write <>= subroutine evt_base_write (evt, unit, testflag, show_set) class(evt_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag, show_set integer :: u logical :: show u = given_output_unit (unit) show = .true.; if (present (show_set)) show = show_set if (associated (evt%process)) then write (u, "(3x,A,A,A)") "Associated process: '", & char (evt%process%get_id ()), "'" end if if (allocated (evt%rng)) then call evt%rng%write (u, 1) write (u, "(3x,A,I0)") "Number of tries = ", evt%rejection_count end if if (show) then if (evt%particle_set_exists) then call write_separator (u) call evt%particle_set%write (u, testflag = testflag) end if end if end subroutine evt_base_write @ %def evt_base_write @ Connect the transform with a process instance (and thus with the associated process). Use this to allocate the master random-number generator. This is not an initializer; we may initialize the transform by implementation-specific methods. <>= procedure :: connect => evt_connect procedure :: base_connect => evt_connect <>= subroutine evt_connect (evt, process_instance, model, process_stack) class(evt_t), intent(inout), target :: evt type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack evt%process => process_instance%process evt%process_instance => process_instance evt%model => model call evt%process%make_rng (evt%rng) end subroutine evt_connect @ %def evt_connect @ Reset internal state. <>= procedure :: reset => evt_reset procedure :: base_reset => evt_reset <>= subroutine evt_reset (evt) class(evt_t), intent(inout) :: evt evt%rejection_count = 0 call evt%particle_set%final () evt%particle_set_exists = .false. end subroutine evt_reset @ %def evt_reset @ Prepare for a new event: reset internal state, if necessary. We provide MCI and term index of the parent process. <>= procedure (evt_prepare_new_event), deferred :: prepare_new_event <>= interface subroutine evt_prepare_new_event (evt, i_mci, i_term) import class(evt_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term end subroutine evt_prepare_new_event end interface @ %def evt_prepare_new_event @ Generate a weighted event, using a valid initiator event in the process instance, and the random-number generator. The returned event probability should be a number between zero and one that we can use for rejection. <>= procedure (evt_generate_weighted), deferred :: generate_weighted <>= abstract interface subroutine evt_generate_weighted (evt, probability) import class(evt_t), intent(inout) :: evt real(default), intent(inout) :: probability end subroutine evt_generate_weighted end interface @ %def evt_generate_weighted @ The unweighted event generation routine is actually implemented. It uses the random-number generator for simple rejection. Of course, the implementation may override this and implement a different way of generating an unweighted event. <>= procedure :: generate_unweighted => evt_generate_unweighted procedure :: base_generate_unweighted => evt_generate_unweighted <>= subroutine evt_generate_unweighted (evt) class(evt_t), intent(inout) :: evt real(default) :: p, x evt%rejection_count = 0 REJECTION: do evt%rejection_count = evt%rejection_count + 1 call evt%generate_weighted (p) if (signal_is_pending ()) return call evt%rng%generate (x) if (x < p) exit REJECTION end do REJECTION end subroutine evt_generate_unweighted @ %def evt_generate_unweighted @ Make a particle set. This should take the most recent evaluator (or whatever stores the event), factorize the density matrix if necessary, and store as a particle set. If applicable, the factorization should make use of the [[factorization_mode]] and [[keep_correlations]] settings. The values [[r]], if set, should control the factorization in more detail, e.g., bypassing the random-number generator. <>= procedure (evt_make_particle_set), deferred :: make_particle_set <>= interface subroutine evt_make_particle_set & (evt, factorization_mode, keep_correlations, r) import class(evt_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r end subroutine evt_make_particle_set end interface @ %def evt_make_particle_set @ Copy an existing particle set into the event record. This bypasses all methods to evaluate the internal state, but may be sufficient for further processing. <>= procedure :: set_particle_set => evt_set_particle_set <>= subroutine evt_set_particle_set (evt, particle_set, i_mci, i_term) class(evt_t), intent(inout) :: evt type(particle_set_t), intent(in) :: particle_set integer, intent(in) :: i_term, i_mci call evt%prepare_new_event (i_mci, i_term) evt%particle_set = particle_set evt%particle_set_exists = .true. end subroutine evt_set_particle_set @ %def evt_set_particle_set @ This procedure can help in the previous task, if the particles are available in the form of an interaction object. We need two interactions, one with color summed over, the [[int_matrix]], and one with the probability distributed among flows, the [[int_flows]]. We use the two values from the random number generator saved in [[r]] for factorizing the state. For testing purposes, we can provide those numbers explicitly. The optional [[qn_select]] allows to limit the number of quantum numbers to choose from when factorizing. If only a single set of quantum numbers is given, it effectively dictates the quantum numbers chosen for the event. <>= procedure :: factorize_interactions => evt_factorize_interactions <>= subroutine evt_factorize_interactions & (evt, int_matrix, int_flows, factorization_mode, & keep_correlations, r, qn_select) class(evt_t), intent(inout) :: evt type(interaction_t), intent(in), target :: int_matrix, int_flows integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_select real(default), dimension(2) :: x if (present (r)) then if (size (r) == 2) then x = r else call msg_bug ("event factorization: size of r array must be 2") end if else call evt%rng%generate (x) end if call evt%particle_set%init (evt%particle_set_exists, & int_matrix, int_flows, factorization_mode, x, & keep_correlations, keep_virtual=.true., qn_select = qn_select) evt%particle_set_exists = .true. end subroutine evt_factorize_interactions @ %def evt_factorize_interactions @ <>= public :: make_factorized_particle_set <>= subroutine make_factorized_particle_set (evt, factorization_mode, & keep_correlations, r, ii_term, qn_select) class(evt_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r integer, intent(in), optional :: ii_term type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_select integer :: i_term type(interaction_t), pointer :: int_matrix, int_flows if (evt%process_instance%is_complete_event ()) then if (present (ii_term)) then i_term = ii_term else i_term = evt%process_instance%select_i_term () end if int_matrix => evt%process_instance%get_matrix_int_ptr (i_term) int_flows => evt%process_instance%get_flows_int_ptr (i_term) call evt%factorize_interactions (int_matrix, int_flows, & factorization_mode, keep_correlations, r, qn_select) call evt%tag_incoming () else call msg_bug ("Event factorization: event is incomplete") end if end subroutine make_factorized_particle_set @ %def make_factorized_particle_set @ Mark the incoming particles as incoming in the particle set. This is necessary because in the interaction objects they are usually marked as virtual. In the inquiry functions we set the term index to one; the indices of beams and incoming particles should be identical for all process terms. We use the initial elementary process for obtaining the indices. Thus, we implicitly assume that the beam and incoming indices stay the same across event transforms. If this is not true for a transform (say, MPI), it should override this method. <>= procedure :: tag_incoming => evt_tag_incoming <>= subroutine evt_tag_incoming (evt) class(evt_t), intent(inout) :: evt integer :: i_term, n_in integer, dimension(:), allocatable :: beam_index, in_index n_in = evt%process%get_n_in () i_term = 1 allocate (beam_index (n_in)) call evt%process_instance%get_beam_index (i_term, beam_index) call evt%particle_set%reset_status (beam_index, PRT_BEAM) allocate (in_index (n_in)) call evt%process_instance%get_in_index (i_term, in_index) call evt%particle_set%reset_status (in_index, PRT_INCOMING) end subroutine evt_tag_incoming @ %def evt_tag_incoming @ \subsection{Implementation: Trivial transform} This transform contains just a pointer to process and process instance. The [[generate]] methods do nothing. <>= public :: evt_trivial_t <>= type, extends (evt_t) :: evt_trivial_t contains <> end type evt_trivial_t @ %def evt_trivial_t @ <>= procedure :: write_name => evt_trivial_write_name <>= subroutine evt_trivial_write_name (evt, unit) class(evt_trivial_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: trivial (hard process)" end subroutine evt_trivial_write_name @ %def evt_trivial_write_name @ The finalizer is trivial. Some output: <>= procedure :: write => evt_trivial_write <>= subroutine evt_trivial_write (evt, unit, verbose, more_verbose, testflag) class(evt_trivial_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u) call evt%base_write (u, testflag = testflag) !!! More readable but wider output; in line with evt_resonance_write ! if (verbose .and. evt%particle_set_exists) then ! call evt%particle_set%write & ! (u, summary = .true., compressed = .true., testflag = testflag) ! call write_separator (u) ! end if end subroutine evt_trivial_write @ %def evt_trivial_write @ Nothing to do here: <>= procedure :: prepare_new_event => evt_trivial_prepare_new_event <>= subroutine evt_trivial_prepare_new_event (evt, i_mci, i_term) class(evt_trivial_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () end subroutine evt_trivial_prepare_new_event @ %def evt_trivial_prepare_new_event @ The weighted generator is, surprisingly, trivial. <>= procedure :: generate_weighted => evt_trivial_generate_weighted <>= subroutine evt_trivial_generate_weighted (evt, probability) class(evt_trivial_t), intent(inout) :: evt real(default), intent(inout) :: probability probability = 1 end subroutine evt_trivial_generate_weighted @ %def evt_trivial_generate_weighted @ This routine makes a particle set, using the associated process instance as-is. Note that it is a potential risk to tolerate a non-existent particle set at this point. We should remove it once the flavors are determined correctly in all cases. It is currently neccessary if we are keeping failed events [[?keep_failed_events = .true.]]. For these events, we do not compute the matrix elements, so the factorization fails trying to determine the quantum numbers. Additionally, it is necessary for the trivial event transformation preceeding the event transformations required for POWHEG matching. <>= procedure :: make_particle_set => evt_trivial_make_particle_set <>= subroutine evt_trivial_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_trivial_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r call make_factorized_particle_set (evt, factorization_mode, & keep_correlations, r) evt%particle_set_exists = .true. end subroutine evt_trivial_make_particle_set @ %def event_trivial_make_particle_set @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[event_transforms_ut.f90]]>>= <> module event_transforms_ut use unit_tests use event_transforms_uti <> <> contains <> end module event_transforms_ut @ %def event_transforms_ut @ <<[[event_transforms_uti.f90]]>>= <> module event_transforms_uti <> <> use format_utils, only: write_separator use os_interface use sm_qcd use models use state_matrices, only: FM_IGNORE_HELICITY use interactions, only: reset_interaction_counter use process_libraries use rng_base use mci_base use mci_midpoint use phs_base use phs_single use prc_core use prc_test, only: prc_test_create_library use process, only: process_t use instances, only: process_instance_t use event_transforms use rng_base_ut, only: rng_test_factory_t <> <> contains <> <> end module event_transforms_uti @ %def event_transforms_uti @ API: driver for the unit tests below. <>= public :: event_transforms_test <>= subroutine event_transforms_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine event_transforms_test @ %def event_transforms_test @ \subsubsection{Test trivial event transform} The trivial transform, as an instance of the abstract transform, does nothing but to trigger event generation for an elementary process. <>= call test (event_transforms_1, "event_transforms_1", & "trivial event transform", & u, results) <>= public :: event_transforms_1 <>= subroutine event_transforms_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_t), target :: model type(process_library_t), target :: lib type(string_t) :: libname, procname1 class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance class(evt_t), allocatable :: evt integer :: factorization_mode logical :: keep_correlations write (u, "(A)") "* Test output: event_transforms_1" write (u, "(A)") "* Purpose: handle trivial transform" write (u, "(A)") write (u, "(A)") "* Initialize environment and parent process" write (u, "(A)") call os_data%init () libname = "event_transforms_1_lib" procname1 = "event_transforms_1_p" call prc_test_create_library (libname, lib, & scattering = .true., procname1 = procname1) call reset_interaction_counter () call model%init_test () allocate (process) call process%init (procname1, lib, os_data, model) call process%setup_test_cores () allocate (phs_single_config_t :: phs_config_template) call process%init_components (phs_config_template) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test_midpoint) call process%setup_terms () allocate (process_instance) call process_instance%init (process) call process_instance%integrate (1, n_it=1, n_calls=100) call process%final_integration (1) call process_instance%final () deallocate (process_instance) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () call process_instance%init_simulation (1) write (u, "(A)") "* Initialize trivial event transform" write (u, "(A)") allocate (evt_trivial_t :: evt) call evt%connect (process_instance, process%get_model_ptr ()) write (u, "(A)") "* Generate event and subsequent transform" write (u, "(A)") call process_instance%generate_unweighted_event (1) call process_instance%evaluate_event_data () call evt%prepare_new_event (1, 1) call evt%generate_unweighted () call write_separator (u, 2) call evt%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Obtain particle set" write (u, "(A)") factorization_mode = FM_IGNORE_HELICITY keep_correlations = .false. call evt%make_particle_set (factorization_mode, keep_correlations) call write_separator (u, 2) call evt%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Cleanup" call evt%final () call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Test output end: event_transforms_1" end subroutine event_transforms_1 @ %def event_transforms_1 @ MCI record prepared for midpoint integrator. <>= subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo) use variables, only: var_list_t class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_midpoint_t :: mci) end subroutine dispatch_mci_test_midpoint @ %def dispatch_mci_test_midpoint @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Hadronization interface} <<[[hadrons.f90]]>>= <> module hadrons <> <> <> use constants use diagnostics use event_transforms use format_utils, only: write_separator use helicities use hep_common use io_units use lorentz use model_data use models use numeric_utils, only: vanishes use particles use physics_defs use process, only: process_t use instances, only: process_instance_t use process_stacks use pythia8 use rng_base, only: rng_t use shower_base use shower_pythia6 use sm_qcd use subevents use variables use whizard_lha <> <> <> <> <> contains <> end module hadrons @ %def hadrons @ \subsection{Hadronization implementations} <>= public :: HADRONS_UNDEFINED, HADRONS_WHIZARD, HADRONS_PYTHIA6, HADRONS_PYTHIA8 <>= integer, parameter :: HADRONS_UNDEFINED = 0 integer, parameter :: HADRONS_WHIZARD = 1 integer, parameter :: HADRONS_PYTHIA6 = 2 integer, parameter :: HADRONS_PYTHIA8 = 3 @ %def HADRONS_UNDEFINED HADRONS_WHIZARD HADRONS_PYTHIA6 HADRONS_PYTHIA8 @ A dictionary <>= public :: hadrons_method <>= interface hadrons_method module procedure hadrons_method_of_string module procedure hadrons_method_to_string end interface <>= elemental function hadrons_method_of_string (string) result (i) integer :: i type(string_t), intent(in) :: string select case (char(string)) case ("WHIZARD") i = HADRONS_WHIZARD case ("PYTHIA6") i = HADRONS_PYTHIA6 case ("PYTHIA8") i = HADRONS_PYTHIA8 case default i = HADRONS_UNDEFINED end select end function hadrons_method_of_string elemental function hadrons_method_to_string (i) result (string) type(string_t) :: string integer, intent(in) :: i select case (i) case (HADRONS_WHIZARD) string = "WHIZARD" case (HADRONS_PYTHIA6) string = "PYTHIA6" case (HADRONS_PYTHIA8) string = "PYTHIA8" case default string = "UNDEFINED" end select end function hadrons_method_to_string @ %def hadrons_method @ \subsection{Hadronization settings} These are the general settings and parameters for the different shower methods. <>= public :: hadron_settings_t <>= type :: hadron_settings_t logical :: active = .false. integer :: method = HADRONS_UNDEFINED real(default) :: enhanced_fraction = 0 real(default) :: enhanced_width = 0 contains <> end type hadron_settings_t @ %def hadron_settings_t @ Read in the hadronization settings. <>= procedure :: init => hadron_settings_init <>= subroutine hadron_settings_init (hadron_settings, var_list) class(hadron_settings_t), intent(out) :: hadron_settings type(var_list_t), intent(in) :: var_list hadron_settings%active = & var_list%get_lval (var_str ("?hadronization_active")) hadron_settings%method = hadrons_method_of_string ( & var_list%get_sval (var_str ("$hadronization_method"))) hadron_settings%enhanced_fraction = & var_list%get_rval (var_str ("hadron_enhanced_fraction")) hadron_settings%enhanced_width = & var_list%get_rval (var_str ("hadron_enhanced_width")) end subroutine hadron_settings_init @ %def hadron_settings_init @ <>= procedure :: write => hadron_settings_write <>= subroutine hadron_settings_write (settings, unit) class(hadron_settings_t), intent(in) :: settings integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Hadronization settings:" call write_separator (u) write (u, "(1x,A)") "Master switches:" write (u, "(3x,A,1x,L1)") & "active = ", settings%active write (u, "(1x,A)") "General settings:" if (settings%active) then write (u, "(3x,A)") & "hadron_method = " // & char (hadrons_method_to_string (settings%method)) else write (u, "(3x,A)") " [Hadronization off]" end if write (u, "(1x,A)") "pT generation parameters" write (u, "(3x,A,1x,ES19.12)") & "enhanced_fraction = ", settings%enhanced_fraction write (u, "(3x,A,1x,ES19.12)") & "enhanced_width = ", settings%enhanced_width end subroutine hadron_settings_write @ %def hadron_settings_write @ \subsection{Abstract Hadronization Type} The [[model]] is the fallback model including all hadrons <>= type, abstract :: hadrons_t class(rng_t), allocatable :: rng type(shower_settings_t) :: shower_settings type(hadron_settings_t) :: hadron_settings type(model_t), pointer :: model => null() contains <> end type hadrons_t @ %def hadrons_t @ <>= procedure (hadrons_init), deferred :: init <>= abstract interface subroutine hadrons_init & (hadrons, shower_settings, hadron_settings, model_hadrons) import class(hadrons_t), intent(out) :: hadrons type(shower_settings_t), intent(in) :: shower_settings type(hadron_settings_t), intent(in) :: hadron_settings type(model_t), target, intent(in) :: model_hadrons end subroutine hadrons_init end interface @ %def hadrons_init @ <>= procedure (hadrons_hadronize), deferred :: hadronize <>= abstract interface subroutine hadrons_hadronize (hadrons, particle_set, valid) import class(hadrons_t), intent(inout) :: hadrons type(particle_set_t), intent(in) :: particle_set logical, intent(out) :: valid end subroutine hadrons_hadronize end interface @ %def hadrons_hadronize @ <>= procedure (hadrons_make_particle_set), deferred :: make_particle_set <>= abstract interface subroutine hadrons_make_particle_set (hadrons, particle_set, & model, valid) import class(hadrons_t), intent(in) :: hadrons type(particle_set_t), intent(inout) :: particle_set class(model_data_t), intent(in), target :: model logical, intent(out) :: valid end subroutine hadrons_make_particle_set end interface @ %def hadrons_make_particle_set @ <>= procedure :: import_rng => hadrons_import_rng <>= pure subroutine hadrons_import_rng (hadrons, rng) class(hadrons_t), intent(inout) :: hadrons class(rng_t), intent(inout), allocatable :: rng call move_alloc (from = rng, to = hadrons%rng) end subroutine hadrons_import_rng @ %def hadrons_import_rng @ \subsection{[[WHIZARD]] Hadronization Type} Hadronization can be (incompletely) performed through \whizard's internal routine. <>= public :: hadrons_hadrons_t <>= type, extends (hadrons_t) :: hadrons_hadrons_t contains <> end type hadrons_hadrons_t @ %def hadrons_hadrons_t @ <>= procedure :: init => hadrons_hadrons_init <>= subroutine hadrons_hadrons_init & (hadrons, shower_settings, hadron_settings, model_hadrons) class(hadrons_hadrons_t), intent(out) :: hadrons type(shower_settings_t), intent(in) :: shower_settings type(hadron_settings_t), intent(in) :: hadron_settings type(model_t), intent(in), target :: model_hadrons hadrons%model => model_hadrons hadrons%shower_settings = shower_settings hadrons%hadron_settings = hadron_settings call msg_message & ("Hadronization: WHIZARD model for hadronization and decays") end subroutine hadrons_hadrons_init @ %def hadrons_hadrons_init @ <>= procedure :: hadronize => hadrons_hadrons_hadronize <>= subroutine hadrons_hadrons_hadronize (hadrons, particle_set, valid) class(hadrons_hadrons_t), intent(inout) :: hadrons type(particle_set_t), intent(in) :: particle_set logical, intent(out) :: valid integer, dimension(:), allocatable :: cols, acols, octs integer :: n if (signal_is_pending ()) return if (debug_on) call msg_debug (D_TRANSFORMS, "hadrons_hadrons_hadronize") call particle_set%write (6, compressed=.true.) n = particle_set%get_n_tot () allocate (cols (n), acols (n), octs (n)) call extract_color_systems (particle_set, cols, acols, octs) print *, "size(cols) = ", size (cols) if (size(cols) > 0) then print *, "cols = ", cols end if print *, "size(acols) = ", size(acols) if (size(acols) > 0) then print *, "acols = ", acols end if print *, "size(octs) = ", size(octs) if (size (octs) > 0) then print *, "octs = ", octs end if !!! if all arrays are empty, i.e. zero particles found, nothing to do end subroutine hadrons_hadrons_hadronize @ %def hadrons_hadrons_hadronize @ This type contains a flavor selector for the creation of hadrons, including parameters for the special handling of baryons. <>= public :: had_flav_t <>= type had_flav_t end type had_flav_t @ %def had_flav_t @ This is the type for the ends of Lund strings. <>= public :: lund_end <>= type lund_end logical :: from_pos integer :: i_end integer :: i_max integer :: id_had integer :: i_pos_old integer :: i_neg_old integer :: i_pos_new integer :: i_neg_new real(default) :: px_old real(default) :: py_old real(default) :: px_new real(default) :: py_new real(default) :: px_had real(default) :: py_had real(default) :: m_had real(default) :: mT2_had real(default) :: z_had real(default) :: gamma_old real(default) :: gamma_new real(default) :: x_pos_old real(default) :: x_pos_new real(default) :: x_pos_had real(default) :: x_neg_old real(default) :: x_neg_new real(default) :: x_neg_had type(had_flav_t) :: old_flav type(had_flav_t) :: new_flav type(vector4_t) :: p_had type(vector4_t) :: p_pre end type lund_end @ %def lund_end @ Generator for transverse momentum for the fragmentation. <>= public :: lund_pt_t <>= type lund_pt_t real(default) :: sigma_min real(default) :: sigma_q real(default) :: enhanced_frac real(default) :: enhanced_width real(default) :: sigma_to_had class(rng_t), allocatable :: rng contains <> end type lund_pt_t @ %def lund_pt <>= procedure :: init => lund_pt_init <>= subroutine lund_pt_init (lund_pt, settings) class (lund_pt_t), intent(out) :: lund_pt type(hadron_settings_t), intent(in) :: settings end subroutine lund_pt_init @ %def lund_pt_init @ <>= procedure :: make_particle_set => hadrons_hadrons_make_particle_set <>= subroutine hadrons_hadrons_make_particle_set & (hadrons, particle_set, model, valid) class(hadrons_hadrons_t), intent(in) :: hadrons type(particle_set_t), intent(inout) :: particle_set class(model_data_t), intent(in), target :: model logical, intent(out) :: valid if (signal_is_pending ()) return valid = .false. if (valid) then else call msg_fatal ("WHIZARD hadronization not yet implemented") end if end subroutine hadrons_hadrons_make_particle_set @ %def hadrons_hadrons_make_particle_set @ <>= subroutine extract_color_systems (p_set, cols, acols, octs) type(particle_set_t), intent(in) :: p_set integer, dimension(:), allocatable, intent(out) :: cols, acols, octs logical, dimension(:), allocatable :: mask integer :: i, n, n_cols, n_acols, n_octs n = p_set%get_n_tot () allocate (mask (n)) do i = 1, n mask(i) = p_set%prt(i)%col%get_col () /= 0 .and. & p_set%prt(i)%col%get_acl () == 0 .and. & p_set%prt(i)%get_status () == PRT_OUTGOING end do n_cols = count (mask) allocate (cols (n_cols)) cols = p_set%get_indices (mask) do i = 1, n mask(i) = p_set%prt(i)%col%get_col () == 0 .and. & p_set%prt(i)%col%get_acl () /= 0 .and. & p_set%prt(i)%get_status () == PRT_OUTGOING end do n_acols = count (mask) allocate (acols (n_acols)) acols = p_set%get_indices (mask) do i = 1, n mask(i) = p_set%prt(i)%col%get_col () /= 0 .and. & p_set%prt(i)%col%get_acl () /= 0 .and. & p_set%prt(i)%get_status () == PRT_OUTGOING end do n_octs = count (mask) allocate (octs (n_octs)) octs = p_set%get_indices (mask) end subroutine extract_color_systems @ %def extract_color_systems @ \subsection{[[PYTHIA6]] Hadronization Type} Hadronization via [[PYTHIA6]] is at another option for hadronization within \whizard. <>= public :: hadrons_pythia6_t <>= type, extends (hadrons_t) :: hadrons_pythia6_t contains <> end type hadrons_pythia6_t @ %def hadrons_pythia6_t <>= procedure :: init => hadrons_pythia6_init <>= subroutine hadrons_pythia6_init & (hadrons, shower_settings, hadron_settings, model_hadrons) class(hadrons_pythia6_t), intent(out) :: hadrons type(shower_settings_t), intent(in) :: shower_settings type(hadron_settings_t), intent(in) :: hadron_settings type(model_t), intent(in), target :: model_hadrons logical :: pygive_not_set_by_shower hadrons%model => model_hadrons hadrons%shower_settings = shower_settings hadrons%hadron_settings = hadron_settings pygive_not_set_by_shower = .not. (shower_settings%method == PS_PYTHIA6 & .and. (shower_settings%isr_active .or. shower_settings%fsr_active)) if (pygive_not_set_by_shower) then call pythia6_set_verbose (shower_settings%verbose) call pythia6_set_config (shower_settings%pythia6_pygive) end if call msg_message & ("Hadronization: Using PYTHIA6 interface for hadronization and decays") end subroutine hadrons_pythia6_init @ %def hadrons_pythia6_init @ Assume that the event record is still in the PYTHIA COMMON BLOCKS transferred there by the WHIZARD or PYTHIA6 shower routines. <>= procedure :: hadronize => hadrons_pythia6_hadronize <>= subroutine hadrons_pythia6_hadronize (hadrons, particle_set, valid) class(hadrons_pythia6_t), intent(inout) :: hadrons type(particle_set_t), intent(in) :: particle_set logical, intent(out) :: valid integer :: N, NPAD, K real(double) :: P, V common /PYJETS/ N, NPAD, K(4000,5), P(4000,5), V(4000,5) save /PYJETS/ if (signal_is_pending ()) return if (debug_on) call msg_debug (D_TRANSFORMS, "hadrons_pythia6_hadronize") call pygive ("MSTP(111)=1") !!! Switch on hadronization and decays call pygive ("MSTJ(1)=1") !!! String fragmentation call pygive ("MSTJ(21)=2") !!! String fragmentation keeping resonance momentum call pygive ("MSTJ(28)=0") !!! Switch off tau decays if (debug_active (D_TRANSFORMS)) then call msg_debug (D_TRANSFORMS, "N", N) call pylist(2) print *, ' line 7 : ', k(7,1:5), p(7,1:5) end if call pyedit (12) call pythia6_set_last_treated_line (N) call pyexec () call pyedit (12) valid = .true. end subroutine hadrons_pythia6_hadronize @ %def hadrons_pythia6_hadronize @ <>= procedure :: make_particle_set => hadrons_pythia6_make_particle_set <>= subroutine hadrons_pythia6_make_particle_set & (hadrons, particle_set, model, valid) class(hadrons_pythia6_t), intent(in) :: hadrons type(particle_set_t), intent(inout) :: particle_set class(model_data_t), intent(in), target :: model logical, intent(out) :: valid if (signal_is_pending ()) return valid = pythia6_handle_errors () if (valid) then call pythia6_combine_with_particle_set & (particle_set, model, hadrons%model, hadrons%shower_settings) end if end subroutine hadrons_pythia6_make_particle_set @ %def hadrons_pythia6_make_particle_set @ \subsection{[[PYTHIA8]] Hadronization} @ <>= public :: hadrons_pythia8_t <>= type, extends (hadrons_t) :: hadrons_pythia8_t type(pythia8_t) :: pythia type(whizard_lha_t) :: lhaup logical :: user_process_set = .false. logical :: pythia_initialized = .false., & lhaup_initialized = .false. contains <> end type hadrons_pythia8_t @ %def hadrons_pythia8_t @ <>= procedure :: init => hadrons_pythia8_init <>= subroutine hadrons_pythia8_init & (hadrons, shower_settings, hadron_settings, model_hadrons) class(hadrons_pythia8_t), intent(out) :: hadrons type(shower_settings_t), intent(in) :: shower_settings type(hadron_settings_t), intent(in) :: hadron_settings type(model_t), intent(in), target :: model_hadrons hadrons%model => model_hadrons hadrons%shower_settings = shower_settings hadrons%hadron_settings = hadron_settings call msg_message & ("Hadronization: Using PYTHIA8 interface for hadronization and decays.") ! TODO sbrass which verbose? call hadrons%pythia%init (verbose = shower_settings%verbose) call hadrons%lhaup%init () end subroutine hadrons_pythia8_init @ %def hadrons_pythia8_init @ Transfer hadron settings to [[PYTHIA8]]. <>= procedure, private :: transfer_settings => hadrons_pythia8_transfer_settings <>= subroutine hadrons_pythia8_transfer_settings (hadrons) class(hadrons_pythia8_t), intent(inout), target :: hadrons real(default) :: r if (debug_on) call msg_debug (D_TRANSFORMS, "hadrons_pythia8_transfer_settings") if (debug_on) call msg_debug2 (D_TRANSFORMS, "pythia_initialized", hadrons%pythia_initialized) if (hadrons%pythia_initialized) return call hadrons%pythia%import_rng (hadrons%rng) call hadrons%pythia%parse_and_set_config (hadrons%shower_settings%pythia8_config) if (len (hadrons%shower_settings%pythia8_config_file) > 0) & call hadrons%pythia%read_file (hadrons%shower_settings%pythia8_config_file) call hadrons%pythia%read_string (var_str ("Beams:frameType = 5")) call hadrons%pythia%read_string (var_str ("ProcessLevel:all = off")) if (.not. hadrons%shower_settings%verbose) then call hadrons%pythia%read_string (var_str ("Print:quiet = on")) end if call hadrons%pythia%set_lhaup_ptr (hadrons%lhaup) call hadrons%pythia%init_pythia () hadrons%pythia_initialized = .true. end subroutine hadrons_pythia8_transfer_settings @ %def hadrons_pythia8_transfer_settings @ Set user process for the LHA interface. <>= procedure, private :: set_user_process => hadrons_pythia8_set_user_process <>= subroutine hadrons_pythia8_set_user_process (hadrons, pset) class(hadrons_pythia8_t), intent(inout) :: hadrons type(particle_set_t), intent(in) :: pset integer, dimension(2) :: beam_pdg real(default), dimension(2) :: beam_energy integer, parameter :: process_id = 0, n_processes = 0 if (debug_on) call msg_debug (D_TRANSFORMS, "hadrons_pythia8_set_user_process") beam_pdg = [pset%prt(1)%get_pdg (), pset%prt(2)%get_pdg ()] beam_energy = [energy(pset%prt(1)%p), energy(pset%prt(2)%p)] call hadrons%lhaup%set_init (beam_pdg, beam_energy, & n_processes, unweighted = .false., negative_weights = .false.) call hadrons%lhaup%set_process_parameters (process_id = process_id, & cross_section = one, error = one) end subroutine hadrons_pythia8_set_user_process @ %def hadrons_pythia8_set_user_process @ Import particle set. <>= procedure, private :: import_particle_set => hadrons_pythia8_import_particle_set <>= subroutine hadrons_pythia8_import_particle_set (hadrons, particle_set) class(hadrons_pythia8_t), target, intent(inout) :: hadrons type(particle_set_t), intent(in) :: particle_set type(particle_set_t) :: pset_reduced integer, parameter :: PROCESS_ID = 1 if (debug_on) call msg_debug (D_TRANSFORMS, "hadrons_pythia8_import_particle_set") if (.not. hadrons%user_process_set) then call hadrons%set_user_process (particle_set) hadrons%user_process_set = .true. end if call hadrons%lhaup%set_event_process (process_id = PROCESS_ID, scale = -one, & alpha_qcd = -one, alpha_qed = -one, weight = -one) call hadrons%lhaup%set_event (process_id = PROCESS_ID, particle_set = particle_set, & polarization = .true.) if (debug_active (D_TRANSFORMS)) then call hadrons%lhaup%list_init () end if end subroutine hadrons_pythia8_import_particle_set @ %def hadrons_pythia8_import_particle_set @ <>= procedure :: hadronize => hadrons_pythia8_hadronize <>= subroutine hadrons_pythia8_hadronize (hadrons, particle_set, valid) class(hadrons_pythia8_t), intent(inout) :: hadrons type(particle_set_t), intent(in) :: particle_set logical, intent(out) :: valid if (signal_is_pending ()) return call hadrons%import_particle_set (particle_set) if (.not. hadrons%pythia_initialized) & call hadrons%transfer_settings () call hadrons%pythia%next (valid) if (debug_active (D_TRANSFORMS)) then call hadrons%pythia%list_event () call particle_set%write (summary=.true., compressed=.true.) end if end subroutine hadrons_pythia8_hadronize @ %def hadrons_pythia8_hadronize @ <>= procedure :: make_particle_set => hadrons_pythia8_make_particle_set <>= subroutine hadrons_pythia8_make_particle_set & (hadrons, particle_set, model, valid) class(hadrons_pythia8_t), intent(in) :: hadrons type(particle_set_t), intent(inout) :: particle_set class(model_data_t), intent(in), target :: model logical, intent(out) :: valid type(particle_t), dimension(:), allocatable :: beam if (debug_on) call msg_debug (D_TRANSFORMS, "hadrons_pythia8_make_particle_set") if (signal_is_pending ()) return associate (settings => hadrons%shower_settings) if (debug_active (D_TRANSFORMS)) then call msg_debug (D_TRANSFORMS, 'Combine PYTHIA8 with particle set') call msg_debug (D_TRANSFORMS, 'Particle set before replacing') call particle_set%write (summary=.true., compressed=.true.) call hadrons%pythia%list_event () call msg_debug (D_TRANSFORMS, string = "settings%hadron_collision", & value = settings%hadron_collision) end if call hadrons%pythia%get_hadron_particles (& model, hadrons%model, particle_set, & helicity = PRT_DEFINITE_HELICITY) end associate if (debug_active (D_TRANSFORMS)) then print *, 'Particle set after replacing' call particle_set%write (summary=.true., compressed=.true.) end if valid = .true. end subroutine hadrons_pythia8_make_particle_set @ %def hadrons_pythia8_make_particle_set @ \subsection{Hadronization Event Transform} This is the type for the hadronization event transform. It does not depend on the specific hadronization implementation of [[hadrons_t]]. <>= public :: evt_hadrons_t <>= type, extends (evt_t) :: evt_hadrons_t class(hadrons_t), allocatable :: hadrons type(model_t), pointer :: model_hadrons => null() type(qcd_t) :: qcd logical :: is_first_event contains <> end type evt_hadrons_t @ %def evt_hadrons_t @ Initialize the parameters. The [[model_hadrons]] is supposed to be the SM variant that contains all hadrons that may be generated in the shower. <>= procedure :: init => evt_hadrons_init <>= subroutine evt_hadrons_init (evt, model_hadrons) class(evt_hadrons_t), intent(out) :: evt type(model_t), intent(in), target :: model_hadrons evt%model_hadrons => model_hadrons evt%is_first_event = .true. end subroutine evt_hadrons_init @ %def evt_hadrons_init @ <>= procedure :: write_name => evt_hadrons_write_name <>= subroutine evt_hadrons_write_name (evt, unit) class(evt_hadrons_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: hadronization" end subroutine evt_hadrons_write_name @ %def evt_hadrons_write_name @ Output. <>= procedure :: write => evt_hadrons_write <>= subroutine evt_hadrons_write (evt, unit, verbose, more_verbose, testflag) class(evt_hadrons_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u) call evt%base_write (u, testflag = testflag, show_set = .false.) if (evt%particle_set_exists) & call evt%particle_set%write & (u, summary = .true., compressed = .true., testflag = testflag) call write_separator (u) call evt%hadrons%shower_settings%write (u) call write_separator (u) call evt%hadrons%hadron_settings%write (u) end subroutine evt_hadrons_write @ %def evt_hadrons_write @ <>= procedure :: first_event => evt_hadrons_first_event <>= subroutine evt_hadrons_first_event (evt) class(evt_hadrons_t), intent(inout) :: evt if (debug_on) call msg_debug (D_TRANSFORMS, "evt_hadrons_first_event") associate (settings => evt%hadrons%shower_settings) settings%hadron_collision = .false. !!! !!! !!! Workaround for PGF90 16.1 !!! if (all (evt%particle_set%prt(1:2)%flv%get_pdg_abs () <= 39)) then if (evt%particle_set%prt(1)%flv%get_pdg_abs () <= 39 .and. & evt%particle_set%prt(2)%flv%get_pdg_abs () <= 39) then settings%hadron_collision = .false. !!! else if (all (evt%particle_set%prt(1:2)%flv%get_pdg_abs () >= 100)) then else if (evt%particle_set%prt(1)%flv%get_pdg_abs () >= 100 .and. & evt%particle_set%prt(2)%flv%get_pdg_abs () >= 100) then settings%hadron_collision = .true. else call msg_fatal ("evt_hadrons didn't recognize beams setup") end if if (debug_on) call msg_debug (D_TRANSFORMS, "hadron_collision", settings%hadron_collision) if (.not. (settings%isr_active .or. settings%fsr_active)) then call msg_fatal ("Hadronization without shower is not supported") end if end associate evt%is_first_event = .false. end subroutine evt_hadrons_first_event @ %def evt_hadrons_first_event @ Here we take the particle set from the previous event transform and apply the hadronization. The result is stored in the [[evt%hadrons]] object. We always return a probability of unity as we don't have the analytic weight of the hadronization. Invalid events have to be discarded by the caller which is why we mark the particle set as invalid. <>= procedure :: generate_weighted => evt_hadrons_generate_weighted <>= subroutine evt_hadrons_generate_weighted (evt, probability) class(evt_hadrons_t), intent(inout) :: evt real(default), intent(inout) :: probability logical :: valid if (signal_is_pending ()) return evt%particle_set = evt%previous%particle_set if (evt%is_first_event) then call evt%first_event () end if call evt%hadrons%hadronize (evt%particle_set, valid) probability = 1 evt%particle_set_exists = valid end subroutine evt_hadrons_generate_weighted @ %def evt_hadrons_generate_weighted @ The factorization parameters are irrelevant. <>= procedure :: make_particle_set => evt_hadrons_make_particle_set <>= subroutine evt_hadrons_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_hadrons_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r logical :: valid call evt%hadrons%make_particle_set (evt%particle_set, evt%model, valid) evt%particle_set_exists = evt%particle_set_exists .and. valid end subroutine evt_hadrons_make_particle_set @ %def event_hadrons_make_particle_set @ Connect the process with the hadrons object. <>= procedure :: connect => evt_hadrons_connect <>= subroutine evt_hadrons_connect & (evt, process_instance, model, process_stack) class(evt_hadrons_t), intent(inout), target :: evt type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack call evt%base_connect (process_instance, model, process_stack) call evt%make_rng (evt%process) end subroutine evt_hadrons_connect @ %def evt_hadrons_connect @ Create RNG instances, spawned by the process object. <>= procedure :: make_rng => evt_hadrons_make_rng <>= subroutine evt_hadrons_make_rng (evt, process) class(evt_hadrons_t), intent(inout) :: evt type(process_t), intent(inout) :: process class(rng_t), allocatable :: rng call process%make_rng (rng) call evt%hadrons%import_rng (rng) end subroutine evt_hadrons_make_rng @ %def evt_hadrons_make_rng @ <>= procedure :: prepare_new_event => evt_hadrons_prepare_new_event <>= subroutine evt_hadrons_prepare_new_event (evt, i_mci, i_term) class(evt_hadrons_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () end subroutine evt_hadrons_prepare_new_event @ %def evt_hadrons_prepare_new_event @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Resonance Insertion} <<[[resonance_insertion.f90]]>>= <> module resonance_insertion <> <> use io_units use format_utils, only: write_separator use format_defs, only: FMT_12 use rng_base, only: rng_t use selectors, only: selector_t use sm_qcd use model_data use interactions, only: interaction_t use particles, only: particle_t, particle_set_t use subevents, only: PRT_RESONANT use models use resonances, only: resonance_history_set_t use resonances, only: resonance_tree_t use instances, only: process_instance_ptr_t use event_transforms <> <> <> contains <> end module resonance_insertion @ %def resonance_insertion @ \subsection{Resonance-Insertion Event Transform} This is the type for the event transform that applies resonance insertion. The resonance history set describe the resonance histories that we may consider. There is a process library with process objects that correspond to the resonance histories. Library creation, compilation etc.\ is done outside the scope of this module. <>= public :: evt_resonance_t <>= type, extends (evt_t) :: evt_resonance_t type(resonance_history_set_t), dimension(:), allocatable :: res_history_set integer, dimension(:), allocatable :: index_offset integer :: selected_component = 0 type(string_t) :: libname type(string_t), dimension(:), allocatable :: proc_id real(default) :: on_shell_limit = 0 real(default) :: on_shell_turnoff = 0 real(default) :: background_factor = 1 logical :: selector_active = .false. type(selector_t) :: selector integer :: selected_history = 0 type(process_instance_ptr_t), dimension(:), allocatable :: instance contains <> end type evt_resonance_t @ %def evt_resonance_t <>= procedure :: write_name => evt_resonance_write_name <>= subroutine evt_resonance_write_name (evt, unit) class(evt_resonance_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: resonance insertion" end subroutine evt_resonance_write_name @ %def evt_resonance_write_name @ Output. <>= procedure :: write => evt_resonance_write <>= subroutine evt_resonance_write (evt, unit, verbose, more_verbose, testflag) class(evt_resonance_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u, i u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u, 2) write (u, "(1x,A,A,A)") "Process library = '", char (evt%libname), "'" if (allocated (evt%res_history_set)) then do i = 1, size (evt%res_history_set) if (i == evt%selected_component) then write (u, "(1x,A,I0,A)") "Component #", i, ": *" else write (u, "(1x,A,I0,A)") "Component #", i, ":" end if call evt%res_history_set(i)%write (u, indent=1) end do end if call write_separator (u) if (allocated (evt%instance)) then write (u, "(1x,A)") "Subprocess instances: allocated" else write (u, "(1x,A)") "Subprocess instances: not allocated" end if if (evt%particle_set_exists) then if (evt%selected_history > 0) then write (u, "(1x,A,I0)") "Selected: resonance history #", & evt%selected_history else write (u, "(1x,A)") "Selected: no resonance history" end if else write (u, "(1x,A)") "Selected: [none]" end if write (u, "(1x,A,1x," // FMT_12 // ")") & "On-shell limit =", evt%on_shell_limit write (u, "(1x,A,1x," // FMT_12 // ")") & "On-shell turnoff =", evt%on_shell_turnoff write (u, "(1x,A,1x," // FMT_12 // ")") & "Background factor =", evt%background_factor call write_separator (u) if (evt%selector_active) then write (u, "(2x)", advance="no") call evt%selector%write (u, testflag=testflag) call write_separator (u) end if call evt%base_write (u, testflag = testflag, show_set = .false.) call write_separator (u) if (evt%particle_set_exists) then call evt%particle_set%write & (u, summary = .true., compressed = .true., testflag = testflag) call write_separator (u) end if end subroutine evt_resonance_write @ %def evt_resonance_write @ \subsection{Set contained data} Insert the resonance data, in form of a pre-generated resonance history set. Accumulate the number of histories for each set, to initialize an array of index offsets for lookup. <>= procedure :: set_resonance_data => evt_resonance_set_resonance_data <>= subroutine evt_resonance_set_resonance_data (evt, res_history_set) class(evt_resonance_t), intent(inout) :: evt type(resonance_history_set_t), dimension(:), intent(in) :: res_history_set integer :: i evt%res_history_set = res_history_set allocate (evt%index_offset (size (evt%res_history_set)), source = 0) do i = 2, size (evt%res_history_set) evt%index_offset(i) = & evt%index_offset(i-1) + evt%res_history_set(i-1)%get_n_history () end do end subroutine evt_resonance_set_resonance_data @ %def evt_resonance_set_resonance_data @ Set the library that contains the resonant subprocesses. <>= procedure :: set_library => evt_resonance_set_library <>= subroutine evt_resonance_set_library (evt, libname) class(evt_resonance_t), intent(inout) :: evt type(string_t), intent(in) :: libname evt%libname = libname end subroutine evt_resonance_set_library @ %def evt_resonance_set_library @ Assign pointers to subprocess instances. Once a subprocess has been selected, the instance is used for generating the particle set with valid quantum-number assignments, ready for resonance insertion. <>= procedure :: set_subprocess_instances & => evt_resonance_set_subprocess_instances <>= subroutine evt_resonance_set_subprocess_instances (evt, instance) class(evt_resonance_t), intent(inout) :: evt type(process_instance_ptr_t), dimension(:), intent(in) :: instance evt%instance = instance end subroutine evt_resonance_set_subprocess_instances @ %def evt_resonance_set_subprocess_instances @ Set the on-shell limit, the relative distance from a resonance that is still considered to be on-shell. The probability for being considered on-shell can be reduced by the turnoff parameter below. For details, see the [[resonances]] module. <>= procedure :: set_on_shell_limit => evt_resonance_set_on_shell_limit <>= subroutine evt_resonance_set_on_shell_limit (evt, on_shell_limit) class(evt_resonance_t), intent(inout) :: evt real(default), intent(in) :: on_shell_limit evt%on_shell_limit = on_shell_limit end subroutine evt_resonance_set_on_shell_limit @ %def evt_resonance_set_on_shell_limit @ Set the Gaussian on-shell turnoff parameter, the width of the weighting factor for the resonance squared matrix element. If the resonance is off shell, this factor reduces the weight of the matrix element in the selector, such that the probability for considered resonant is reduced. The factor is applied only if the offshellness is less than the [[on_shell_limit]] above. For details, see the [[resonances]] module. <>= procedure :: set_on_shell_turnoff => evt_resonance_set_on_shell_turnoff <>= subroutine evt_resonance_set_on_shell_turnoff (evt, on_shell_turnoff) class(evt_resonance_t), intent(inout) :: evt real(default), intent(in) :: on_shell_turnoff evt%on_shell_turnoff = on_shell_turnoff end subroutine evt_resonance_set_on_shell_turnoff @ %def evt_resonance_set_on_shell_turnoff @ Reweight (suppress) the background contribution if there is a resonance history that applies. The event will be registered as background if there is no applicable resonance history, or if the background configuration has been selected based on (reweighted) squared matrix elements. <>= procedure :: set_background_factor => evt_resonance_set_background_factor <>= subroutine evt_resonance_set_background_factor (evt, background_factor) class(evt_resonance_t), intent(inout) :: evt real(default), intent(in) :: background_factor evt%background_factor = background_factor end subroutine evt_resonance_set_background_factor @ %def evt_resonance_set_background_factor @ \subsection{Selector} Manually import a random-number generator object. This should be done only for testing purposes. The standard procedure is to [[connect]] a process to an event transform; this will create an appropriate [[rng]] from the RNG factory in the process object. <>= procedure :: import_rng => evt_resonance_import_rng <>= subroutine evt_resonance_import_rng (evt, rng) class(evt_resonance_t), intent(inout) :: evt class(rng_t), allocatable, intent(inout) :: rng call move_alloc (from = rng, to = evt%rng) end subroutine evt_resonance_import_rng @ %def evt_resonance_import_rng @ We use a standard selector object to choose from the available resonance histories. If the selector is inactive, we do not insert resonances. <>= procedure :: write_selector => evt_resonance_write_selector <>= subroutine evt_resonance_write_selector (evt, unit, testflag) class(evt_resonance_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (evt%selector_active) then call evt%selector%write (u, testflag) else write (u, "(1x,A)") "Selector: [inactive]" end if end subroutine evt_resonance_write_selector @ %def evt_resonance_write_selector @ The selector is initialized with relative weights of histories which need not be normalized. Channels with weight zero are ignored. The [[offset]] will normally be $-1$, so we count from zero, and zero is a valid result from the selector. Selecting the zero entry implies no resonance insertion. However, this behavior is not hard-coded here (without offset, no resonance is not possible as a result). <>= procedure :: init_selector => evt_resonance_init_selector <>= subroutine evt_resonance_init_selector (evt, weight, offset) class(evt_resonance_t), intent(inout) :: evt real(default), dimension(:), intent(in) :: weight integer, intent(in), optional :: offset if (any (weight > 0)) then call evt%selector%init (weight, offset = offset) evt%selector_active = .true. else evt%selector_active = .false. end if end subroutine evt_resonance_init_selector @ %def evt_resonance_init_selector @ Return all selector weights, for inspection. Note that the index counts from zero. <>= procedure :: get_selector_weights => evt_resonance_get_selector_weights <>= subroutine evt_resonance_get_selector_weights (evt, weight) class(evt_resonance_t), intent(in) :: evt real(default), dimension(0:), intent(out) :: weight integer :: i do i = 0, ubound (weight,1) weight(i) = evt%selector%get_weight (i) end do end subroutine evt_resonance_get_selector_weights @ %def evt_resonance_get_selector_weights @ \subsection{Runtime calculations} Use the associated master process instance and the subprocess instances to distribute the current momentum set, then compute the squared matrix elements weights for all subprocesses. NOTE: Procedures in this subsection are not covered by unit tests in this module, but by unit tests of the [[restricted_subprocesses]] module. Fill the particle set, so the momentum configuration can be used by the subprocess instances. The standard workflow is to copy from the previous particle set. <>= procedure :: fill_momenta => evt_resonance_fill_momenta <>= subroutine evt_resonance_fill_momenta (evt) class(evt_resonance_t), intent(inout) :: evt integer :: i, n if (associated (evt%previous)) then evt%particle_set = evt%previous%particle_set else if (associated (evt%process_instance)) then ! this branch only for unit test call evt%process_instance%get_trace & (evt%particle_set, i_term=1, n_incoming=evt%process%get_n_in ()) end if end subroutine evt_resonance_fill_momenta @ %def evt_resonance_fill_momenta @ Return the indices of those subprocesses which can be considered on-shell. The result depends on the stored particle set (outgoing momenta) and on the on-shell limit value. The index [[evt%selected_component]] identifies the particular history set that corresponds to the given process component. Recall that process components may have different external particles, so they have distinct history sets. <>= procedure :: determine_on_shell_histories & => evt_resonance_determine_on_shell_histories <>= subroutine evt_resonance_determine_on_shell_histories & (evt, index_array) class(evt_resonance_t), intent(in) :: evt integer, dimension(:), allocatable, intent(out) :: index_array integer :: i i = evt%selected_component call evt%res_history_set(i)%determine_on_shell_histories & (evt%particle_set%get_outgoing_momenta (), & evt%on_shell_limit, & index_array) end subroutine evt_resonance_determine_on_shell_histories @ %def evt_resonance_determine_on_shell_histories @ Evaluate selected subprocesses. (In actual operation, the ones that have been tagged as on-shell.) We assume that the MCI, term, and channel indices for the subprocesses can all be set to 1. <>= procedure :: evaluate_subprocess => evt_resonance_evaluate_subprocess <>= subroutine evt_resonance_evaluate_subprocess (evt, index_array) class(evt_resonance_t), intent(inout) :: evt integer, dimension(:), intent(in) :: index_array integer :: k, i if (allocated (evt%instance)) then do k = 1, size (index_array) i = index_array(k) associate (instance => evt%instance(i)%p) call instance%choose_mci (1) call instance%set_trace (evt%particle_set, 1, check_match=.false.) call instance%recover (channel = 1, i_term = 1, & update_sqme = .true., recover_phs = .false.) end associate end do end if end subroutine evt_resonance_evaluate_subprocess @ %def evt_resonance_evaluate_subprocess @ Return the current squared matrix-element value of the master process, and of the selected resonant subprocesses, respectively. <>= procedure :: get_master_sqme => evt_resonance_get_master_sqme procedure :: get_subprocess_sqme => evt_resonance_get_subprocess_sqme <>= function evt_resonance_get_master_sqme (evt) result (sqme) class(evt_resonance_t), intent(in) :: evt real(default) :: sqme sqme = evt%process_instance%get_sqme () end function evt_resonance_get_master_sqme subroutine evt_resonance_get_subprocess_sqme (evt, sqme, index_array) class(evt_resonance_t), intent(in) :: evt real(default), dimension(:), intent(out) :: sqme integer, dimension(:), intent(in), optional :: index_array integer :: k, i if (present (index_array)) then sqme = 0 do k = 1, size (index_array) call get_sqme (index_array(k)) end do else do i = 1, size (evt%instance) call get_sqme (i) end do end if contains subroutine get_sqme (i) integer, intent(in) :: i associate (instance => evt%instance(i)%p) sqme(i) = instance%get_sqme () end associate end subroutine get_sqme end subroutine evt_resonance_get_subprocess_sqme @ %def evt_resonance_get_master_sqme @ %def evt_resonance_get_subprocess_sqme @ Apply a turnoff factor for off-shell kinematics to the [[sqme]] values. The [[sqme]] array indices are offset from the resonance history set entries. <>= procedure :: apply_turnoff_factor => evt_resonance_apply_turnoff_factor <>= subroutine evt_resonance_apply_turnoff_factor (evt, sqme, index_array) class(evt_resonance_t), intent(in) :: evt real(default), dimension(:), intent(inout) :: sqme integer, dimension(:), intent(in) :: index_array integer :: k, i_res, i_prc do k = 1, size (index_array) i_res = evt%selected_component i_prc = index_array(k) + evt%index_offset(i_res) sqme(i_prc) = sqme(i_prc) & * evt%res_history_set(i_res)%evaluate_gaussian & & (evt%particle_set%get_outgoing_momenta (), & & evt%on_shell_turnoff, index_array(k)) end do end subroutine evt_resonance_apply_turnoff_factor @ %def evt_resonance_apply_turnoff_factor @ We use the calculations of resonant matrix elements to determine probabilities for all applicable resonance configurations. This method combines the steps implemented above. First, we determine the selected process component. TODO: the version below selects the first component which is found active. This make sense only for standard LO process components, where exactly one component corresponds to a MCI set. For the selected process component, we query the kinematics and determine the applicable resonance histories. We collect squared matrix elements for those resonance histories and compare them to the master-process squared matrix element. The result is the probability for each resonance history together with the probability for non-resonant background (zeroth entry). The latter is defined as the difference between the complete process result and the sum of the resonances, ignoring the possibility for interference. If the complete process result is actually undershooting the sum of resonances, we nevertheless count the background with positive probability. When looking up the subprocess sqme, we must add the [[index_offset]] to the resulting array, since the indices returned by the individual history set all count from one, while the subprocess instances that belong to process components are collected in one flat array. After determining matrix elements and background, we may reduce the weight of the matrix elements in the selector by applying a turnoff factor. The factor [[background_factor]] indicates whether to include the background contribution at all, as long as there is a nonvanishing resonance contribution. Note that instead of setting background to zero, we just multiply it by a very small number. This ensures that indices are assigned correctly, and that background will eventually be selected if smooth turnoff is chosen. <>= procedure :: compute_probabilities => evt_resonance_compute_probabilities <>= subroutine evt_resonance_compute_probabilities (evt) class(evt_resonance_t), intent(inout) :: evt integer, dimension(:), allocatable :: index_array real(default) :: sqme_master, sqme_sum, sqme_bg real(default), dimension(:), allocatable :: sqme_res integer :: n, ic if (.not. associated (evt%process_instance)) return n = size (evt%instance) call evt%select_component (0) FIND_ACTIVE_COMPONENT: do ic = 1, evt%process%get_n_components () if (evt%process%component_is_selected (ic)) then call evt%select_component (ic) exit FIND_ACTIVE_COMPONENT end if end do FIND_ACTIVE_COMPONENT if (evt%selected_component > 0) then call evt%determine_on_shell_histories (index_array) else allocate (index_array (0)) end if call evt%evaluate_subprocess & (index_array + evt%index_offset(evt%selected_component)) allocate (sqme_res (n), source = 0._default) call evt%get_subprocess_sqme & (sqme_res, index_array + evt%index_offset(evt%selected_component)) sqme_master = evt%get_master_sqme () sqme_sum = sum (sqme_res) sqme_bg = abs (sqme_master - sqme_sum) if (evt%on_shell_turnoff > 0) then call evt%apply_turnoff_factor (sqme_res, index_array) end if if (any (sqme_res > 0)) then sqme_bg = sqme_bg * evt%background_factor end if call evt%init_selector ([sqme_bg, sqme_res], offset = -1) end subroutine evt_resonance_compute_probabilities @ %def evt_resonance_compute_probabilities @ Set the selected component (unit tests). <>= procedure :: select_component => evt_resonance_select_component <>= subroutine evt_resonance_select_component (evt, i_component) class(evt_resonance_t), intent(inout) :: evt integer, intent(in) :: i_component evt%selected_component = i_component end subroutine evt_resonance_select_component @ %def evt_resonance_select_component @ \subsection{Sanity check} Check the color assignment, which may be wrong for the inserted resonances. Delegated to the particle-set component. Return offending particle indices and, optionally, particles as arrays. This is done in a unit test. The current algorithm, i.e., selecting the color assignment from the resonant-subprocess instance, should not generate invalid color assignments. <>= procedure :: find_prt_invalid_color => evt_resonance_find_prt_invalid_color <>= subroutine evt_resonance_find_prt_invalid_color (evt, index, prt) class(evt_resonance_t), intent(in) :: evt integer, dimension(:), allocatable, intent(out) :: index type(particle_t), dimension(:), allocatable, intent(out), optional :: prt if (evt%particle_set_exists) then call evt%particle_set%find_prt_invalid_color (index, prt) else allocate (prt (0)) end if end subroutine evt_resonance_find_prt_invalid_color @ %def evt_resonance_find_prt_invalid_color @ \subsection{API implementation} <>= procedure :: prepare_new_event => evt_resonance_prepare_new_event <>= subroutine evt_resonance_prepare_new_event (evt, i_mci, i_term) class(evt_resonance_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () end subroutine evt_resonance_prepare_new_event @ %def evt_resonance_prepare_new_event @ Select one of the histories, based on the momentum array from the current particle set. Compute the probabilities for all resonant subprocesses and initialize the selector accordingly. Then select one resonance history, or none. <>= procedure :: generate_weighted => evt_resonance_generate_weighted <>= subroutine evt_resonance_generate_weighted (evt, probability) class(evt_resonance_t), intent(inout) :: evt real(default), intent(inout) :: probability call evt%fill_momenta () call evt%compute_probabilities () call evt%selector%generate (evt%rng, evt%selected_history) probability = 1 end subroutine evt_resonance_generate_weighted @ %def evt_resonance_generate_weighted @ Here take the current particle set and insert resonance intermediate states if applicable. The resonance history has already been chosen by the generator above. If no resonance history applies, just retain the particle set. If a resonance history applies, we factorize the exclusive interaction of the selected (resonance-process) process instance. With a temporary particle set [[prt_set]] as workspace, we the insert the resonances, reinstate parent-child relations and set colors and momenta for the resonances. The temporary is then copied back. Taking the event data from the resonant subprocess instead of the master process, guarantees that all flavor, helicity, and color assignments are valid for the selected resonance history. Note that the transform may thus choose a quantum-number combination that is different from the one chosen by the master process. The [[i_term]] value for the selected subprocess instance is always 1. We support only LO process. For those, the master process may have several terms (= components) that correspond to different external states. The subprocesses are distinct, each one corresponds to a definite master component, and by itself it consists of a single component/term. However, if the selector chooses resonance history \#0, i.e., no resonance, we just copy the particle set from the previous (i.e., trivial) event transform and ignore all subprocess data. <>= procedure :: make_particle_set => evt_resonance_make_particle_set <>= subroutine evt_resonance_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_resonance_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r type(particle_set_t), target :: prt_set type(particle_t), dimension(:), allocatable :: prt integer :: n_beam, n_in, n_vir, n_res, n_out, i, i_res, i_term, i_tree type(interaction_t), pointer :: int_matrix, int_flows integer, dimension(:), allocatable :: map type(resonance_tree_t) :: res_tree if (associated (evt%previous)) then if (evt%previous%particle_set_exists) then if (evt%selected_history > 0) then if (allocated (evt%instance)) then associate (instance => evt%instance(evt%selected_history)%p) call instance%evaluate_event_data (weight = 1._default) i_term = 1 int_matrix => instance%get_matrix_int_ptr (i_term) int_flows => instance%get_flows_int_ptr (i_term) call evt%factorize_interactions (int_matrix, int_flows, & factorization_mode, keep_correlations, r) call evt%tag_incoming () end associate else ! this branch only for unit test evt%particle_set = evt%previous%particle_set end if i_tree = evt%selected_history & - evt%index_offset(evt%selected_component) call evt%res_history_set(evt%selected_component)%get_tree & (i_tree, res_tree) n_beam = evt%particle_set%get_n_beam () n_in = evt%particle_set%get_n_in () n_vir = evt%particle_set%get_n_vir () n_out = evt%particle_set%get_n_out () n_res = res_tree%get_n_resonances () allocate (map (n_beam + n_in + n_vir + n_out)) map(1:n_beam+n_in+n_vir) & = [(i, i = 1, n_beam+n_in+n_vir)] map(n_beam+n_in+n_vir+1:n_beam+n_in+n_vir+n_out) & = [(i + n_res, & & i = n_beam+n_in+n_vir+1, & & n_beam+n_in+n_vir+n_out)] call prt_set%transfer (evt%particle_set, n_res, map) do i = 1, n_res i_res = n_beam + n_in + n_vir + i call prt_set%insert (i_res, & PRT_RESONANT, & res_tree%get_flv (i), & res_tree%get_children (i, & & n_beam+n_in+n_vir, n_beam+n_in+n_vir+n_res)) end do do i = n_res, 1, -1 i_res = n_beam + n_in + n_vir + i call prt_set%recover_color (i_res) end do call prt_set%set_momentum & (map(:), evt%particle_set%get_momenta (), on_shell = .true.) do i = n_res, 1, -1 i_res = n_beam + n_in + n_vir + i call prt_set%recover_momentum (i_res) end do call evt%particle_set%final () evt%particle_set = prt_set call prt_set%final () evt%particle_set_exists = .true. else ! retain particle set, as copied from previous evt evt%particle_set_exists = .true. end if else evt%particle_set_exists = .false. end if else evt%particle_set_exists = .false. end if end subroutine evt_resonance_make_particle_set @ %def event_resonance_make_particle_set @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[resonance_insertion_ut.f90]]>>= <> module resonance_insertion_ut use unit_tests use resonance_insertion_uti <> <> contains <> end module resonance_insertion_ut @ %def resonance_insertion_ut @ <<[[resonance_insertion_uti.f90]]>>= <> module resonance_insertion_uti <> <> use format_utils, only: write_separator use os_interface use lorentz use rng_base, only: rng_t use flavors, only: flavor_t use colors, only: color_t use models, only: syntax_model_file_init, syntax_model_file_final use models, only: model_list_t, model_t use particles, only: particle_t, particle_set_t use resonances, only: resonance_info_t use resonances, only: resonance_history_t use resonances, only: resonance_history_set_t use event_transforms use resonance_insertion use rng_base_ut, only: rng_test_t <> <> contains <> end module resonance_insertion_uti @ %def resonance_insertion_uti @ API: driver for the unit tests below. <>= public :: resonance_insertion_test <>= subroutine resonance_insertion_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine resonance_insertion_test @ %def resonance_insertion_test @ \subsubsection{Test resonance insertion as event transform} Insert a resonance (W boson) into an event with momentum assignment. <>= call test (resonance_insertion_1, "resonance_insertion_1", & "simple resonance insertion", & u, results) <>= public :: resonance_insertion_1 <>= subroutine resonance_insertion_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance type(flavor_t) :: fw type(color_t) :: col real(default) :: mw, ew, pw type(vector4_t), dimension(5) :: p class(rng_t), allocatable :: rng real(default) :: probability integer, dimension(:), allocatable :: i_invalid type(particle_t), dimension(:), allocatable :: prt_invalid integer :: i write (u, "(A)") "* Test output: resonance_insertion_1" write (u, "(A)") "* Purpose: apply simple resonance insertion" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) ! reset slightly in order to avoid a rounding ambiguity call model%set_real (var_str ("mW"), 80.418_default) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 3, & pdg = [1, -1, 1, -2, 24], model = model) call fw%init (24, model) mw = fw%get_mass () ew = 200._default pw = sqrt (ew**2 - mw**2) p(1) = vector4_moving (ew, ew, 3) p(2) = vector4_moving (ew,-ew, 3) p(3) = vector4_moving (ew/2, vector3_moving ([pw/2, mw/2, 0._default])) p(4) = vector4_moving (ew/2, vector3_moving ([pw/2,-mw/2, 0._default])) p(5) = vector4_moving (ew, vector3_moving ([-pw, 0._default, 0._default])) call pset%set_momentum (p, on_shell = .true.) call col%init_col_acl (1,0) call pset%set_color (1, col) call col%init_col_acl (0,1) call pset%set_color (2, col) call col%init_col_acl (2,0) call pset%set_color (3, col) call col%init_col_acl (0,2) call pset%set_color (4, col) call col%init_col_acl (0,0) call pset%set_color (5, col) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, -24, model, 2) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default]) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") call evt_resonance%find_prt_invalid_color (i_invalid, prt_invalid) write (u, "(A)") "Particles with invalid color:" select case (size (prt_invalid)) case (0) write (u, "(2x,A)") "[none]" case default do i = 1, size (prt_invalid) write (u, "(1x,A,1x,I0)", advance="no") "Particle", i_invalid(i) call prt_invalid(i)%write (u) end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_1" end subroutine resonance_insertion_1 @ %def resonance_insertion_1 @ \subsubsection{Resonance insertion with color mismatch} Same as previous test (but no momenta); resonance insertion should fail because of color mismatch: W boson is color-neutral. <>= call test (resonance_insertion_2, "resonance_insertion_2", & "resonance color mismatch", & u, results) <>= public :: resonance_insertion_2 <>= subroutine resonance_insertion_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance type(color_t) :: col class(rng_t), allocatable :: rng real(default) :: probability type(particle_t), dimension(:), allocatable :: prt_invalid integer, dimension(:), allocatable :: i_invalid integer :: i write (u, "(A)") "* Test output: resonance_insertion_2" write (u, "(A)") "* Purpose: resonance insertion with color mismatch" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 3, & pdg = [1, -1, 1, -2, 24], model = model) call col%init_col_acl (1,0) call pset%set_color (1, col) call col%init_col_acl (0,2) call pset%set_color (2, col) call col%init_col_acl (1,0) call pset%set_color (3, col) call col%init_col_acl (0,2) call pset%set_color (4, col) call col%init_col_acl (0,0) call pset%set_color (5, col) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, -24, model, 2) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default]) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") call evt_resonance%find_prt_invalid_color (i_invalid, prt_invalid) write (u, "(A)") "Particles with invalid color:" select case (size (prt_invalid)) case (0) write (u, "(2x,A)") "[none]" case default do i = 1, size (prt_invalid) write (u, "(1x,A,1x,I0)", advance="no") "Particle", i_invalid(i) call prt_invalid(i)%write (u) end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_2" end subroutine resonance_insertion_2 @ %def resonance_insertion_2 @ \subsubsection{Complex resonance history} This is the resonance history $u\bar u \to (t\to W^+ b) + (\bar t\to (h \to b\bar b) + (\bar t^\ast \to W^-\bar b))$. <>= call test (resonance_insertion_3, "resonance_insertion_3", & "complex resonance history", & u, results) <>= public :: resonance_insertion_3 <>= subroutine resonance_insertion_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance type(color_t) :: col class(rng_t), allocatable :: rng real(default) :: probability type(particle_t), dimension(:), allocatable :: prt_invalid integer, dimension(:), allocatable :: i_invalid integer :: i write (u, "(A)") "* Test output: resonance_insertion_3" write (u, "(A)") "* Purpose: resonance insertion with color mismatch" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 6, & pdg = [2, -2, 24, 5, 5, -5, -24, -5], model = model) call col%init_col_acl (1,0) call pset%set_color (1, col) call col%init_col_acl (0,2) call pset%set_color (2, col) call col%init_col_acl (0,0) call pset%set_color (3, col) call col%init_col_acl (1,0) call pset%set_color (4, col) call col%init_col_acl (3,0) call pset%set_color (5, col) call col%init_col_acl (0,3) call pset%set_color (6, col) call col%init_col_acl (0,0) call pset%set_color (7, col) call col%init_col_acl (0,2) call pset%set_color (8, col) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, 6, model, 6) call res_history%add_resonance (res_info) call res_info%init (12, 25, model, 6) call res_history%add_resonance (res_info) call res_info%init (60, -6, model, 6) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default]) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") call evt_resonance%find_prt_invalid_color (i_invalid, prt_invalid) write (u, "(A)") "Particles with invalid color:" select case (size (prt_invalid)) case (0) write (u, "(2x,A)") "[none]" case default do i = 1, size (prt_invalid) write (u, "(1x,A,1x,I0)", advance="no") "Particle", i_invalid(i) call prt_invalid(i)%write (u) end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_3" end subroutine resonance_insertion_3 @ %def resonance_insertion_3 @ \subsubsection{Resonance history selection} Another test with zero momenta: select one of several resonant channels using the selector component. <>= call test (resonance_insertion_4, "resonance_insertion_4", & "resonance history selection", & u, results) <>= public :: resonance_insertion_4 <>= subroutine resonance_insertion_4 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance type(color_t) :: col class(rng_t), allocatable :: rng real(default) :: probability integer :: i write (u, "(A)") "* Test output: resonance_insertion_4" write (u, "(A)") "* Purpose: resonance history selection" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 4, & pdg = [1, -1, 1, -2, -3, 4], model = model) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, -24, model, 4) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_info%init (12, 24, model, 4) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_info%init (12, 24, model, 4) call res_history%add_resonance (res_info) call res_info%init (15, 25, model, 4) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") do i = 1, 6 write (u, "(A,1x,I0)") "* Event #", i write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default, 2._default, 1._default]) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") end do write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_4" end subroutine resonance_insertion_4 @ %def resonance_insertion_4 @ \subsubsection{Resonance history selection} Another test with zero momenta: select either a resonant channel or no resonance. <>= call test (resonance_insertion_5, "resonance_insertion_5", & "resonance history on/off", & u, results) <>= public :: resonance_insertion_5 <>= subroutine resonance_insertion_5 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance type(color_t) :: col class(rng_t), allocatable :: rng real(default) :: probability integer :: i write (u, "(A)") "* Test output: resonance_insertion_5" write (u, "(A)") "* Purpose: resonance history selection including no resonance" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 4, & pdg = [1, -1, 1, -2, -3, 4], model = model) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, -24, model, 4) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") do i = 1, 2 write (u, "(A,1x,I0)") "* Event #", i write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default, 3._default], offset = -1) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") end do write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_5" end subroutine resonance_insertion_5 @ %def resonance_insertion_5 @ \subsubsection{Resonance insertion with structured beams} Insert a resonance (W boson) into an event with beam and virtual particles. <>= call test (resonance_insertion_6, "resonance_insertion_6", & "resonance insertion with beam structure", & u, results) <>= public :: resonance_insertion_6 <>= subroutine resonance_insertion_6 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(particle_set_t) :: pset type(model_t), pointer :: model type(resonance_info_t) :: res_info type(resonance_history_t) :: res_history type(resonance_history_set_t), dimension(1) :: res_history_set type(evt_trivial_t), target :: evt_trivial type(evt_resonance_t), target :: evt_resonance class(rng_t), allocatable :: rng real(default) :: probability write (u, "(A)") "* Test output: resonance_insertion_6" write (u, "(A)") "* Purpose: resonance insertion with structured beams" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 11, -11, 22, 22, 13, -13], model = model) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Prepare resonance history set" write (u, "(A)") call res_history_set(1)%init () call res_info%init (3, 23, model, 2) call res_history%add_resonance (res_info) call res_history_set(1)%enter (res_history) call res_history%clear () call res_history_set(1)%freeze () write (u, "(A)") "* Initialize resonance insertion transform" write (u, "(A)") evt_trivial%next => evt_resonance evt_resonance%previous => evt_trivial allocate (rng_test_t :: rng) call evt_resonance%import_rng (rng) call evt_resonance%set_resonance_data (res_history_set) call evt_resonance%select_component (1) call evt_resonance%write (u) write (u, "(A)") write (u, "(A)") "* Fill resonance insertion transform" write (u, "(A)") call evt_resonance%prepare_new_event (1, 1) call evt_resonance%init_selector ([1._default]) call evt_resonance%generate_weighted (probability) call evt_resonance%make_particle_set (0, .false.) call evt_resonance%write (u) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_resonance%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: resonance_insertion_6" end subroutine resonance_insertion_6 @ %def resonance_insertion_6 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Recoil kinematics} <<[[recoil_kinematics.f90]]>>= <> module recoil_kinematics <> use constants, only: twopi use lorentz, only: vector4_t use lorentz, only: vector4_null use lorentz, only: vector4_moving use lorentz, only: vector3_moving use lorentz, only: transverse_part use lorentz, only: lorentz_transformation_t use lorentz, only: inverse use lorentz, only: boost use lorentz, only: transformation use lorentz, only: operator(+) use lorentz, only: operator(-) use lorentz, only: operator(*) use lorentz, only: operator(**) use lorentz, only: lambda <> <> <> <> contains <> end module recoil_kinematics @ %def recoil_kinematics @ \subsection{$\phi$ sampler} This is trivial. Generate an azimuthal angle, given a $(0,1)$ RNG parameter. <>= elemental subroutine generate_phi_recoil (r, phi) real(default), intent(in) :: r real(default), intent(out) :: phi phi = r * twopi end subroutine generate_phi_recoil @ %def generate_phi_recoil @ \subsection{$Q^2$ sampler} The dynamics of factorization suggests to generate a flat $Q^2$ distribution from a (random) number, event by event. At the lowest momentum transfer values, the particle (electron) mass sets a smooth cutoff. The formula can produce $Q$ values below the electron mass, down to zero, but with a power distribution that eventually evolves into the expected logarithmic distribution for $Q^2 > m^2$. We are talking about the absolute value here, so all $Q^2$ values are positive. For the actual momentum transfer, $q^2=-Q^2$. <>= public :: generate_q2_recoil <>= elemental subroutine generate_q2_recoil (s, x_bar, q2_max, m2, r, q2) real(default), intent(in) :: s real(default), intent(in) :: q2_max real(default), intent(in) :: x_bar real(default), intent(in) :: m2 real(default), intent(in) :: r real(default), intent(out) :: q2 real(default) :: q2_max_evt q2_max_evt = q2_max_event (s, x_bar, q2_max) q2 = m2 * (exp (r * log (1 + (q2_max_evt / m2))) - 1) end subroutine generate_q2_recoil @ %def generate_q_recoil @ The $Q$ distribution is cut off from above by the kinematic limit, which depends on the energy that is available for the radiated photon, or by a user-defined cutoff -- whichever is less. The kinematic limit fits the formulas for recoil momenta (see below), and it also implicitly enters the ISR collinear structure function, so the normalization of the distribution should be correct. <>= elemental function q2_max_event (s, x_bar, q2_max) result (q2) real(default), intent(in) :: s real(default), intent(in) :: x_bar real(default), intent(in) :: q2_max real(default) :: q2 q2 = min (x_bar * s, q2_max) end function q2_max_event @ %def q2_max_event @ \subsection{Kinematics functions} Given values for energies, $Q_{1,2}^2$, azimuthal angle, compute the matching polar angle of the radiating particle. The subroutine returns $\sin\theta$ and $\cos\theta$. <>= subroutine polar_angles (s, xb, rho, ee, q2, sin_th, cos_th, ok) real(default), intent(in) :: s real(default), intent(in) :: xb real(default), intent(in) :: rho real(default), dimension(2), intent(in) :: ee real(default), dimension(2), intent(in) :: q2 real(default), dimension(2), intent(out) :: sin_th real(default), dimension(2), intent(out) :: cos_th logical, intent(out) :: ok real(default), dimension(2) :: sin2_th_2 sin2_th_2 = q2 / (ee * rho * xb * s) if (all (sin2_th_2 <= 1)) then sin_th = 2 * sqrt (sin2_th_2 * (1 - sin2_th_2)) cos_th = 1 - 2 * sin2_th_2 ok = .true. else sin_th = 0 cos_th = 1 ok = .false. end if end subroutine polar_angles @ %def polar_angles @ Compute the acollinearity parameter $\lambda$ from azimuthal and polar angles. The result is a number between $0$ and $1$. <>= function lambda_factor (sin_th, cos_th, cphi) result (lambda) real(default), dimension(2), intent(in) :: sin_th real(default), dimension(2), intent(in) :: cos_th real(default), intent(in) :: cphi real(default) :: lambda lambda = (1 - cos_th(1) * cos_th(2) - cphi * sin_th(1) * sin_th(2)) / 2 end function lambda_factor @ %def lambda_factor @ Compute the factor that rescales photon energies, such that the radiation angles match the kinematics parameters. For small values of $\bar x/\cosh\eta$, we have to use the Taylor expansion if we do not want to lose precision. The optional argument allows for a unit test that compares exact and approximate. <>= function scale_factor (che, lambda, xb0, approximate) result (rho) real(default), intent(in) :: che real(default), intent(in) :: lambda real(default), intent(in) :: xb0 logical, intent(in), optional :: approximate real(default) :: rho real(default), parameter :: & e0 = (100 * epsilon (1._default)) ** (0.3_default) logical :: approx if (present (approximate)) then approx = approximate else approx = (xb0/che) < e0 end if if (approx) then rho = 1 - lambda * (xb0/(2*che)) * (1 + (1-lambda) * (xb0/che)) else rho = (che / ((1-lambda)*xb0)) & * (1 - sqrt (1 - 2 * (1-lambda) * (xb0/che) & & + (1-lambda) * (xb0 / che)**2)) end if end function scale_factor @ %def scale_factor @ The code snippet below is not used anywhere, but may be manually inserted in a unit test to numerically verify the approximation above. <>= write (u, "(A)") write (u, "(A)") "*** Table: scale factor calculation" write (u, "(A)") lambda = 0.25_default write (u, FMT1) "lambda =", lambda che = 4._default write (u, FMT1) "che =", che write (u, "(A)") " x0 rho(exact) rho(approx) rho(chosen)" xb0 = 1._default do i = 1, 30 xb0 = xb0 / 10 write (u, FMT4) xb0, & scale_factor (che, lambda, xb0, approximate=.false.), & scale_factor (che, lambda, xb0, approximate=.true.), & scale_factor (che, lambda, xb0) end do @ Compute the current values for the $x_{1,2}$ parameters, given the updated scale factor $\rho$ and the collinear parameters. <>= subroutine scaled_x (rho, ee, xb0, x, xb) real(default), intent(in) :: rho real(default), dimension(2), intent(in) :: ee real(default), intent(in) :: xb0 real(default), dimension(2), intent(out) :: x real(default), dimension(2), intent(out) :: xb xb = rho * ee * xb0 x = 1 - xb end subroutine scaled_x @ %def scaled_x @ \subsection{Iterative solution of kinematics constraints} Find a solution of the kinematics constraints. We know the parameters appropriate for collinear kinematics $\sqrt{s}$, $x^c_{1,2}$. We have picked values vor the momentum transfer $Q_{1,2}$ and the azimuthal angles $\phi_{1,2}$. The solution consists of modified energy fractions $x_{1,2}$ and polar angles $\theta_{1,2}$. If the computation fails, which can happen for large momentum transfer, the flag [[ok]] will indicate this. <>= public :: solve_recoil <>= subroutine solve_recoil (sqrts, xc, xcb, phi, q2, x, xb, cos_th, sin_th, ok) real(default), intent(in) :: sqrts real(default), dimension(2), intent(in) :: xc real(default), dimension(2), intent(in) :: xcb real(default), dimension(2), intent(in) :: phi real(default), dimension(2), intent(in) :: q2 real(default), dimension(2), intent(out) :: x real(default), dimension(2), intent(out) :: xb real(default), dimension(2), intent(out) :: cos_th real(default), dimension(2), intent(out) :: sin_th logical, intent(out) :: ok real(default) :: s real(default), dimension(2) :: ee real(default), dimension(2) :: th real(default) :: xb0, cphi real(default) :: che, lambda real(default) :: rho_new, rho, rho_old real(default) :: dr_old, dr_new real(default), parameter :: dr_limit = 100 * epsilon (1._default) integer, parameter :: n_it_max = 20 integer :: i ok = .true. s = sqrts**2 ee = sqrt ([xcb(1)/xcb(2), xcb(2)/xcb(1)]) che = sum (ee) / 2 xb0 = sqrt (xcb(1) * xcb(2)) cphi = cos (phi(1) - phi(2)) rho_old = 10 rho = 1 th = 0 sin_th = sin (th) cos_th = cos (th) lambda = lambda_factor (sin_th, cos_th, cphi) call scaled_x (rho, ee, xb0, x, xb) iterate_loop: do i = 1, n_it_max call polar_angles (s, xb0, rho, ee, q2, sin_th, cos_th, ok) if (.not. ok) return th = atan2 (sin_th, cos_th) lambda = lambda_factor (sin_th, cos_th, cphi) rho_new = scale_factor (che, lambda, xb0) call scaled_x (rho_new, ee, xb0, x, xb) dr_old = abs (rho - rho_old) dr_new = abs (rho_new - rho) rho_old = rho rho = rho_new if (dr_new < dr_limit .or. dr_new >= dr_old) exit iterate_loop end do iterate_loop end subroutine solve_recoil @ %def solve_recoil @ With all kinematics parameters known, construct actual four-vectors for the recoil momenta, the off-shell (spacelike) parton momenta, and on-shell projected parton momenta. <>= public :: recoil_momenta <>= subroutine recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, & km, qm, qo, ok) real(default), intent(in) :: sqrts real(default), dimension(2), intent(in) :: xc real(default), dimension(2), intent(in) :: xb real(default), dimension(2), intent(in) :: cos_th real(default), dimension(2), intent(in) :: sin_th real(default), dimension(2), intent(in) :: phi real(default), dimension(2), intent(in) :: mo type(vector4_t), dimension(2), intent(out) :: km type(vector4_t), dimension(2), intent(out) :: qm type(vector4_t), dimension(2), intent(out) :: qo logical, intent(out) :: ok type(vector4_t), dimension(2) :: pm type(lorentz_transformation_t) :: lt real(default) :: sqsh real(default) :: po4, po2 real(default), dimension(2) :: p0, p3 pm(1) = & vector4_moving (sqrts/2, & vector3_moving ([0._default, 0._default, sqrts/2])) pm(2) = & vector4_moving (sqrts/2, & vector3_moving ([0._default, 0._default,-sqrts/2])) km(1) = xb(1) * (sqrts/2) * vector4_moving ( & 1._default, & vector3_moving ([ & & sin_th(1) * cos (phi(1)), & & sin_th(1) * sin (phi(1)), & & cos_th(1)]) & ) km(2) = xb(2) * (sqrts/2) * vector4_moving ( & 1._default, & vector3_moving ([ & & -sin_th(2) * cos (phi(2)), & & -sin_th(2) * sin (phi(2)), & & -cos_th(2)]) & ) qm(1) = pm(1) - km(1) qm(2) = pm(2) - km(2) sqsh = sqrt (xc(1)*xc(2)) * sqrts lt = transformation (3, qm(1), qm(2), sqsh) po4 = lambda (sqsh**2, mo(1)**2, mo(2)**2) ok = po4 > 0 if (ok) then po2 = sqrt (po4)/4 p0 = sqrt (po2 + mo**2) p3 = [sqrt (po2), -sqrt (po2)] qo = lt * vector4_moving (p0, p3, 3) else qo = vector4_null end if end subroutine recoil_momenta @ %def recoil_momenta @ Compute the Lorentz transformation that we can use to transform any outgoing momenta into the new c.m.\ system of the incoming partons. Not relying on the previous calculations, we determine the transformation that transforms the original collinear partons into their c.m.\ system, and then transform this to the new c.m.\ system. <>= public :: recoil_transformation <>= subroutine recoil_transformation (sqrts, xc, qo, lt) real(default), intent(in) :: sqrts real(default), dimension(2), intent(in) :: xc type(vector4_t), dimension(2), intent(in) :: qo type(lorentz_transformation_t), intent(out) :: lt real(default) :: sqsh type(vector4_t), dimension(2) :: qc type(lorentz_transformation_t) :: ltc, lto qc(1) = xc(1) * vector4_moving (sqrts/2, sqrts/2, 3) qc(2) = xc(2) * vector4_moving (sqrts/2,-sqrts/2, 3) sqsh = sqrt (xc(1) * xc(2)) * sqrts ltc = transformation (3, qc(1), qc(2), sqsh) lto = transformation (3, qo(1), qo(2), sqsh) lt = lto * inverse (ltc) end subroutine recoil_transformation @ %def recoil_transformation @ Compute the Lorentz boost that transforms the c.m.\ frame of the momenta into the lab frame where they are given. Also return their common invariant mass, $\sqrt{s}$. If the initial momenta are not collinear, [[ok]] is set false. <>= public :: initial_transformation <>= subroutine initial_transformation (p, sqrts, lt, ok) type(vector4_t), dimension(2), intent(in) :: p real(default), intent(out) :: sqrts type(lorentz_transformation_t), intent(out) :: lt logical, intent(out) :: ok ok = all (transverse_part (p) == 0) sqrts = (p(1) + p(2)) ** 1 lt = boost (p(1) + p(2), sqrts) end subroutine initial_transformation @ %def initial_transformation @ \subsection{Generate recoil event} Combine the above kinematics calculations. First generate azimuthal angles and momentum transfer, solve kinematics and compute momenta for the radiated photons and the on-shell projected, recoiling partons. The [[mo]] masses are used for the on-shell projection of the partons after radiation. They may be equal to [[m]], or set to zero. If [[ok]] is false, the data point has failed and we should repeat the procedure for a new set of RNG parameters [[r]]. <>= public :: generate_recoil <>= subroutine generate_recoil (sqrts, q_max, m, mo, xc, xcb, r, km, qm, qo, ok) real(default), intent(in) :: sqrts real(default), intent(in), dimension(2) :: q_max real(default), intent(in), dimension(2) :: m real(default), intent(in), dimension(2) :: mo real(default), intent(in), dimension(2) :: xc real(default), intent(in), dimension(2) :: xcb real(default), intent(in), dimension(4) :: r type(vector4_t), dimension(2), intent(out) :: km type(vector4_t), dimension(2), intent(out) :: qm type(vector4_t), dimension(2), intent(out) :: qo logical, intent(out) :: ok real(default), dimension(2) :: q2 real(default), dimension(2) :: phi real(default), dimension(2) :: x real(default), dimension(2) :: xb real(default), dimension(2) :: cos_th real(default), dimension(2) :: sin_th call generate_q2_recoil (sqrts**2, xcb, q_max**2, m**2, r(1:2), q2) call generate_phi_recoil (r(3:4), phi) call solve_recoil (sqrts, xc, xcb, phi, q2, x, xb, cos_th, sin_th, ok) if (ok) then call recoil_momenta & (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) end if end subroutine generate_recoil @ %def generate_recoil @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[recoil_kinematics_ut.f90]]>>= <> module recoil_kinematics_ut use unit_tests use recoil_kinematics_uti <> <> contains <> end module recoil_kinematics_ut @ %def recoil_kinematics_ut @ <<[[recoil_kinematics_uti.f90]]>>= <> module recoil_kinematics_uti <> use constants, only: twopi use constants, only: degree use lorentz, only: vector4_t use lorentz, only: vector4_moving use lorentz, only: lorentz_transformation_t use lorentz, only: inverse use lorentz, only: operator(+) use lorentz, only: operator(*) use lorentz, only: operator(**) use lorentz, only: pacify use recoil_kinematics, only: solve_recoil use recoil_kinematics, only: recoil_momenta use recoil_kinematics, only: recoil_transformation use recoil_kinematics, only: initial_transformation use recoil_kinematics, only: generate_q2_recoil use recoil_kinematics, only: generate_recoil <> <> contains <> end module recoil_kinematics_uti @ %def recoil_kinematics_uti @ API: driver for the unit tests below. <>= public :: recoil_kinematics_test <>= subroutine recoil_kinematics_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine recoil_kinematics_test @ %def recoil_kinematics_test @ \subsubsection{Recoil kinematics} For a set of input data, solve the kinematics constraints and generate momenta accordingly. <>= call test (recoil_kinematics_1, "recoil_kinematics_1", & "iterative solution of non-collinear kinematics", & u, results) <>= public :: recoil_kinematics_1 <>= subroutine recoil_kinematics_1 (u) integer, intent(in) :: u real(default) :: sqrts real(default), dimension(2) :: xc, xcb real(default), dimension(2) :: q real(default), dimension(2) :: phi real(default), dimension(2) :: mo real(default), dimension(2) :: cos_th, sin_th real(default), dimension(2) :: x real(default), dimension(2) :: xb type(vector4_t), dimension(2) :: km type(vector4_t), dimension(2) :: qm type(vector4_t), dimension(2) :: qo integer :: i logical :: ok character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT2 = "(1x,A,9(1x,F10.5))" character(*), parameter :: FMT4 = "(3x,ES8.1,9(1x,ES19.12))" write (u, "(A)") "* Test output: recoil_kinematics_1" write (u, "(A)") "* Purpose: compute kinematics for various input data" write (u, "(A)") sqrts = 100 write (u, FMT1) "sqrts =", sqrts write (u, "(A)") write (u, "(A)") "*** collinear data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = 0 mo = 0 call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call show_results call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** moderate data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = [0.2_default, 0.05_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call show_results call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** semi-soft data set" write (u, "(A)") xcb= [0.1_default, 0.0001_default] xc = 1 - xcb phi = [0.1_default, 0.2_default] * twopi q = [0.2_default, 0.00001_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call show_results call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** hard-soft data set" write (u, "(A)") xcb= [0.1_default, 1.e-30_default] xc = 1 - xcb phi = [0.1_default, 0.2_default] * twopi q = [0.2_default, 1.e-35_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call show_results call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** hard data set" write (u, "(A)") xc = [0.2_default, 0.4_default] xcb = 1 - xc phi = [0.1_default, 0.8_default] * twopi q = [0.74_default, 0.3_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call show_results call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** failing data set" write (u, "(A)") xc = [0.2_default, 0.4_default] xcb = 1 - xc phi = [0.1_default, 0.8_default] * twopi q = [0.9_default, 0.3_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) if (.not. ok) then write (u, "(A)") write (u, "(A)") "Failed as expected." end if write (u, "(A)") write (u, "(A)") "* Test output end: recoil_kinematics_1" contains subroutine show_data write (u, FMT1) "sqs_h =", sqrt (xc(1) * xc(2)) * sqrts write (u, FMT1) "xc =", xc write (u, FMT1) "xcb =", xcb write (u, FMT1) "Q =", Q write (u, FMT1) "phi/D =", phi / degree end subroutine show_data subroutine show_results write (u, "(A)") write (u, "(A)") "Result:" write (u, FMT1) "th/D =", atan2 (sin_th, cos_th) / degree write (u, FMT1) "x =", x write (u, "(A)") end subroutine show_results subroutine show_momenta type(vector4_t) :: qm0, qo0 real(default), parameter :: tol = 1.e-7_default call pacify (km, tol) call pacify (qm, tol) call pacify (qo, tol) write (u, "(A)") "Momenta: k" call km(1)%write (u, testflag=.true.) call km(2)%write (u, testflag=.true.) write (u, FMT1) "k^2 =", abs (km(1)**2), abs (km(2)**2) write (u, "(A)") write (u, "(A)") "Momenta: q" call qm(1)%write (u, testflag=.true.) call qm(2)%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "Momenta: q(os)" call qo(1)%write (u, testflag=.true.) call qo(2)%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "Check: parton momentum sum: q vs q(os)" qm0 = qm(1) + qm(2) call qm0%write (u, testflag=.true.) qo0 = qo(1) + qo(2) call qo0%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Check: momentum transfer (off-shell/on-shell)" write (u, FMT2) "|q| =", abs (qm(1)**1), abs (qm(2)**1) write (u, FMT2) "Q =", q write (u, FMT2) "|qo|=", abs (qo(1)**1), abs (qo(2)**1) write (u, "(A)") write (u, "(A)") "* Check: sqrts, sqrts_hat" write (u, FMT1) "|p| =", (km(1)+km(2)+qm(1)+qm(2))**1, (qm(1)+qm(2))**1 write (u, FMT1) "sqs =", sqrts, sqrt (product (xc)) * sqrts write (u, FMT1) "|po|=", abs ((km(1)+km(2)+qo(1)+qo(2))**1), abs ((qo(1)+qo(2))**1) end subroutine show_momenta end subroutine recoil_kinematics_1 @ %def recoil_kinematics_1 @ \subsubsection{Recoil $Q$ distribution} Sample the $Q$ distribution for equidistant bins in the input variable. <>= call test (recoil_kinematics_2, "recoil_kinematics_2", & "Q distribution", & u, results) <>= public :: recoil_kinematics_2 <>= subroutine recoil_kinematics_2 (u) integer, intent(in) :: u real(default) :: sqrts real(default) :: q_max real(default) :: m real(default) :: x_bar real(default) :: r real(default) :: q2, q2_old integer :: i integer :: n_bin character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT3 = "(2x,9(1x,F10.5))" write (u, "(A)") "* Test output: recoil_kinematics_2" write (u, "(A)") "* Purpose: compute Q distribution" write (u, "(A)") n_bin = 20 write (u, "(A)") "* No Q cutoff, xbar = 1" write (u, "(A)") sqrts = 100 q_max = sqrts m = 0.511e-3_default x_bar = 1._default call show_table write (u, "(A)") write (u, "(A)") "* With Q cutoff, xbar = 1" write (u, "(A)") q_max = 10 call show_table write (u, "(A)") write (u, "(A)") "* No Q cutoff, xbar = 0.01" write (u, "(A)") q_max = sqrts x_bar = 0.01_default call show_table write (u, "(A)") write (u, "(A)") "* Test output end: recoil_kinematics_2" contains subroutine show_table write (u, FMT1) "sqrts =", sqrts write (u, FMT1) "q_max =", q_max write (u, FMT1) "m =", m write (u, FMT1) "x_bar =", x_bar write (u, "(A)") write (u, "(1x,A)") "Table: r |Q| |Q_i/Q_(i-1)|" q2_old = 0 do i = 0, n_bin r = real (i, default) / n_bin call generate_q2_recoil (sqrts**2, x_bar, q_max**2, m**2, r, q2) if (q2_old > 0) then write (u, FMT3) r, sqrt (q2), sqrt (q2 / q2_old) else write (u, FMT3) r, sqrt (q2) end if q2_old = q2 end do end subroutine show_table end subroutine recoil_kinematics_2 @ %def recoil_kinematics_2 @ \subsubsection{Generate recoil event} Combine $Q^2$ sampling with momentum generation. <>= call test (recoil_kinematics_3, "recoil_kinematics_3", & "generate recoil event", & u, results) <>= public :: recoil_kinematics_3 <>= subroutine recoil_kinematics_3 (u) integer, intent(in) :: u real(default) :: sqrts real(default), dimension(2) :: q_max real(default), dimension(2) :: m, mo real(default), dimension(2) :: xc, xcb real(default), dimension(4) :: r type(vector4_t), dimension(2) :: km type(vector4_t), dimension(2) :: qm type(vector4_t), dimension(2) :: qo logical :: ok character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT2 = "(1x,A,9(1x,F10.5))" write (u, "(A)") "* Test output: recoil_kinematics_3" write (u, "(A)") "* Purpose: generate momenta from RNG parameters" write (u, "(A)") write (u, "(A)") "*** collinear data set" write (u, "(A)") sqrts = 100 q_max = sqrts m = 0.511e-3_default mo = 0 xc = [0.6_default, 0.9_default] xcb = 1 - xc r = [0._default, 0._default, 0._default, 0._default] call show_data call generate_recoil (sqrts, q_max, m, mo, xc, xcb, r, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** moderate data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc r = [0.8_default, 0.2_default, 0.1_default, 0.2_default] call show_data call generate_recoil (sqrts, q_max, m, mo, xc, xcb, r, km, qm, qo, ok) call show_momenta write (u, "(A)") write (u, "(A)") "*** failing data set" write (u, "(A)") xc = [0.2_default, 0.4_default] xcb = 1 - xc r = [0.9999_default, 0.3_default, 0.1_default, 0.8_default] call show_data call generate_recoil (sqrts, q_max, m, mo, xc, xcb, r, km, qm, qo, ok) if (.not. ok) then write (u, "(A)") write (u, "(A)") "Failed as expected." else call show_momenta end if contains subroutine show_data write (u, FMT1) "sqrts =", sqrts write (u, FMT1) "q_max =", q_max write (u, FMT1) "m =", m write (u, FMT1) "xc =", xc write (u, FMT1) "xcb =", xcb write (u, FMT1) "r =", r end subroutine show_data subroutine show_momenta real(default), parameter :: tol = 1.e-7_default call pacify (km, tol) call pacify (qo, tol) write (u, "(A)") write (u, "(A)") "* Momenta: k" call km(1)%write (u, testflag=.true.) call km(2)%write (u, testflag=.true.) write (u, FMT1) "k^2 =", abs (km(1)**2), abs (km(2)**2) write (u, "(A)") write (u, "(A)") "* Momenta: q(os)" call qo(1)%write (u, testflag=.true.) call qo(2)%write (u, testflag=.true.) write (u, FMT1) "q^2 =", abs (qo(1)**2), abs (qo(2)**2) write (u, "(A)") write (u, "(A)") "* Check: momentum transfer (off-shell/on-shell)" write (u, FMT2) "Q =", q_check (1), q_check (2) write (u, FMT2) "|q| =", abs (qm(1)**1), abs (qm(2)**1) write (u, "(A)") write (u, "(A)") "* Check: sqrts, sqrts_hat" write (u, FMT1) "sqs =", sqrts, sqrt (product (xc)) * sqrts write (u, FMT1) "|po|=", abs ((km(1)+km(2)+qo(1)+qo(2))**1), abs ((qo(1)+qo(2))**1) end subroutine show_momenta function q_check (i) result (q) integer, intent(in) :: i real(default) :: q real(default) :: q2 call generate_q2_recoil (sqrts**2, xcb(i), q_max(i)**2, m(i)**2, r(i), q2) q = sqrt (q2) end function q_check end subroutine recoil_kinematics_3 @ %def recoil_kinematics_3 @ \subsubsection{Transformation after recoil} Given a solution to recoil kinematics, compute the Lorentz transformation that transforms the old collinear parton momenta into the new parton momenta. <>= call test (recoil_kinematics_4, "recoil_kinematics_4", & "reference frame", & u, results) <>= public :: recoil_kinematics_4 <>= subroutine recoil_kinematics_4 (u) integer, intent(in) :: u real(default) :: sqrts real(default), dimension(2) :: xc, xcb real(default), dimension(2) :: q real(default), dimension(2) :: phi real(default), dimension(2) :: cos_th, sin_th real(default), dimension(2) :: mo real(default), dimension(2) :: x real(default), dimension(2) :: xb type(vector4_t), dimension(2) :: km type(vector4_t), dimension(2) :: qm type(vector4_t), dimension(2) :: qo type(lorentz_transformation_t) :: lt logical :: ok character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT2 = "(1x,A,9(1x,F10.5))" write (u, "(A)") "* Test output: recoil_kinematics_4" write (u, "(A)") "* Purpose: check Lorentz transformation for recoil" write (u, "(A)") sqrts = 100 write (u, FMT1) "sqrts =", sqrts write (u, "(A)") write (u, "(A)") "*** collinear data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = 0 mo = 0 call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call recoil_transformation (sqrts, xc, qo, lt) call show_transformation write (u, "(A)") write (u, "(A)") "*** moderate data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = [0.2_default, 0.05_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call recoil_transformation (sqrts, xc, qo, lt) call show_transformation write (u, "(A)") write (u, "(A)") "* Test output end: recoil_kinematics_4" contains subroutine show_data write (u, FMT1) "sqs_h =", sqrt (xc(1) * xc(2)) * sqrts write (u, FMT1) "xc =", xc write (u, FMT1) "xcb =", xcb write (u, FMT1) "Q =", Q write (u, FMT1) "phi/D =", phi / degree end subroutine show_data subroutine show_transformation type(vector4_t), dimension(2) :: qc type(vector4_t), dimension(2) :: qct real(default), parameter :: tol = 1.e-7_default qc(1) = xc(1) * vector4_moving (sqrts/2, sqrts/2, 3) qc(2) = xc(2) * vector4_moving (sqrts/2,-sqrts/2, 3) qct = lt * qc call pacify (qct, tol) write (u, "(A)") write (u, "(A)") "Momenta: q(os)" call qo(1)%write (u, testflag=.true.) call qo(2)%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "Momenta: LT * qc" call qct(1)%write (u, testflag=.true.) call qct(2)%write (u, testflag=.true.) end subroutine show_transformation end subroutine recoil_kinematics_4 @ %def recoil_kinematics_4 @ \subsubsection{Transformation before recoil} Given a pair of incoming `beam' partons (i.e., before ISR splitting), compute the transformation that transforms their common c.m.\ frame into the lab frame. <>= call test (recoil_kinematics_5, "recoil_kinematics_5", & "initial reference frame", & u, results) <>= public :: recoil_kinematics_5 <>= subroutine recoil_kinematics_5 (u) integer, intent(in) :: u real(default) :: sqrts real(default) :: sqrtsi real(default), dimension(2) :: x type(vector4_t), dimension(2) :: p type(vector4_t), dimension(2) :: pi type(vector4_t), dimension(2) :: p0 type(lorentz_transformation_t) :: lt logical :: ok character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT2 = "(1x,A,9(1x,F10.5))" write (u, "(A)") "* Test output: recoil_kinematics_5" write (u, "(A)") "* Purpose: determine initial Lorentz transformation" write (u, "(A)") sqrts = 100 write (u, FMT1) "sqrts =", sqrts x = [0.6_default, 0.9_default] p(1) = x(1) * vector4_moving (sqrts/2, sqrts/2, 3) p(2) = x(2) * vector4_moving (sqrts/2,-sqrts/2, 3) call show_data call initial_transformation (p, sqrtsi, lt, ok) pi(1) = vector4_moving (sqrtsi/2, sqrtsi/2, 3) pi(2) = vector4_moving (sqrtsi/2,-sqrtsi/2, 3) p0 = inverse (lt) * p call show_momenta write (u, "(A)") write (u, "(A)") "* Test output end: recoil_kinematics_5" contains subroutine show_data write (u, FMT1) "sqrts =", sqrts write (u, FMT1) "x =", x end subroutine show_data subroutine show_momenta real(default), parameter :: tol = 1.e-7_default write (u, "(A)") write (u, "(A)") "* Momenta: p_in(c.m.)" call pi(1)%write (u, testflag=.true.) call pi(2)%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Momenta: inv(LT) * p_in(lab)" call p0(1)%write (u, testflag=.true.) call p0(2)%write (u, testflag=.true.) end subroutine show_momenta end subroutine recoil_kinematics_5 @ %def recoil_kinematics_5 @ \subsubsection{Transformation after recoil with on-shell momenta} Given a solution to recoil kinematics, compute the Lorentz transformation that transforms the old collinear parton momenta into the new parton momenta. Compare the results for massless and massive on-shell projection. <>= call test (recoil_kinematics_6, "recoil_kinematics_6", & "massless/massive on-shell projection", & u, results) <>= public :: recoil_kinematics_6 <>= subroutine recoil_kinematics_6 (u) integer, intent(in) :: u real(default) :: sqrts real(default), dimension(2) :: xc, xcb real(default), dimension(2) :: q real(default), dimension(2) :: phi real(default), dimension(2) :: cos_th, sin_th real(default), dimension(2) :: x real(default), dimension(2) :: xb real(default), dimension(2) :: mo, z type(vector4_t), dimension(2) :: km type(vector4_t), dimension(2) :: qm type(vector4_t), dimension(2) :: qo type(lorentz_transformation_t) :: lt logical :: ok character(*), parameter :: FMT1 = "(1x,A,9(1x,F15.10))" character(*), parameter :: FMT2 = "(1x,A,9(1x,F11.6))" write (u, "(A)") "* Test output: recoil_kinematics_6" write (u, "(A)") "* Purpose: check effect of mass in on-shell projection" write (u, "(A)") sqrts = 10 write (u, FMT1) "sqrts =", sqrts z = 0 mo = 0.511e-3 write (u, FMT1) "mass =", mo write (u, "(A)") write (u, "(A)") "*** collinear data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = 0 call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, z, km, qm, qo, ok) call recoil_transformation (sqrts, xc, qo, lt) write (u, "(A)") write (u, "(A)") "Massless projection:" call show_momenta call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call recoil_transformation (sqrts, xc, qo, lt) write (u, "(A)") write (u, "(A)") "Massive projection:" call show_momenta write (u, "(A)") write (u, "(A)") "*** moderate data set" write (u, "(A)") xc = [0.6_default, 0.9_default] xcb = 1 - xc phi = [0.1_default, 0.2_default] * twopi q = [0.2_default, 0.05_default] * sqrts call show_data call solve_recoil (sqrts, xc, xcb, phi, q**2, x, xb, cos_th, sin_th, ok) call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, z, km, qm, qo, ok) call recoil_transformation (sqrts, xc, qo, lt) write (u, "(A)") write (u, "(A)") "Massless projection:" call show_momenta call recoil_momenta (sqrts, xc, xb, cos_th, sin_th, phi, mo, km, qm, qo, ok) call recoil_transformation (sqrts, xc, qo, lt) write (u, "(A)") write (u, "(A)") "Massive projection:" call show_momenta write (u, "(A)") write (u, "(A)") "* Test output end: recoil_kinematics_6" contains subroutine show_data write (u, FMT1) "sqs_h =", sqrt (xc(1) * xc(2)) * sqrts write (u, FMT1) "xc =", xc write (u, FMT1) "xcb =", xcb write (u, FMT1) "Q =", Q write (u, FMT1) "phi/D =", phi / degree end subroutine show_data subroutine show_momenta write (u, "(A)") "Momenta: q(os)" call qo(1)%write (u, testflag=.true.) write (u, FMT2) "m = ", abs (qo(1)**1) call qo(2)%write (u, testflag=.true.) write (u, FMT2) "m = ", abs (qo(2)**1) end subroutine show_momenta end subroutine recoil_kinematics_6 @ %def recoil_kinematics_6 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Transverse momentum for the ISR and EPA approximations} The ISR and EPA handler takes an event with a single radiated collinear particle (photon for ISR, beam particle for EPA) for each beam, respectively, and inserts transverse momentum for both. The four-particle kinematics allows us to generate $Q^2$ and azimuthal angles independently, without violating energy-momentum conservation. The $Q^2$ distribution is logarithmic, as required by the effective particle approximation, and reflected in the inclusive ISR/EPA structure functions. We also conserve the invariant mass of the partonic systm after radiation. The total transverse-momentum kick is applied in form of a Lorentz transformation to the elementary process, both in- and out-particles. In fact, the incoming partons (beam particle for ISR, photon for EPA) which would be virtual space-like in the exact kinematics configuration, are replaced by on-shell incoming partons, such that energy, momentum, and invariant mass $\sqrt{\hat s}$ are conserved. Regarding kinematics, we treat all particles as massless. The beam-particle mass only appears as the parameter [[isr_mass]] or [[epa_mass]], respectively, and cuts off the logarithmic distribution. The upper cutoff is [[isr_q_max]] ([[epa_q_max]]), which defaults to the available energy $\sqrt{s}$. The only differences between ISR and EPA, in this context, are the particle types, and an extra $\bar x$ factor in the lower cutoff for EPA, see below. <<[[isr_epa_handler.f90]]>>= <> module isr_epa_handler <> <> use diagnostics, only: msg_fatal use diagnostics, only: msg_bug use io_units use format_defs, only: FMT_12, FMT_19 use format_utils, only: write_separator use format_utils, only: pac_fmt use physics_defs, only: PHOTON use lorentz, only: vector4_t use lorentz, only: energy use lorentz, only: lorentz_transformation_t use lorentz, only: identity use lorentz, only: inverse use lorentz, only: operator(*) use sm_qcd use flavors, only: flavor_t use particles, only: particle_t use model_data use models use rng_base, only: rng_t use event_transforms use recoil_kinematics, only: initial_transformation use recoil_kinematics, only: generate_recoil use recoil_kinematics, only: recoil_transformation <> <> <> <> contains <> end module isr_epa_handler @ %def isr_epa_handler @ \subsection{Event transform type} Convention: [[beam]] are the incoming partons before ISR -- not necessarily the actual beams, need not be in c.m.\ frame. [[radiated]] are the radiated particles (photon for ISR), and [[parton]] are the remainders which initiate the elementary process. These particles are copied verbatim from the event record, and must be collinear. The kinematical parameters are [[sqrts]] = invariant mass of the [[beam]] particles, [[q_max]] and [[m]] determining the $Q^2$ distribution, and [[xc]]/[[xcb]] as the energy fraction (complement) of the partons, relative to the beams. Transformations: [[lti]] is the Lorentz transformation that would boosts [[pi]] (c.m. frame) back to the original [[beam]] momenta (lab frame). [[lto]] is the recoil transformation, transforming the partons after ISR from the collinear frame to the recoiling frame. [[lt]] is the combination of both, which is to be applied to all particles after the hard interaction. Momenta: [[pi]] are the beams transformed to their common c.m.\ frame. [[ki]] and [[qi]] are the photon/parton momenta in the [[pi]] c.m.\ frame. [[km]] and [[qm]] are the photon/parton momenta with the $Q$ distribution applied, and finally [[qo]] are the partons [[qm]] projected on-shell. <>= public :: evt_isr_epa_t <>= type, extends (evt_t) :: evt_isr_epa_t private integer :: mode = ISR_TRIVIAL_COLLINEAR logical :: isr_active = .false. logical :: epa_active = .false. real(default) :: isr_q_max = 0 real(default) :: epa_q_max = 0 real(default) :: isr_mass = 0 real(default) :: epa_mass = 0 logical :: isr_keep_mass = .true. real(default) :: sqrts = 0 integer, dimension(2) :: rad_mode = BEAM_RAD_NONE real(default), dimension(2) :: q_max = 0 real(default), dimension(2) :: m = 0 real(default), dimension(2) :: xc = 0 real(default), dimension(2) :: xcb = 0 type(lorentz_transformation_t) :: lti = identity type(lorentz_transformation_t) :: lto = identity type(lorentz_transformation_t) :: lt = identity integer, dimension(2) :: i_beam = 0 type(particle_t), dimension(2) :: beam type(vector4_t), dimension(2) :: pi integer, dimension(2) :: i_radiated = 0 type(particle_t), dimension(2) :: radiated type(vector4_t), dimension(2) :: ki type(vector4_t), dimension(2) :: km integer, dimension(2) :: i_parton = 0 type(particle_t), dimension(2) :: parton type(vector4_t), dimension(2) :: qi type(vector4_t), dimension(2) :: qm type(vector4_t), dimension(2) :: qo contains <> end type evt_isr_epa_t @ %def evt_isr_epa_t @ \subsection{ISR/EPA distinction} <>= integer, parameter, public :: BEAM_RAD_NONE = 0 integer, parameter, public :: BEAM_RAD_ISR = 1 integer, parameter, public :: BEAM_RAD_EPA = 2 @ %def BEAM_RAD_NONE @ %def BEAM_RAD_ISR @ %def BEAM_RAD_EPA <>= function rad_mode_string (mode) result (string) type(string_t) :: string integer, intent(in) :: mode select case (mode) case (BEAM_RAD_NONE); string = "---" case (BEAM_RAD_ISR); string = "ISR" case (BEAM_RAD_EPA); string = "EPA" case default; string = "???" end select end function rad_mode_string @ %def rad_mode_string @ \subsection{Photon insertion modes} <>= integer, parameter, public :: ISR_TRIVIAL_COLLINEAR = 0 integer, parameter, public :: ISR_PAIR_RECOIL = 1 @ %def ISR_TRIVIAL_COLLINEAR ISR_PAIR_RECOIL @ <>= procedure :: get_mode_string => evt_isr_epa_get_mode_string <>= function evt_isr_epa_get_mode_string (evt) result (string) type(string_t) :: string class(evt_isr_epa_t), intent(in) :: evt select case (evt%mode) case (ISR_TRIVIAL_COLLINEAR) string = "trivial, collinear" case (ISR_PAIR_RECOIL) string = "pair recoil" case default string = "[undefined]" end select end function evt_isr_epa_get_mode_string @ %def evt_isr_epa_get_mode_string @ Set the numerical mode ID from a user-level string representation. <>= procedure :: set_mode_string => evt_isr_epa_set_mode_string <>= subroutine evt_isr_epa_set_mode_string (evt, string) class(evt_isr_epa_t), intent(inout) :: evt type(string_t), intent(in) :: string select case (char (string)) case ("trivial") evt%mode = ISR_TRIVIAL_COLLINEAR case ("recoil") evt%mode = ISR_PAIR_RECOIL case default call msg_fatal ("ISR handler: mode '" // char (string) & // "' is undefined") end select end subroutine evt_isr_epa_set_mode_string @ %def evt_isr_epa_set_mode_string @ \subsection{Output} <>= procedure :: write_name => evt_isr_epa_write_name <>= subroutine evt_isr_epa_write_name (evt, unit) class(evt_isr_epa_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: ISR/EPA handler" end subroutine evt_isr_epa_write_name @ %def evt_isr_epa_write_name @ The overall recoil-handling mode. <>= procedure :: write_mode => evt_isr_epa_write_mode <>= subroutine evt_isr_epa_write_mode (evt, unit) class(evt_isr_epa_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A,1x,I0,':',1x,A)") "Insertion mode =", evt%mode, & char (evt%get_mode_string ()) end subroutine evt_isr_epa_write_mode @ %def evt_isr_epa_write_mode @ The input data for ISR and EPA, respectively. <>= procedure :: write_input => evt_isr_epa_write_input <>= subroutine evt_isr_epa_write_input (evt, unit, testflag) class(evt_isr_epa_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag character(len=7) :: fmt integer :: u u = given_output_unit (unit) call pac_fmt (fmt, FMT_19, FMT_12, testflag) if (evt%isr_active) then write (u, "(3x,A,1x," // fmt // ")") "ISR: Q_max =", evt%isr_q_max write (u, "(3x,A,1x," // fmt // ")") " m =", evt%isr_mass write (u, "(3x,A,1x,L1)") " keep m=", evt%isr_keep_mass else write (u, "(3x,A)") "ISR: [inactive]" end if if (evt%epa_active) then write (u, "(3x,A,1x," // fmt // ")") "EPA: Q_max =", evt%epa_q_max write (u, "(3x,A,1x," // fmt // ")") " m =", evt%epa_mass else write (u, "(3x,A)") "EPA: [inactive]" end if end subroutine evt_isr_epa_write_input @ %def evt_isr_epa_write_input @ The trivial mode does not depend on any data, since it does nothing to the event. <>= procedure :: write_data => evt_isr_epa_write_data <>= subroutine evt_isr_epa_write_data (evt, unit, testflag) class(evt_isr_epa_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag character(len=7), parameter :: FMTL_19 = "A3,16x" character(len=7), parameter :: FMTL_12 = "A3,9x" character(len=7) :: fmt, fmtl integer :: u u = given_output_unit (unit) call pac_fmt (fmt, FMT_19, FMT_12, testflag) call pac_fmt (fmtl, FMTL_19, FMTL_12, testflag) select case (evt%mode) case (ISR_PAIR_RECOIL) write (u, "(1x,A)") "Event:" write (u, "(3x,A,2(1x," // fmtl // "))") & "mode = ", & char (rad_mode_string (evt%rad_mode(1))), & char (rad_mode_string (evt%rad_mode(2))) write (u, "(3x,A,2(1x," // fmt // "))") "Q_max =", evt%q_max write (u, "(3x,A,2(1x," // fmt // "))") "m =", evt%m write (u, "(3x,A,2(1x," // fmt // "))") "x =", evt%xc write (u, "(3x,A,2(1x," // fmt // "))") "xb =", evt%xcb write (u, "(3x,A,1x," // fmt // ")") "sqrts =", evt%sqrts call write_separator (u) write (u, "(A)") "Lorentz boost (partons before radiation & &c.m. -> lab) =" call evt%lti%write (u, testflag) write (u, "(A)") "Lorentz transformation (collinear partons & &-> partons with recoil in c.m.) =" call evt%lto%write (u, testflag) write (u, "(A)") "Combined transformation (partons & &-> partons with recoil in lab frame) =" call evt%lt%write (u, testflag) end select end subroutine evt_isr_epa_write_data @ %def evt_isr_epa_write_data @ Output method. <>= procedure :: write => evt_isr_epa_write <>= subroutine evt_isr_epa_write (evt, unit, verbose, more_verbose, testflag) class(evt_isr_epa_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag logical :: show_mass integer :: u, i u = given_output_unit (unit) if (present (testflag)) then show_mass = .not. testflag else show_mass = .true. end if call write_separator (u, 2) call evt%write_name (u) call write_separator (u, 2) call evt%write_mode (u) call evt%write_input (u, testflag=testflag) call evt%write_data (u, testflag=testflag) call write_separator (u) call evt%base_write (u, testflag = testflag, show_set = .false.) if (all (evt%i_beam > 0)) then call write_separator (u) write (u, "(A,2(1x,I0))") "Partons before radiation:", evt%i_beam do i = 1, 2 call evt%beam(i)%write (u, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... boosted to c.m.:" do i = 1, 2 call evt%pi(i)%write (u, show_mass=show_mass, testflag=testflag) end do end if if (all (evt%i_radiated > 0)) then call write_separator (u) write (u, "(A,2(1x,I0))") "Radiated particles, collinear:", & evt%i_radiated do i = 1, 2 call evt%radiated(i)%write (u, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... boosted to c.m.:" do i = 1, 2 call evt%ki(i)%write (u, show_mass=show_mass, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... with kT:" do i = 1, 2 call evt%km(i)%write (u, show_mass=show_mass, testflag=testflag) end do end if if (all (evt%i_parton > 0)) then call write_separator (u) write (u, "(A,2(1x,I0))") "Partons after radiation, collinear:", & evt%i_parton do i = 1, 2 call evt%parton(i)%write (u, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... boosted to c.m.:" do i = 1, 2 call evt%qi(i)%write (u, show_mass=show_mass, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... with qT, off-shell:" do i = 1, 2 call evt%qm(i)%write (u, show_mass=show_mass, testflag=testflag) end do call write_separator (u) write (u, "(A)") "... projected on-shell:" do i = 1, 2 call evt%qo(i)%write (u, show_mass=show_mass, testflag=testflag) end do call write_separator (u) end if if (evt%particle_set_exists) & call evt%particle_set%write & (u, summary = .true., compressed = .true., testflag = testflag) call write_separator (u) end subroutine evt_isr_epa_write @ %def evt_isr_epa_write @ \subsection{Initialization} Manually import a random-number generator object. This should be done only for testing purposes. The standard procedure is to [[connect]] a process to an event transform; this will create an appropriate [[rng]] from the RNG factory in the process object. <>= procedure :: import_rng => evt_isr_epa_import_rng <>= subroutine evt_isr_epa_import_rng (evt, rng) class(evt_isr_epa_t), intent(inout) :: evt class(rng_t), allocatable, intent(inout) :: rng call move_alloc (from = rng, to = evt%rng) end subroutine evt_isr_epa_import_rng @ %def evt_isr_epa_import_rng @ Set constant kinematics limits and initialize for ISR. Note that [[sqrts]] is used only as the fallback value for [[q_max]]. The actual [[sqrts]] value for the transform object is inferred from the incoming particles, event by event. <>= procedure :: set_data_isr => evt_isr_epa_set_data_isr <>= subroutine evt_isr_epa_set_data_isr (evt, sqrts, q_max, m, keep_mass) class(evt_isr_epa_t), intent(inout) :: evt real(default), intent(in) :: sqrts real(default), intent(in) :: q_max real(default), intent(in) :: m logical, intent(in) :: keep_mass if (sqrts <= 0) then call msg_fatal ("ISR handler: sqrts value must be positive") end if if (q_max <= 0 .or. q_max > sqrts) then evt%isr_q_max = sqrts else evt%isr_q_max = q_max end if if (m > 0) then evt%isr_mass = m else call msg_fatal ("ISR handler: ISR_mass value must be positive") end if evt%isr_active = .true. evt%isr_keep_mass = keep_mass end subroutine evt_isr_epa_set_data_isr @ %def evt_isr_epa_set_data_isr @ Set constant kinematics limits and initialize for EPA. Note that [[sqrts]] is used only as the fallback value for [[q_max]]. The actual [[sqrts]] value for the transform object is inferred from the incoming particles, event by event. <>= procedure :: set_data_epa => evt_isr_epa_set_data_epa <>= subroutine evt_isr_epa_set_data_epa (evt, sqrts, q_max, m) class(evt_isr_epa_t), intent(inout) :: evt real(default), intent(in) :: sqrts real(default), intent(in) :: q_max real(default), intent(in) :: m if (sqrts <= 0) then call msg_fatal ("EPA handler: sqrts value must be positive") end if if (q_max <= 0 .or. q_max > sqrts) then evt%epa_q_max = sqrts else evt%epa_q_max = q_max end if if (m > 0) then evt%epa_mass = m else call msg_fatal ("EPA handler: EPA_mass value must be positive") end if evt%epa_active = .true. end subroutine evt_isr_epa_set_data_epa @ %def evt_isr_epa_set_data_epa @ \subsection{Fetch event data} Identify the radiated particles and the recoil momenta in the particle set. Without much sophistication, start from the end and find particles with the ``remnant'' status. Their parents should point to the recoiling parton. If successful, set the particle indices in the [[evt]] object, for further processing. <>= procedure, private :: identify_radiated <>= subroutine identify_radiated (evt) class(evt_isr_epa_t), intent(inout) :: evt integer :: i, k k = 2 FIND_LAST_RADIATED: do i = evt%particle_set%get_n_tot (), 1, -1 associate (prt => evt%particle_set%prt(i)) if (prt%is_beam_remnant ()) then evt%i_radiated(k) = i evt%radiated(k) = prt k = k - 1 if (k == 0) exit FIND_LAST_RADIATED end if end associate end do FIND_LAST_RADIATED if (k /= 0) call err_count contains subroutine err_count call evt%particle_set%write () call msg_fatal ("ISR/EPA handler: & &event does not contain two radiated particles") end subroutine err_count end subroutine identify_radiated @ %def identify_radiated @ When the radiated particles are known, we can fetch their parent particles and ask for the other child, the incoming parton. <>= procedure, private :: identify_partons <>= subroutine identify_partons (evt) class(evt_isr_epa_t), intent(inout) :: evt integer, dimension(:), allocatable :: parent, child integer :: i, j if (all (evt%i_radiated > 0)) then do i = 1, 2 parent = evt%radiated(i)%get_parents () if (size (parent) /= 1) call err_mismatch evt%i_beam(i) = parent(1) evt%beam(i) = evt%particle_set%prt(parent(1)) associate (prt => evt%beam(i)) child = prt%get_children () if (size (child) /= 2) call err_mismatch do j = 1, 2 if (child(j) /= evt%i_radiated(i)) then evt%i_parton(i) = child(j) evt%parton(i) = evt%particle_set%prt(child(j)) end if end do end associate end do end if contains subroutine err_mismatch call evt%particle_set%write () call msg_bug ("ISR/EPA handler: mismatch in parent-child relations") end subroutine err_mismatch end subroutine identify_partons @ %def identify_partons @ Check whether the radiated particle is a photon, or the incoming parton is a photon. Then set the ISR/EPA switch appropriately, for each beam. <>= procedure :: check_radiation => evt_isr_epa_check_radiation <>= subroutine evt_isr_epa_check_radiation (evt) class(evt_isr_epa_t), intent(inout) :: evt type(flavor_t) :: flv integer :: i do i = 1, 2 flv = evt%radiated(i)%get_flv () if (flv%get_pdg () == PHOTON) then if (evt%isr_active) then evt%rad_mode(i) = BEAM_RAD_ISR else call err_isr_init end if else flv = evt%parton(i)%get_flv () if (flv%get_pdg () == PHOTON) then if (evt%epa_active) then evt%rad_mode(i) = BEAM_RAD_EPA else call err_epa_init end if else call err_no_photon end if end if end do contains subroutine err_isr_init call evt%particle_set%write () call msg_fatal ("ISR/EPA handler: & &event contains radiated photon, but ISR is not initialized") end subroutine err_isr_init subroutine err_epa_init call evt%particle_set%write () call msg_fatal ("ISR/EPA handler: & &event contains incoming photon, but EPA is not initialized") end subroutine err_epa_init subroutine err_no_photon call evt%particle_set%write () call msg_fatal ("ISR/EPA handler: & &event does not appear to be ISR or EPA - missing photon") end subroutine err_no_photon end subroutine evt_isr_epa_check_radiation @ %def evt_isr_epa_check_radiation @ Internally set the appropriate parameters (ISR/EPA) for the two beams in the recoil mode. <>= procedure :: set_recoil_parameters => evt_isr_epa_set_recoil_parameters <>= subroutine evt_isr_epa_set_recoil_parameters (evt) class(evt_isr_epa_t), intent(inout) :: evt integer :: i do i = 1, 2 select case (evt%rad_mode(i)) case (BEAM_RAD_ISR) evt%q_max(i) = evt%isr_q_max evt%m(i) = evt%isr_mass case (BEAM_RAD_EPA) evt%q_max(i) = evt%epa_q_max evt%m(i) = evt%epa_mass end select end do end subroutine evt_isr_epa_set_recoil_parameters @ %def evt_isr_epa_set_recoil_parameters @ Boost the particles that participate in ISR to their proper c.m.\ frame, copying the momenta to [[pi]], [[ki]], [[qi]]. Also assign [[sqrts]] properly. <>= procedure, private :: boost_to_cm <>= subroutine boost_to_cm (evt) class(evt_isr_epa_t), intent(inout) :: evt type(vector4_t), dimension(2) :: p type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q logical :: ok p = evt%beam%get_momentum () k = evt%radiated%get_momentum () q = evt%parton%get_momentum () call initial_transformation (p, evt%sqrts, evt%lti, ok) if (.not. ok) call err_non_collinear evt%pi = inverse (evt%lti) * p evt%ki = inverse (evt%lti) * k evt%qi = inverse (evt%lti) * q contains subroutine err_non_collinear call evt%particle_set%write () call msg_fatal ("ISR/EPA handler: & &partons before radiation are not collinear") end subroutine err_non_collinear end subroutine boost_to_cm @ %def boost_to_cm @ We can infer the $x$ and $\bar x$ values of the event by looking at the energy fractions of the radiated particles and incoming partons, respectively, relative to their parents. Of course, we must assume that they are all collinear, and that energy is conserved. <>= procedure, private :: infer_x <>= subroutine infer_x (evt) class(evt_isr_epa_t), intent(inout) :: evt real(default) :: E_parent, E_radiated, E_parton integer :: i if (all (evt%i_radiated > 0)) then do i = 1, 2 E_parent = energy (evt%pi(i)) E_radiated = energy (evt%ki(i)) E_parton = energy (evt%qi(i)) if (E_parent > 0) then evt%xc(i) = E_parton / E_parent evt%xcb(i)= E_radiated / E_parent else call err_energy end if end do end if contains subroutine err_energy call evt%particle_set%write () call msg_bug ("ISR/EPA handler: non-positive energy in splitting") end subroutine err_energy end subroutine infer_x @ %def infer_x @ \subsection{Two-parton recoil} For transforming partons into recoil momenta, we make use of the routines in the [[recoil_kinematics]] module. In addition to the collinear momenta, we use the $x$ energy fractions, and four numbers from the RNG. There is one subtle difference w.r.t.\ ISR case: the EPA mass parameter is multiplied by the energy fraction $x$, separately for each beam. This is the effective lower $Q$ cutoff. For certain kinematics, close to the $Q_\text{max}$ endpoint, this may fail, and [[ok]] is set to false. In that case, we should generate new recoil momenta for the same event. This is handled by the generic unweighting procedure. <>= procedure, private :: generate_recoil => evt_generate_recoil <>= subroutine evt_generate_recoil (evt, ok) class(evt_isr_epa_t), intent(inout) :: evt logical, intent(out) :: ok real(default), dimension(4) :: r real(default), dimension(2) :: m, mo integer :: i call evt%rng%generate (r) m = 0 mo = 0 do i = 1, 2 select case (evt%rad_mode(i)) case (BEAM_RAD_ISR) m(i) = evt%m(i) if (evt%isr_keep_mass) mo(i) = m(i) case (BEAM_RAD_EPA) m(i) = evt%xc(i) * evt%m(i) end select end do call generate_recoil (evt%sqrts, evt%q_max, m, mo, evt%xc, evt%xcb, r, & evt%km, evt%qm, evt%qo, ok) end subroutine evt_generate_recoil @ %def evt_generate_recoil @ Replace the collinear radiated (incoming) parton momenta by the momenta that we have generated, respectively. Recall that the recoil has been applied in the c.m.\ system of the partons before ISR, so we apply the stored Lorentz transformation to boost them to the lab frame. <>= procedure, private :: replace_radiated procedure, private :: replace_partons <>= subroutine replace_radiated (evt) class(evt_isr_epa_t), intent(inout) :: evt integer :: i do i = 1, 2 associate (prt => evt%particle_set%prt(evt%i_radiated(i))) call prt%set_momentum (evt%lti * evt%km(i)) end associate end do end subroutine replace_radiated subroutine replace_partons (evt) class(evt_isr_epa_t), intent(inout) :: evt integer :: i do i = 1, 2 associate (prt => evt%particle_set%prt(evt%i_parton(i))) call prt%set_momentum (evt%lti * evt%qo(i)) end associate end do end subroutine replace_partons @ %def replace_radiated @ %def replace_partons @ \subsection{Transform the event} Knowing the new incoming partons for the elementary process, we can make use of another procedure in [[recoil_kinematics]] to determine the Lorentz transformation that transforms the collinear frame into the frame with transverse momentum. We apply this transformation, recursively, to all particles that originate from those incoming partons in the original particle set. We have to allow for the pre-ISR partons being not in their common c.m.\ frame. Taking into account non-commutativity, we actually have to first transform the outgoing particles to that c.m.\ frame, then apply the recoil transformation, then boost back to the lab frame. The [[mask]] keep track of particles that we transform, just in case the parent-child tree is multiply connected. <>= procedure :: transform_outgoing => evt_transform_outgoing <>= subroutine evt_transform_outgoing (evt) class(evt_isr_epa_t), intent(inout) :: evt logical, dimension(:), allocatable :: mask call recoil_transformation (evt%sqrts, evt%xc, evt%qo, evt%lto) evt%lt = evt%lti * evt%lto * inverse (evt%lti) allocate (mask (evt%particle_set%get_n_tot ()), source=.false.) call transform_children (evt%i_parton(1)) contains recursive subroutine transform_children (i) integer, intent(in) :: i integer :: j, n_child, c integer, dimension(:), allocatable :: child child = evt%particle_set%prt(i)%get_children () do j = 1, size (child) c = child(j) if (.not. mask(c)) then associate (prt => evt%particle_set%prt(c)) call prt%set_momentum (evt%lt * prt%get_momentum ()) mask(c) = .true. call transform_children (c) end associate end if end do end subroutine transform_children end subroutine evt_transform_outgoing @ %def evt_transform_outgoing @ \subsection{Implemented methods} Here we take the particle set from the previous event transform and copy it, then generate the transverse momentum for the radiated particles and for the incoming partons. If this fails (rarely, for large $p_T$), return zero for the probability, to trigger another try. NOTE: The boost for the initial partonic system, if not in the c.m.\ frame, has not been implemented yet. <>= procedure :: generate_weighted => & evt_isr_epa_generate_weighted <>= subroutine evt_isr_epa_generate_weighted (evt, probability) class(evt_isr_epa_t), intent(inout) :: evt real(default), intent(inout) :: probability logical :: valid call evt%particle_set%final () evt%particle_set = evt%previous%particle_set evt%particle_set_exists = .true. select case (evt%mode) case (ISR_TRIVIAL_COLLINEAR) probability = 1 valid = .true. case (ISR_PAIR_RECOIL) call evt%identify_radiated () call evt%identify_partons () call evt%check_radiation () call evt%set_recoil_parameters () call evt%boost_to_cm () call evt%infer_x () call evt%generate_recoil (valid) if (valid) then probability = 1 else probability = 0 end if case default call msg_bug ("ISR/EPA handler: generate weighted: unsupported mode") end select evt%particle_set_exists = .false. end subroutine evt_isr_epa_generate_weighted @ %def evt_isr_epa_generate_weighted @ Insert the generated radiated particles and incoming partons with $p_T$ in their respective places. The factorization parameters are irrelevant. <>= procedure :: make_particle_set => & evt_isr_epa_make_particle_set <>= subroutine evt_isr_epa_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_isr_epa_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r select case (evt%mode) case (ISR_TRIVIAL_COLLINEAR) case (ISR_PAIR_RECOIL) call evt%replace_radiated () call evt%replace_partons () call evt%transform_outgoing () case default call msg_bug ("ISR/EPA handler: make particle set: unsupported mode") end select evt%particle_set_exists = .true. end subroutine evt_isr_epa_make_particle_set @ %def event_isr_epa_handler_make_particle_set @ <>= procedure :: prepare_new_event => & evt_isr_epa_prepare_new_event <>= subroutine evt_isr_epa_prepare_new_event (evt, i_mci, i_term) class(evt_isr_epa_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () end subroutine evt_isr_epa_prepare_new_event @ %def evt_isr_epa_prepare_new_event @ \subsection{Unit tests: ISR} Test module, followed by the corresponding implementation module. This test module differs from most of the other test modules, since it contains two test subroutines: one for ISR and one for EPA below. <<[[isr_epa_handler_ut.f90]]>>= <> module isr_epa_handler_ut use unit_tests use isr_epa_handler_uti <> <> contains <> end module isr_epa_handler_ut @ %def isr_epa_handler_ut @ <<[[isr_epa_handler_uti.f90]]>>= <> module isr_epa_handler_uti <> <> use format_utils, only: write_separator use os_interface use lorentz, only: vector4_t, vector4_moving, operator(*) use rng_base, only: rng_t use models, only: syntax_model_file_init, syntax_model_file_final use models, only: model_list_t, model_t use particles, only: particle_set_t use event_transforms use isr_epa_handler, only: evt_isr_epa_t use rng_base_ut, only: rng_test_t <> <> contains <> end module isr_epa_handler_uti @ %def isr_epa_handler_uti @ API: driver for the unit tests below. <>= public :: isr_handler_test <>= subroutine isr_handler_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine isr_handler_test @ %def isr_handler_test @ \subsubsection{Trivial case} Handle photons resulting from ISR radiation. This test is for the trivial case where the event is kept collinear. <>= call test (isr_handler_1, "isr_handler_1", & "collinear case, no modification", & u, results) <>= public :: isr_handler_1 <>= subroutine isr_handler_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x, xb real(default) :: probability write (u, "(A)") "* Test output: isr_handler_1" write (u, "(A)") "* Purpose: apply photon handler trivially (no-op)" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 11, -11, 22, 22, 13, -13], model = model) sqrts = 100._default x = [0.6_default, 0.9_default] xb= 1 - x p(1) = vector4_moving (sqrts/2, sqrts/2, 3) p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize ISR handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%write (u) write (u, "(A)") write (u, "(A)") "* Fill ISR handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: isr_handler_1" end subroutine isr_handler_1 @ %def isr_handler_1 @ \subsubsection{Photon pair with recoil} Handle photons resulting from ISR radiation. This test invokes the two-photon recoil mechanism. Both photons acquire transverse momentum, the parton momenta recoil, such that total energy-momentum is conserved, and all outgoing photons and partons are on-shell (massless). <>= call test (isr_handler_2, "isr_handler_2", & "two-photon recoil", & u, results) <>= public :: isr_handler_2 <>= subroutine isr_handler_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x, xb class(rng_t), allocatable :: rng real(default) :: probability write (u, "(A)") "* Test output: isr_handler_2" write (u, "(A)") "* Purpose: apply photon handler with two-photon recoil" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 11, -11, 22, 22, 13, -13], model = model) sqrts = 100._default x = [0.6_default, 0.9_default] xb= 1 - x p(1) = vector4_moving (sqrts/2, sqrts/2, 3) p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize ISR handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%set_mode_string (var_str ("recoil")) call evt_isr_epa%set_data_isr ( & sqrts = sqrts, & q_max = sqrts, & m = 511.e-3_default, & keep_mass = .false. & ) allocate (rng_test_t :: rng) call rng%init (3) ! default would produce pi for azimuthal angle call evt_isr_epa%import_rng (rng) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill ISR handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: isr_handler_2" end subroutine isr_handler_2 @ %def isr_handler_2 @ \subsubsection{Boosted beams} Handle photons resulting from ISR radiation. This test invokes the two-photon recoil mechanism, in the case that the partons before ISR are not in their c.m.\ frame (but collinear). <>= call test (isr_handler_3, "isr_handler_3", & "two-photon recoil with boost", & u, results) <>= public :: isr_handler_3 <>= subroutine isr_handler_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x0 real(default), dimension(2) :: x, xb class(rng_t), allocatable :: rng real(default) :: probability write (u, "(A)") "* Test output: isr_handler_3" write (u, "(A)") "* Purpose: apply photon handler for boosted beams & &and two-photon recoil" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 11, -11, 22, 22, 13, -13], model = model) write (u, "(A)") "* Event data" write (u, "(A)") sqrts = 100._default write (u, "(A,2(1x,F12.7))") "sqrts =", sqrts x0 = [0.9_default, 0.4_default] write (u, "(A,2(1x,F12.7))") "x0 =", x0 write (u, "(A)") write (u, "(A,2(1x,F12.7))") "sqs_hat =", sqrts * sqrt (product (x0)) x = [0.6_default, 0.9_default] xb= 1 - x write (u, "(A,2(1x,F12.7))") "x =", x write (u, "(A)") write (u, "(A,2(1x,F12.7))") "x0 * x =", x0 * x p(1) = x0(1) * vector4_moving (sqrts/2, sqrts/2, 3) p(2) = x0(2) * vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize ISR handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%set_mode_string (var_str ("recoil")) call evt_isr_epa%set_data_isr ( & sqrts = sqrts, & q_max = sqrts, & m = 511.e-3_default, & keep_mass = .false. & ) allocate (rng_test_t :: rng) call rng%init (3) ! default would produce pi for azimuthal angle call evt_isr_epa%import_rng (rng) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill ISR handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: isr_handler_3" end subroutine isr_handler_3 @ %def isr_handler_3 @ \subsection{Unit tests: EPA} API: Extra driver for the unit tests below. <>= public :: epa_handler_test <>= subroutine epa_handler_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine epa_handler_test @ %def epa_handler_test @ \subsubsection{Trivial case} Handle events resulting from the EPA approximation. This test is for the trivial case where the event is kept collinear. <>= call test (epa_handler_1, "epa_handler_1", & "collinear case, no modification", & u, results) <>= public :: epa_handler_1 <>= subroutine epa_handler_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x, xb real(default) :: probability write (u, "(A)") "* Test output: epa_handler_1" write (u, "(A)") "* Purpose: apply beam handler trivially (no-op)" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct & (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 22, 22, 11, -11, 13, -13], & model = model) sqrts = 100._default x = [0.6_default, 0.9_default] xb= 1 - x p(1) = vector4_moving (sqrts/2, sqrts/2, 3) p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize EPA handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%write (u) write (u, "(A)") write (u, "(A)") "* Fill EPA handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: epa_handler_1" end subroutine epa_handler_1 @ %def epa_handler_1 @ \subsubsection{Beam pair with recoil} Handle beams resulting from the EPA approximation. This test invokes the two-beam recoil mechanism. Both beam remnants acquire transverse momentum, the photon momenta recoil, such that total energy-momentum is conserved, and all outgoing beam remnants and photons are on-shell (massless). <>= call test (epa_handler_2, "epa_handler_2", & "two-beam recoil", & u, results) <>= public :: epa_handler_2 <>= subroutine epa_handler_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x, xb class(rng_t), allocatable :: rng real(default) :: probability write (u, "(A)") "* Test output: epa_handler_2" write (u, "(A)") "* Purpose: apply beam handler with two-beam recoil" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 22, 22, 11, -11, 13, -13], model = model) sqrts = 100._default x = [0.6_default, 0.9_default] xb= 1 - x p(1) = vector4_moving (sqrts/2, sqrts/2, 3) p(2) = vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize EPA handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%set_mode_string (var_str ("recoil")) call evt_isr_epa%set_data_epa ( & sqrts = sqrts, & q_max = sqrts, & m = 511.e-3_default & ) allocate (rng_test_t :: rng) call rng%init (3) ! default would produce pi for azimuthal angle call evt_isr_epa%import_rng (rng) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill EPA handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: epa_handler_2" end subroutine epa_handler_2 @ %def epa_handler_2 @ \subsubsection{Boosted beams} Handle radiated beam remnants resulting from EPA radiation. This test invokes the two-beam recoil mechanism, in the case that the partons before EPA are not in their c.m.\ frame (but collinear). <>= call test (epa_handler_3, "epa_handler_3", & "two-beam recoil with boost", & u, results) <>= public :: epa_handler_3 <>= subroutine epa_handler_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(particle_set_t) :: pset type(model_list_t) :: model_list type(model_t), pointer :: model type(evt_trivial_t), target :: evt_trivial type(evt_isr_epa_t), target :: evt_isr_epa type(vector4_t), dimension(8) :: p real(default) :: sqrts real(default), dimension(2) :: x0 real(default), dimension(2) :: x, xb class(rng_t), allocatable :: rng real(default) :: probability write (u, "(A)") "* Test output: epa_handler_3" write (u, "(A)") "* Purpose: apply beam handler for boosted beams & &and two-beam recoil" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Initialize particle set" write (u, "(A)") call pset%init_direct (n_beam = 2, n_in = 2, n_rem = 2, n_vir = 0, n_out = 2, & pdg = [11, -11, 22, 22, 11, -11, 13, -13], model = model) write (u, "(A)") "* Event data" write (u, "(A)") sqrts = 100._default write (u, "(A,2(1x,F12.7))") "sqrts =", sqrts x0 = [0.9_default, 0.4_default] write (u, "(A,2(1x,F12.7))") "x0 =", x0 write (u, "(A)") write (u, "(A,2(1x,F12.7))") "sqs_hat =", sqrts * sqrt (product (x0)) x = [0.6_default, 0.9_default] xb= 1 - x write (u, "(A,2(1x,F12.7))") "x =", x write (u, "(A)") write (u, "(A,2(1x,F12.7))") "x0 * x =", x0 * x p(1) = x0(1) * vector4_moving (sqrts/2, sqrts/2, 3) p(2) = x0(2) * vector4_moving (sqrts/2,-sqrts/2, 3) p(3:4) = x * p(1:2) p(5:6) = xb * p(1:2) p(7:8) = p(3:4) call pset%set_momentum (p, on_shell = .false.) write (u, "(A)") write (u, "(A)") "* Fill trivial event transform" write (u, "(A)") call evt_trivial%reset () call evt_trivial%set_particle_set (pset, 1, 1) call evt_trivial%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Initialize EPA handler transform" write (u, "(A)") evt_trivial%next => evt_isr_epa evt_isr_epa%previous => evt_trivial call evt_isr_epa%set_mode_string (var_str ("recoil")) call evt_isr_epa%set_data_epa ( & sqrts = sqrts, & q_max = sqrts, & m = 511.e-3_default & ) allocate (rng_test_t :: rng) call rng%init (3) ! default would produce pi for azimuthal angle call evt_isr_epa%import_rng (rng) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A)") "* Fill EPA handler transform" write (u, "(A)") call evt_isr_epa%prepare_new_event (1, 1) call evt_isr_epa%generate_weighted (probability) call evt_isr_epa%make_particle_set (0, .false.) call evt_isr_epa%write (u, testflag=.true.) write (u, "(A)") write (u, "(A,1x,F8.5)") "Event probability =", probability write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_isr_epa%final () call evt_trivial%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: epa_handler_3" end subroutine epa_handler_3 @ %def epa_handler_3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Decays} <<[[decays.f90]]>>= <> module decays <> <> use io_units use format_utils, only: write_indent, write_separator use format_defs, only: FMT_15 use numeric_utils use diagnostics use flavors use helicities use quantum_numbers use interactions use evaluators use variables, only: var_list_t use model_data use rng_base use selectors use parton_states use process, only: process_t use instances, only: process_instance_t, pacify use process_stacks use event_transforms <> <> <> <> contains <> end module decays @ %def decays @ \subsection{Final-State Particle Configuration} A final-state particle may be either stable or unstable. Here is an empty abstract type as the parent of both, with holds just the flavor information. <>= type, abstract :: any_config_t private contains <> end type any_config_t @ %def any_config_t @ Finalizer, depends on the implementation. <>= procedure (any_config_final), deferred :: final <>= interface subroutine any_config_final (object) import class(any_config_t), intent(inout) :: object end subroutine any_config_final end interface @ %def any_config_final @ The output is also deferred: <>= procedure (any_config_write), deferred :: write <>= interface subroutine any_config_write (object, unit, indent, verbose) import class(any_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose end subroutine any_config_write end interface @ %def any_config_write @ This is a container for a stable or unstable particle configurator. We need this wrapper for preparing arrays that mix stable and unstable particles. <>= type :: particle_config_t private class(any_config_t), allocatable :: c end type particle_config_t @ %def particle_config_t @ \subsection{Final-State Particle} In theory, for the particle instance we only need to consider the unstable case. However, it is more straightforward to treat configuration and instance on the same footing, and to introduce a wrapper for particle objects as above. <>= type, abstract :: any_t private contains <> end type any_t @ %def any_t @ Finalizer, depends on the implementation. <>= procedure (any_final), deferred :: final <>= interface subroutine any_final (object) import class(any_t), intent(inout) :: object end subroutine any_final end interface @ %def any_final @ The output is also deferred: <>= procedure (any_write), deferred :: write <>= interface subroutine any_write (object, unit, indent) import class(any_t), intent(in) :: object integer, intent(in), optional :: unit, indent end subroutine any_write end interface @ %def any_write @ This is a container for a stable or unstable outgoing particle. We need this wrapper for preparing arrays that mix stable and unstable particles. <>= type :: particle_out_t private class(any_t), allocatable :: c end type particle_out_t @ %def particle_config_t @ \subsection{Decay Term Configuration} A decay term is a distinct final state, corresponding to a process term. Each decay process may give rise to several terms with, possibly, differing flavor content. <>= type :: decay_term_config_t private type(particle_config_t), dimension(:), allocatable :: prt contains <> end type decay_term_config_t @ %def decay_term_config_t @ Finalizer, recursive. <>= procedure :: final => decay_term_config_final <>= recursive subroutine decay_term_config_final (object) class(decay_term_config_t), intent(inout) :: object integer :: i if (allocated (object%prt)) then do i = 1, size (object%prt) if (allocated (object%prt(i)%c)) call object%prt(i)%c%final () end do end if end subroutine decay_term_config_final @ %def decay_term_config_final @ Output, with optional indentation <>= procedure :: write => decay_term_config_write <>= recursive subroutine decay_term_config_write (object, unit, indent, verbose) class(decay_term_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: i, j, u, ind logical :: verb u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent verb = .true.; if (present (verbose)) verb = verbose call write_indent (u, ind) write (u, "(1x,A)", advance="no") "Final state:" do i = 1, size (object%prt) select type (prt_config => object%prt(i)%c) type is (stable_config_t) write (u, "(1x,A)", advance="no") & char (prt_config%flv(1)%get_name ()) do j = 2, size (prt_config%flv) write (u, "(':',A)", advance="no") & char (prt_config%flv(j)%get_name ()) end do type is (unstable_config_t) write (u, "(1x,A)", advance="no") & char (prt_config%flv%get_name ()) end select end do write (u, *) if (verb) then do i = 1, size (object%prt) call object%prt(i)%c%write (u, ind) end do end if end subroutine decay_term_config_write @ %def decay_term_config_write @ Initialize, given a set of flavors. For each flavor, we must indicate whether the particle is stable. The second index of the flavor array runs over alternatives for each decay product; alternatives are allowed only if the decay product is itself stable. <>= procedure :: init => decay_term_config_init <>= recursive subroutine decay_term_config_init & (term, flv, stable, model, process_stack, var_list) class(decay_term_config_t), intent(out) :: term type(flavor_t), dimension(:,:), intent(in) :: flv logical, dimension(:), intent(in) :: stable class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(var_list_t), intent(in), optional :: var_list type(string_t), dimension(:), allocatable :: decay integer :: i allocate (term%prt (size (flv, 1))) do i = 1, size (flv, 1) associate (prt => term%prt(i)) if (stable(i)) then allocate (stable_config_t :: prt%c) else allocate (unstable_config_t :: prt%c) end if select type (prt_config => prt%c) type is (stable_config_t) call prt_config%init (flv(i,:)) type is (unstable_config_t) if (all (flv(i,:) == flv(i,1))) then call prt_config%init (flv(i,1)) call flv(i,1)%get_decays (decay) call prt_config%init_decays & (decay, model, process_stack, var_list) else call prt_config%write () call msg_fatal ("Decay configuration: & &unstable product must be unique") end if end select end associate end do end subroutine decay_term_config_init @ %def decay_term_config_init @ Recursively compute widths and branching ratios for all unstable particles. <>= procedure :: compute => decay_term_config_compute <>= recursive subroutine decay_term_config_compute (term) class(decay_term_config_t), intent(inout) :: term integer :: i do i = 1, size (term%prt) select type (unstable_config => term%prt(i)%c) type is (unstable_config_t) call unstable_config%compute () end select end do end subroutine decay_term_config_compute @ %def decay_term_config_compute @ \subsection{Decay Term} A decay term instance is selected when we generate an event for the associated process instance. When evaluated, it triggers further decays down the chain. Only unstable products are allocated as child particles. <>= type :: decay_term_t private type(decay_term_config_t), pointer :: config => null () type(particle_out_t), dimension(:), allocatable :: particle_out contains <> end type decay_term_t @ %def decay_term_t @ Finalizer. <>= procedure :: final => decay_term_final <>= recursive subroutine decay_term_final (object) class(decay_term_t), intent(inout) :: object integer :: i if (allocated (object%particle_out)) then do i = 1, size (object%particle_out) call object%particle_out(i)%c%final () end do end if end subroutine decay_term_final @ %def decay_term_final @ Output. <>= procedure :: write => decay_term_write <>= recursive subroutine decay_term_write (object, unit, indent) class(decay_term_t), intent(in) :: object integer, intent(in), optional :: unit, indent integer :: i, u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call object%config%write (u, ind, verbose = .false.) do i = 1, size (object%particle_out) call object%particle_out(i)%c%write (u, ind) end do end subroutine decay_term_write @ %def decay_term_write @ Recursively write the embedded process instances. <>= procedure :: write_process_instances => decay_term_write_process_instances <>= recursive subroutine decay_term_write_process_instances (term, unit, verbose) class(decay_term_t), intent(in) :: term integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call unstable%write_process_instances (unit, verbose) end select end do end subroutine decay_term_write_process_instances @ %def decay_term_write_process_instances @ Initialization, using the configuration object. We allocate particle objects in parallel to the particle configuration objects which we use to initialize them, one at a time. <>= procedure :: init => decay_term_init <>= recursive subroutine decay_term_init (term, config) class(decay_term_t), intent(out) :: term type(decay_term_config_t), intent(in), target :: config integer :: i term%config => config allocate (term%particle_out (size (config%prt))) do i = 1, size (config%prt) select type (prt_config => config%prt(i)%c) type is (stable_config_t) allocate (stable_t :: term%particle_out(i)%c) select type (stable => term%particle_out(i)%c) type is (stable_t) call stable%init (prt_config) end select type is (unstable_config_t) allocate (unstable_t :: term%particle_out(i)%c) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call unstable%init (prt_config) end select end select end do end subroutine decay_term_init @ %def decay_term_init @ Implement a RNG instance, spawned by the process object. <>= procedure :: make_rng => decay_term_make_rng <>= subroutine decay_term_make_rng (term, process) class(decay_term_t), intent(inout) :: term type(process_t), intent(inout) :: process class(rng_t), allocatable :: rng integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call process%make_rng (rng) call unstable%import_rng (rng) end select end do end subroutine decay_term_make_rng @ %def decay_term_make_rng @ Link the interactions for unstable decay products to the interaction of the parent process. <>= procedure :: link_interactions => decay_term_link_interactions <>= recursive subroutine decay_term_link_interactions (term, trace) class(decay_term_t), intent(inout) :: term type(interaction_t), intent(in), target :: trace integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call unstable%link_interactions (i, trace) end select end do end subroutine decay_term_link_interactions @ %def decay_term_link_interactions @ Recursively generate a decay chain, for each of the unstable particles in the final state. <>= procedure :: select_chain => decay_term_select_chain <>= recursive subroutine decay_term_select_chain (term) class(decay_term_t), intent(inout) :: term integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call unstable%select_chain () end select end do end subroutine decay_term_select_chain @ %def decay_term_select_chain @ Recursively generate a decay event, for each of the unstable particles in the final state. <>= procedure :: generate => decay_term_generate <>= recursive subroutine decay_term_generate (term) class(decay_term_t), intent(inout) :: term integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) call unstable%generate () end select end do end subroutine decay_term_generate @ %def decay_term_generate @ \subsection{Decay Root Configuration} At the root of a decay chain, there is a parent process. The decay root stores a pointer to the parent process and the set of decay configurations. <>= public :: decay_root_config_t <>= type :: decay_root_config_t private type(string_t) :: process_id type(process_t), pointer :: process => null () class(model_data_t), pointer :: model => null () type(decay_term_config_t), dimension(:), allocatable :: term_config contains <> end type decay_root_config_t @ %def decay_root_config_t @ The finalizer is recursive since there may be cascade decays. <>= procedure :: final => decay_root_config_final <>= recursive subroutine decay_root_config_final (object) class(decay_root_config_t), intent(inout) :: object integer :: i if (allocated (object%term_config)) then do i = 1, size (object%term_config) call object%term_config(i)%final () end do end if end subroutine decay_root_config_final @ %def decay_root_config_final @ The output routine is also recursive, and it contains an adjustable indentation. <>= procedure :: write => decay_root_config_write procedure :: write_header => decay_root_config_write_header procedure :: write_terms => decay_root_config_write_terms <>= recursive subroutine decay_root_config_write (object, unit, indent, verbose) class(decay_root_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) write (u, "(1x,A)") "Final-state decay tree:" call object%write_header (unit, indent) call object%write_terms (unit, indent, verbose) end subroutine decay_root_config_write subroutine decay_root_config_write_header (object, unit, indent) class(decay_root_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) if (associated (object%process)) then write (u, 3) "process ID =", char (object%process_id), "*" else write (u, 3) "process ID =", char (object%process_id) end if 3 format (3x,A,2(1x,A)) end subroutine decay_root_config_write_header recursive subroutine decay_root_config_write_terms & (object, unit, indent, verbose) class(decay_root_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: i, u, ind logical :: verb u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent verb = .true.; if (present (verbose)) verb = verbose if (verb .and. allocated (object%term_config)) then do i = 1, size (object%term_config) call object%term_config(i)%write (u, ind + 1) end do end if end subroutine decay_root_config_write_terms @ %def decay_root_config_write @ Initialize for a named process and (optionally) a pre-determined number of terms. <>= procedure :: init => decay_root_config_init <>= subroutine decay_root_config_init (decay, model, process_id, n_terms) class(decay_root_config_t), intent(out) :: decay class(model_data_t), intent(in), target :: model type(string_t), intent(in) :: process_id integer, intent(in), optional :: n_terms decay%model => model decay%process_id = process_id if (present (n_terms)) then allocate (decay%term_config (n_terms)) end if end subroutine decay_root_config_init @ %def decay_root_config_init @ Declare a decay term, given an array of flavors. <>= procedure :: init_term => decay_root_config_init_term <>= recursive subroutine decay_root_config_init_term & (decay, i, flv, stable, model, process_stack, var_list) class(decay_root_config_t), intent(inout) :: decay integer, intent(in) :: i type(flavor_t), dimension(:,:), intent(in) :: flv logical, dimension(:), intent(in) :: stable class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(var_list_t), intent(in), optional, target :: var_list call decay%term_config(i)%init (flv, stable, model, process_stack, var_list) end subroutine decay_root_config_init_term @ %def decay_root_config_init_term @ Connect the decay root configuration with a process object (which should represent the parent process). This includes initialization, therefore intent(out). The flavor state is retrieved from the process term object. However, we have to be careful: the flavor object points to the model instance that is stored in the process object. This model instance may not contain the current setting for unstable particles and decay. Therefore, we assign the model directly. If the [[process_instance]] argument is provided, we use this for the flavor state. This applies to the decay root only, where the process can be entangled with a beam setup, and the latter contains beam remnants as further outgoing particles. These must be included in the set of outgoing flavors, since the decay application is also done on the connected state. Infer stability from the particle properties, using the first row in the set of flavor states. For unstable particles, we look for decays, recursively, available from the process stack (if present). For the unstable particles, we have to check whether their masses match between the production and the decay. Fortunately, both versions are available for comparison. The optional [[var_list]] argument may override integral/error values for decay processes. <>= procedure :: connect => decay_root_config_connect <>= recursive subroutine decay_root_config_connect & (decay, process, model, process_stack, process_instance, var_list) class(decay_root_config_t), intent(out) :: decay type(process_t), intent(in), target :: process class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(process_instance_t), intent(in), optional, target :: process_instance type(var_list_t), intent(in), optional, target :: var_list type(connected_state_t), pointer :: connected_state type(interaction_t), pointer :: int type(flavor_t), dimension(:,:), allocatable :: flv logical, dimension(:), allocatable :: stable real(default), dimension(:), allocatable :: m_prod, m_dec integer :: i call decay%init (model, process%get_id (), process%get_n_terms ()) do i = 1, size (decay%term_config) if (present (process_instance)) then connected_state => process_instance%get_connected_state_ptr (i) int => connected_state%get_matrix_int_ptr () - call interaction_get_flv_out (int, flv) + call int%get_flv_out (flv) else call process%get_term_flv_out (i, flv) end if allocate (m_prod (size (flv(:,1)%get_mass ()))) m_prod = flv(:,1)%get_mass () call flv%set_model (model) allocate (m_dec (size (flv(:,1)%get_mass ()))) m_dec = flv(:,1)%get_mass () allocate (stable (size (flv, 1))) stable = flv(:,1)%is_stable () call check_masses () call decay%init_term (i, flv, stable, model, process_stack, var_list) deallocate (flv, stable, m_prod, m_dec) end do decay%process => process contains subroutine check_masses () integer :: i logical :: ok ok = .true. do i = 1, size (m_prod) if (.not. stable(i)) then if (.not. nearly_equal (m_prod(i), m_dec(i))) then write (msg_buffer, "(A,A,A)") "particle '", & char (flv(i,1)%get_name ()), "':" call msg_message write (msg_buffer, & "(2x,A,1x," // FMT_15 // ",3x,A,1x," // FMT_15 // ")") & "m_prod =", m_prod(i), "m_dec =", m_dec(i) call msg_message ok = .false. end if end if end do if (.not. ok) call msg_fatal & ("Particle mass mismatch between production and decay") end subroutine check_masses end subroutine decay_root_config_connect @ %def decay_root_config_connect @ Recursively compute widths, errors, and branching ratios. <>= procedure :: compute => decay_root_config_compute <>= recursive subroutine decay_root_config_compute (decay) class(decay_root_config_t), intent(inout) :: decay integer :: i do i = 1, size (decay%term_config) call decay%term_config(i)%compute () end do end subroutine decay_root_config_compute @ %def decay_root_config_compute @ \subsection{Decay Root Instance} This is the common parent type for decay and decay root. The process instance points to the parent process. The model pointer is separate because particle settings may be updated w.r.t.\ the parent process object. <>= type, abstract :: decay_gen_t private type(decay_term_t), dimension(:), allocatable :: term type(process_instance_t), pointer :: process_instance => null () integer :: selected_mci = 0 integer :: selected_term = 0 contains <> end type decay_gen_t @ %def decay_gen_t @ The decay root represents the parent process. When an event is generated, the generator selects the term to which the decay chain applies (if possible). The process instance is just a pointer. <>= public :: decay_root_t <>= type, extends (decay_gen_t) :: decay_root_t private type(decay_root_config_t), pointer :: config => null () contains <> end type decay_root_t @ %def decay_root_t @ The finalizer has to recursively finalize the terms, but we can skip the process instance which is not explicitly allocated. <>= procedure :: base_final => decay_gen_final <>= recursive subroutine decay_gen_final (object) class(decay_gen_t), intent(inout) :: object integer :: i if (allocated (object%term)) then do i = 1, size (object%term) call object%term(i)%final () end do end if end subroutine decay_gen_final @ %def decay_gen_final @ No extra finalization for the decay root. <>= procedure :: final => decay_root_final <>= subroutine decay_root_final (object) class(decay_root_t), intent(inout) :: object call object%base_final () end subroutine decay_root_final @ %def decay_gen_final @ Output. <>= procedure :: write => decay_root_write <>= subroutine decay_root_write (object, unit) class(decay_root_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (associated (object%config)) then call object%config%write (unit, verbose = .false.) else write (u, "(1x,A)") "Final-state decay tree: [not configured]" end if if (object%selected_mci > 0) then write (u, "(3x,A,I0)") "Selected MCI = ", object%selected_mci else write (u, "(3x,A)") "Selected MCI = [undefined]" end if if (object%selected_term > 0) then write (u, "(3x,A,I0)") "Selected term = ", object%selected_term call object%term(object%selected_term)%write (u, 1) else write (u, "(3x,A)") "Selected term = [undefined]" end if end subroutine decay_root_write @ %def decay_root_write @ Write the process instances, recursively. <>= procedure :: write_process_instances => decay_gen_write_process_instances <>= recursive subroutine decay_gen_write_process_instances (decay, unit, verbose) class(decay_gen_t), intent(in) :: decay integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical :: verb verb = .true.; if (present (verbose)) verb = verbose if (associated (decay%process_instance)) then if (verb) then call decay%process_instance%write (unit) else call decay%process_instance%write_header (unit) end if end if if (decay%selected_term > 0) then call decay%term(decay%selected_term)%write_process_instances (unit, verb) end if end subroutine decay_gen_write_process_instances @ %def decay_gen_write_process_instances @ Generic initializer. All can be done recursively. <>= procedure :: base_init => decay_gen_init <>= recursive subroutine decay_gen_init (decay, term_config) class(decay_gen_t), intent(out) :: decay type(decay_term_config_t), dimension(:), intent(in), target :: term_config integer :: i allocate (decay%term (size (term_config))) do i = 1, size (decay%term) call decay%term(i)%init (term_config(i)) end do end subroutine decay_gen_init @ %def decay_gen_init @ Specific initializer. We assign the configuration object, which should correspond to a completely initialized decay configuration tree. We also connect to an existing process instance. Then, we recursively link the child interactions to the parent process. <>= procedure :: init => decay_root_init <>= subroutine decay_root_init (decay_root, config, process_instance) class(decay_root_t), intent(out) :: decay_root type(decay_root_config_t), intent(in), target :: config type(process_instance_t), intent(in), target :: process_instance call decay_root%base_init (config%term_config) decay_root%config => config decay_root%process_instance => process_instance call decay_root%make_term_rng (config%process) call decay_root%link_term_interactions () end subroutine decay_root_init @ %def decay_root_init @ Explicitly set/get mci and term indices. (Used in unit test.) <>= procedure :: set_mci => decay_gen_set_mci procedure :: set_term => decay_gen_set_term procedure :: get_mci => decay_gen_get_mci procedure :: get_term => decay_gen_get_term <>= subroutine decay_gen_set_mci (decay, i) class(decay_gen_t), intent(inout) :: decay integer, intent(in) :: i decay%selected_mci = i end subroutine decay_gen_set_mci subroutine decay_gen_set_term (decay, i) class(decay_gen_t), intent(inout) :: decay integer, intent(in) :: i decay%selected_term = i end subroutine decay_gen_set_term function decay_gen_get_mci (decay) result (i) class(decay_gen_t), intent(inout) :: decay integer :: i i = decay%selected_mci end function decay_gen_get_mci function decay_gen_get_term (decay) result (i) class(decay_gen_t), intent(inout) :: decay integer :: i i = decay%selected_term end function decay_gen_get_term @ %def decay_gen_set_mci @ %def decay_gen_set_term @ %def decay_gen_get_mci @ %def decay_gen_get_term @ Implement random-number generators for unstable decay selection in all terms. This is not recursive. We also make use of the fact that [[process]] is a pointer; the (state of the RNG factory inside the) target process will be modified by the rng-spawning method, but not the pointer. <>= procedure :: make_term_rng => decay_gen_make_term_rng <>= subroutine decay_gen_make_term_rng (decay, process) class(decay_gen_t), intent(inout) :: decay type(process_t), intent(in), pointer :: process integer :: i do i = 1, size (decay%term) call decay%term(i)%make_rng (process) end do end subroutine decay_gen_make_term_rng @ %def decay_gen_make_term_rng @ Recursively link interactions of the enclosed decay terms to the corresponding terms in the current process instance. <>= procedure :: link_term_interactions => decay_gen_link_term_interactions <>= recursive subroutine decay_gen_link_term_interactions (decay) class(decay_gen_t), intent(inout) :: decay integer :: i type(interaction_t), pointer :: trace associate (instance => decay%process_instance) do i = 1, size (decay%term) trace => instance%get_trace_int_ptr (i) call decay%term(i)%link_interactions (trace) end do end associate end subroutine decay_gen_link_term_interactions @ %def decay_gen_link_term_interactions @ Select a decay chain: decay modes and process components. <>= procedure :: select_chain => decay_root_select_chain <>= subroutine decay_root_select_chain (decay_root) class(decay_root_t), intent(inout) :: decay_root if (decay_root%selected_term > 0) then call decay_root%term(decay_root%selected_term)%select_chain () else call msg_bug ("Decays: no term selected for parent process") end if end subroutine decay_root_select_chain @ %def decay_root_select_chain @ Generate a decay tree, i.e., for the selected term in the parent process, recursively generate a decay event for all unstable particles. Factor out the trace of the connected state of the parent process. This trace should not be taken into account for unweighting the decay chain, since it was already used for unweighting the parent event, or it determines the overall event weight. <>= procedure :: generate => decay_root_generate <>= subroutine decay_root_generate (decay_root) class(decay_root_t), intent(inout) :: decay_root type(connected_state_t), pointer :: connected_state if (decay_root%selected_term > 0) then connected_state => decay_root%process_instance%get_connected_state_ptr & (decay_root%selected_term) call connected_state%normalize_matrix_by_trace () call decay_root%term(decay_root%selected_term)%generate () else call msg_bug ("Decays: no term selected for parent process") end if end subroutine decay_root_generate @ %def decay_root_generate @ \subsection{Decay Configuration} A decay configuration describes a distinct decay mode of a particle. Each decay mode may include several terms, which correspond to the terms in the associated process. In addition to the base type, the decay configuration object contains the integral of the parent process and the selector for the MCI group inside this process. The flavor component should be identical to the flavor component of the parent particle ([[unstable]] object). <>= type, extends (decay_root_config_t) :: decay_config_t private type(flavor_t) :: flv real(default) :: weight = 0 real(default) :: integral = 0 real(default) :: abs_error = 0 real(default) :: rel_error = 0 type(selector_t) :: mci_selector contains <> end type decay_config_t @ %def decay_config_t @ The output routine extends the decay-root writer by listing numerical component values. <>= procedure :: write => decay_config_write <>= recursive subroutine decay_config_write (object, unit, indent, verbose) class(decay_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) write (u, "(1x,A)") "Decay:" call object%write_header (unit, indent) call write_indent (u, ind) write (u, 2) "branching ratio =", object%weight * 100 call write_indent (u, ind) write (u, 1) "partial width =", object%integral call write_indent (u, ind) write (u, 1) "error (abs) =", object%abs_error call write_indent (u, ind) write (u, 1) "error (rel) =", object%rel_error 1 format (3x,A,ES19.12) 2 format (3x,A,F11.6,1x,'%') call object%write_terms (unit, indent, verbose) end subroutine decay_config_write @ %def decay_config_write @ Connect a decay configuration with a process object (which should represent the decay). This includes initialization, therefore intent(out). We first connect the process itself, then do initializations that are specific for this decay. Infer stability from the particle properties, using the first row in the set of flavor states. Once we can deal with predetermined decay chains, they should be used instead. If there is an optional [[var_list]], check if the stored values for the decay partial width and error have been overridden there. <>= procedure :: connect => decay_config_connect <>= recursive subroutine decay_config_connect & (decay, process, model, process_stack, process_instance, var_list) class(decay_config_t), intent(out) :: decay type(process_t), intent(in), target :: process class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(process_instance_t), intent(in), optional, target :: process_instance type(var_list_t), intent(in), optional, target :: var_list real(default), dimension(:), allocatable :: integral_mci type(string_t) :: process_id integer :: i, n_mci call decay%decay_root_config_t%connect & (process, model, process_stack, var_list=var_list) process_id = process%get_id () if (process%lab_is_cm ()) then call msg_fatal ("Decay process " // char (process_id) & // ": unusable because rest frame is fixed.") end if decay%integral = process%get_integral () decay%abs_error = process%get_error () if (present (var_list)) then call update (decay%integral, "integral(" // process_id // ")") call update (decay%abs_error, "error(" // process_id // ")") end if n_mci = process%get_n_mci () allocate (integral_mci (n_mci)) do i = 1, n_mci integral_mci(i) = process%get_integral_mci (i) end do call decay%mci_selector%init (integral_mci) contains subroutine update (var, var_name) real(default), intent(inout) :: var type(string_t), intent(in) :: var_name if (var_list%contains (var_name)) then var = var_list%get_rval (var_name) end if end subroutine update end subroutine decay_config_connect @ %def decay_config_connect @ Set the flavor entry, which repeats the flavor of the parent unstable particle. <>= procedure :: set_flv => decay_config_set_flv <>= subroutine decay_config_set_flv (decay, flv) class(decay_config_t), intent(inout) :: decay type(flavor_t), intent(in) :: flv decay%flv = flv end subroutine decay_config_set_flv @ %def decay_config_set_flv @ Compute embedded branchings and the relative error. This method does not apply to the decay root. <>= procedure :: compute => decay_config_compute <>= recursive subroutine decay_config_compute (decay) class(decay_config_t), intent(inout) :: decay call decay%decay_root_config_t%compute () if (.not. vanishes (decay%integral)) then decay%rel_error = decay%abs_error / decay%integral else decay%rel_error = 0 end if end subroutine decay_config_compute @ %def decay_config_compute @ \subsection{Decay Instance} The decay contains a collection of terms. One of them is selected when the decay is evaluated. This is similar to the decay root, but we implement it independently. The process instance object is allocated via a pointer, so it automatically behaves as a target. <>= type, extends (decay_gen_t) :: decay_t private type(decay_config_t), pointer :: config => null () class(rng_t), allocatable :: rng contains <> end type decay_t @ %def decay_t @ The finalizer is recursive. <>= procedure :: final => decay_final <>= recursive subroutine decay_final (object) class(decay_t), intent(inout) :: object integer :: i call object%base_final () do i = 1, object%config%process%get_n_mci () call object%process_instance%final_simulation (i) end do call object%process_instance%final () deallocate (object%process_instance) end subroutine decay_final @ %def decay_final @ Output. <>= procedure :: write => decay_write <>= recursive subroutine decay_write (object, unit, indent, recursive) class(decay_t), intent(in) :: object integer, intent(in), optional :: unit, indent, recursive integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call object%config%write (unit, indent, verbose = .false.) if (allocated (object%rng)) then call object%rng%write (u, ind + 1) end if call write_indent (u, ind) if (object%selected_mci > 0) then write (u, "(3x,A,I0)") "Selected MCI = ", object%selected_mci else write (u, "(3x,A)") "Selected MCI = [undefined]" end if call write_indent (u, ind) if (object%selected_term > 0) then write (u, "(3x,A,I0)") "Selected term = ", object%selected_term call object%term(object%selected_term)%write (u, ind + 1) else write (u, "(3x,A)") "Selected term = [undefined]" end if end subroutine decay_write @ %def decay_write @ Initializer. Base initialization is done recursively. Then, we prepare the current process instance and allocate a random-number generator for term selection. For all unstable particles, we also allocate a r.n.g. as spawned by the current process. <>= procedure :: init => decay_init <>= recursive subroutine decay_init (decay, config) class(decay_t), intent(out) :: decay type(decay_config_t), intent(in), target :: config integer :: i call decay%base_init (config%term_config) decay%config => config allocate (decay%process_instance) call decay%process_instance%init (decay%config%process) call decay%process_instance%setup_event_data (decay%config%model) do i = 1, decay%config%process%get_n_mci () call decay%process_instance%init_simulation (i) end do call decay%config%process%make_rng (decay%rng) call decay%make_term_rng (decay%config%process) end subroutine decay_init @ %def decay_init @ Link interactions to the parent process. [[i_prt]] is the index of the current outgoing particle in the parent interaction, for which we take the trace evaluator. We link it to the beam particle in the beam interaction of the decay process instance. Then, repeat the procedure for the outgoing particles. <>= procedure :: link_interactions => decay_link_interactions <>= recursive subroutine decay_link_interactions (decay, i_prt, trace) class(decay_t), intent(inout) :: decay integer, intent(in) :: i_prt type(interaction_t), intent(in), target :: trace type(interaction_t), pointer :: beam_int integer :: n_in, n_vir beam_int => decay%process_instance%get_beam_int_ptr () n_in = trace%get_n_in () n_vir = trace%get_n_vir () call beam_int%set_source_link (1, trace, & n_in + n_vir + i_prt) call decay%link_term_interactions () end subroutine decay_link_interactions @ %def decay_link_interactions @ Determine a decay chain. For each unstable particle we select one of the possible decay modes, and for each decay process we select one of the possible decay MCI components, calling the random-number generators. We do not generate momenta, yet. <>= procedure :: select_chain => decay_select_chain <>= recursive subroutine decay_select_chain (decay) class(decay_t), intent(inout) :: decay real(default) :: x integer :: i call decay%rng%generate (x) decay%selected_mci = decay%config%mci_selector%select (x) call decay%process_instance%choose_mci (decay%selected_mci) decay%selected_term = decay%process_instance%select_i_term () do i = 1, size (decay%term) call decay%term(i)%select_chain () end do end subroutine decay_select_chain @ %def decay_select_chain @ Generate a decay. We first receive the beam momenta from the parent process (assuming that this is properly linked), then call the associated process object for a new event. Factor out the trace of the helicity density matrix of the isolated state (the one that will be used for the decay chain). The trace is taken into account for unweighting the individual decay event and should therefore be ignored for unweighting the correlated decay chain afterwards. <>= procedure :: generate => decay_generate <>= recursive subroutine decay_generate (decay) class(decay_t), intent(inout) :: decay type(isolated_state_t), pointer :: isolated_state integer :: i call decay%process_instance%receive_beam_momenta () call decay%process_instance%generate_unweighted_event (decay%selected_mci) if (signal_is_pending ()) return call decay%process_instance%evaluate_event_data () isolated_state => & decay%process_instance%get_isolated_state_ptr (decay%selected_term) call isolated_state%normalize_matrix_by_trace () do i = 1, size (decay%term) call decay%term(i)%generate () if (signal_is_pending ()) return end do end subroutine decay_generate @ %def decay_generate @ \subsection{Stable Particles} This is a stable particle. The flavor can be ambiguous (e.g., partons). <>= type, extends (any_config_t) :: stable_config_t private type(flavor_t), dimension(:), allocatable :: flv contains <> end type stable_config_t @ %def stable_config_t @ The finalizer is empty: <>= procedure :: final => stable_config_final <>= subroutine stable_config_final (object) class(stable_config_t), intent(inout) :: object end subroutine stable_config_final @ %def stable_config_final @ Output. <>= procedure :: write => stable_config_write <>= recursive subroutine stable_config_write (object, unit, indent, verbose) class(stable_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: u, i, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call write_indent (u, ind) write (u, "(1x,'+',1x,A)", advance = "no") "Stable:" write (u, "(1x,A)", advance = "no") char (object%flv(1)%get_name ()) do i = 2, size (object%flv) write (u, "(':',A)", advance = "no") & char (object%flv(i)%get_name ()) end do write (u, *) end subroutine stable_config_write @ %def stable_config_write @ Initializer. We are presented with an array of flavors, but there may be double entries which we remove, so we store only the distinct flavors. <>= procedure :: init => stable_config_init <>= subroutine stable_config_init (config, flv) class(stable_config_t), intent(out) :: config type(flavor_t), dimension(:), intent(in) :: flv integer, dimension (size (flv)) :: pdg logical, dimension (size (flv)) :: mask integer :: i pdg = flv%get_pdg () mask(1) = .true. forall (i = 2 : size (pdg)) mask(i) = all (pdg(i) /= pdg(1:i-1)) end forall allocate (config%flv (count (mask))) config%flv = pack (flv, mask) end subroutine stable_config_init @ %def stable_config_init @ Here is the corresponding object instance. Except for the pointer to the configuration, there is no content. <>= type, extends (any_t) :: stable_t private type(stable_config_t), pointer :: config => null () contains <> end type stable_t @ %def stable_t @ The finalizer does nothing. <>= procedure :: final => stable_final <>= subroutine stable_final (object) class(stable_t), intent(inout) :: object end subroutine stable_final @ %def stable_final @ We can delegate output to the configuration object. <>= procedure :: write => stable_write <>= subroutine stable_write (object, unit, indent) class(stable_t), intent(in) :: object integer, intent(in), optional :: unit, indent call object%config%write (unit, indent) end subroutine stable_write @ %def stable_write @ Initializer: just assign the configuration. <>= procedure :: init => stable_init <>= subroutine stable_init (stable, config) class(stable_t), intent(out) :: stable type(stable_config_t), intent(in), target :: config stable%config => config end subroutine stable_init @ %def stable_init @ \subsection{Unstable Particles} A branching configuration enables us to select among distinct decay modes of a particle. We store the particle flavor (with its implicit link to a model), an array of decay configurations, and a selector object. The total width, absolute and relative error are stored as [[integral]], [[abs_error]], and [[rel_error]], respectively. The flavor must be unique in this case. <>= public :: unstable_config_t <>= type, extends (any_config_t) :: unstable_config_t private type(flavor_t) :: flv real(default) :: integral = 0 real(default) :: abs_error = 0 real(default) :: rel_error = 0 type(selector_t) :: selector type(decay_config_t), dimension(:), allocatable :: decay_config contains <> end type unstable_config_t @ %def unstable_config_t @ Finalizer. The branching configuration can be a recursive structure. <>= procedure :: final => unstable_config_final <>= recursive subroutine unstable_config_final (object) class(unstable_config_t), intent(inout) :: object integer :: i if (allocated (object%decay_config)) then do i = 1, size (object%decay_config) call object%decay_config(i)%final () end do end if end subroutine unstable_config_final @ %def unstable_config_final @ Output. Since this may be recursive, we include indentation. <>= procedure :: write => unstable_config_write <>= recursive subroutine unstable_config_write (object, unit, indent, verbose) class(unstable_config_t), intent(in) :: object integer, intent(in), optional :: unit, indent logical, intent(in), optional :: verbose integer :: u, i, ind logical :: verb u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent verb = .true.; if (present (verbose)) verb = verbose call write_indent (u, ind) write (u, "(1x,'+',1x,A,1x,A)") "Unstable:", & char (object%flv%get_name ()) call write_indent (u, ind) write (u, 1) "total width =", object%integral call write_indent (u, ind) write (u, 1) "error (abs) =", object%abs_error call write_indent (u, ind) write (u, 1) "error (rel) =", object%rel_error 1 format (5x,A,ES19.12) if (verb .and. allocated (object%decay_config)) then do i = 1, size (object%decay_config) call object%decay_config(i)%write (u, ind + 1) end do end if end subroutine unstable_config_write @ %def unstable_config_write @ Initializer. For the unstable particle, the flavor is unique. <>= procedure :: init => unstable_config_init <>= subroutine unstable_config_init (unstable, flv, set_decays, model) class(unstable_config_t), intent(out) :: unstable type(flavor_t), intent(in) :: flv logical, intent(in), optional :: set_decays class(model_data_t), intent(in), optional, target :: model type(string_t), dimension(:), allocatable :: decay unstable%flv = flv if (present (set_decays)) then call unstable%flv%get_decays (decay) call unstable%init_decays (decay, model) end if end subroutine unstable_config_init @ %def unstable_config_init @ Further initialization: determine the number of decay modes. We can assume that the flavor of the particle has been set already. If the process stack is given, we can delve recursively into actually assigning decay processes. Otherwise, we just initialize with decay process names. <>= procedure :: init_decays => unstable_config_init_decays <>= recursive subroutine unstable_config_init_decays & (unstable, decay_id, model, process_stack, var_list) class(unstable_config_t), intent(inout) :: unstable type(string_t), dimension(:), intent(in) :: decay_id class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(var_list_t), intent(in), optional :: var_list integer :: i allocate (unstable%decay_config (size (decay_id))) do i = 1, size (decay_id) associate (decay => unstable%decay_config(i)) if (present (process_stack)) then call decay%connect (process_stack%get_process_ptr (decay_id(i)), & model, process_stack, var_list=var_list) else call decay%init (model, decay_id(i)) end if call decay%set_flv (unstable%flv) end associate end do end subroutine unstable_config_init_decays @ %def unstable_config_init @ Explicitly connect a specific decay with a process. This is used only in unit tests. <>= procedure :: connect_decay => unstable_config_connect_decay <>= subroutine unstable_config_connect_decay (unstable, i, process, model) class(unstable_config_t), intent(inout) :: unstable integer, intent(in) :: i type(process_t), intent(in), target :: process class(model_data_t), intent(in), target :: model associate (decay => unstable%decay_config(i)) call decay%connect (process, model) end associate end subroutine unstable_config_connect_decay @ %def unstable_config_connect_decay @ Compute the total width and branching ratios, initializing the decay selector. <>= procedure :: compute => unstable_config_compute <>= recursive subroutine unstable_config_compute (unstable) class(unstable_config_t), intent(inout) :: unstable integer :: i do i = 1, size (unstable%decay_config) call unstable%decay_config(i)%compute () end do unstable%integral = sum (unstable%decay_config%integral) if (unstable%integral <= 0) then call unstable%write () call msg_fatal ("Decay configuration: computed total width is zero") end if unstable%abs_error = sqrt (sum (unstable%decay_config%abs_error ** 2)) unstable%rel_error = unstable%abs_error / unstable%integral call unstable%selector%init (unstable%decay_config%integral) do i = 1, size (unstable%decay_config) unstable%decay_config(i)%weight & = unstable%selector%get_weight (i) end do end subroutine unstable_config_compute @ %def unstable_config_compute @ Now we define the instance of an unstable particle. <>= public :: unstable_t <>= type, extends (any_t) :: unstable_t private type(unstable_config_t), pointer :: config => null () class(rng_t), allocatable :: rng integer :: selected_decay = 0 type(decay_t), dimension(:), allocatable :: decay contains <> end type unstable_t @ %def unstable_t @ Recursive finalizer. <>= procedure :: final => unstable_final <>= recursive subroutine unstable_final (object) class(unstable_t), intent(inout) :: object integer :: i if (allocated (object%decay)) then do i = 1, size (object%decay) call object%decay(i)%final () end do end if end subroutine unstable_final @ %def unstable_final @ Output. <>= procedure :: write => unstable_write <>= recursive subroutine unstable_write (object, unit, indent) class(unstable_t), intent(in) :: object integer, intent(in), optional :: unit, indent integer :: u, ind u = given_output_unit (unit) ind = 0; if (present (indent)) ind = indent call object%config%write (u, ind, verbose=.false.) if (allocated (object%rng)) then call object%rng%write (u, ind + 2) end if call write_indent (u, ind) if (object%selected_decay > 0) then write (u, "(5x,A,I0)") "Sel. decay = ", object%selected_decay call object%decay(object%selected_decay)%write (u, ind + 1) else write (u, "(5x,A)") "Sel. decay = [undefined]" end if end subroutine unstable_write @ %def unstable_write @ Write the embedded process instances. <>= procedure :: write_process_instances => unstable_write_process_instances <>= recursive subroutine unstable_write_process_instances & (unstable, unit, verbose) class(unstable_t), intent(in) :: unstable integer, intent(in), optional :: unit logical, intent(in), optional :: verbose if (unstable%selected_decay > 0) then call unstable%decay(unstable%selected_decay)% & write_process_instances (unit, verbose) end if end subroutine unstable_write_process_instances @ %def unstable_write_process_instances @ Initialization, using the configuration object. <>= procedure :: init => unstable_init <>= recursive subroutine unstable_init (unstable, config) class(unstable_t), intent(out) :: unstable type(unstable_config_t), intent(in), target :: config integer :: i unstable%config => config allocate (unstable%decay (size (config%decay_config))) do i = 1, size (config%decay_config) call unstable%decay(i)%init (config%decay_config(i)) end do end subroutine unstable_init @ %def unstable_init @ Recursively link interactions to the parent process. [[i_prt]] is the index of the current outgoing particle in the parent interaction. <>= procedure :: link_interactions => unstable_link_interactions <>= recursive subroutine unstable_link_interactions (unstable, i_prt, trace) class(unstable_t), intent(inout) :: unstable integer, intent(in) :: i_prt type(interaction_t), intent(in), target :: trace integer :: i do i = 1, size (unstable%decay) call unstable%decay(i)%link_interactions (i_prt, trace) end do end subroutine unstable_link_interactions @ %def unstable_link_interactions @ Import the random-number generator state. <>= procedure :: import_rng => unstable_import_rng <>= subroutine unstable_import_rng (unstable, rng) class(unstable_t), intent(inout) :: unstable class(rng_t), intent(inout), allocatable :: rng call move_alloc (from = rng, to = unstable%rng) end subroutine unstable_import_rng @ %def unstable_import_rng @ Generate a decay chain. First select a decay mode, then call the [[select_chain]] method of the selected mode. <>= procedure :: select_chain => unstable_select_chain <>= recursive subroutine unstable_select_chain (unstable) class(unstable_t), intent(inout) :: unstable real(default) :: x call unstable%rng%generate (x) unstable%selected_decay = unstable%config%selector%select (x) call unstable%decay(unstable%selected_decay)%select_chain () end subroutine unstable_select_chain @ %def unstable_select_chain @ Generate a decay event. <>= procedure :: generate => unstable_generate <>= recursive subroutine unstable_generate (unstable) class(unstable_t), intent(inout) :: unstable call unstable%decay(unstable%selected_decay)%generate () end subroutine unstable_generate @ %def unstable_generate @ \subsection{Decay Chain} While the decay configuration tree and the decay tree are static entities (during a simulation run), the decay chain is dynamically generated for each event. The reason is that with the possibility of several decay modes for each particle, and several terms for each process, the total number of distinct decay chains is not under control. Each entry in the decay chain is a connected parton state. The origin of the chain is a connected state in the parent process (not part of the chain itself). For each decay, mode and term chosen, we convolute this with the isolated (!) state of the current decay, to generate a new connected state. We accumulate this chain by recursively traversing the allocated decay tree. Whenever a particle decays, it becomes virtual and is replaced by its decay product, while all other particles stay in the parton state as spectators. Technically, we implement the decay chain as a stack structure and include information from the associated decay object for easier debugging. This is a decay chain entry: <>= type, extends (connected_state_t) :: decay_chain_entry_t private integer :: index = 0 type(decay_config_t), pointer :: config => null () integer :: selected_mci = 0 integer :: selected_term = 0 type(decay_chain_entry_t), pointer :: previous => null () end type decay_chain_entry_t @ %def decay_chain_entry_t @ This is the complete chain; we need just a pointer to the last entry. We also include a pointer to the master process instance, which serves as the seed for the decay chain. The evaluator [[correlated_trace]] traces over all quantum numbers for the final spin-correlated (but color-summed) evaluator of the decay chain. This allows us to compute the probability for a momentum configuration, given that all individual density matrices (of the initial process and the subsequent decays) have been normalized to one. Note: This trace is summed over color, so color is treated exactly when computing spin correlations. However, we do not keep non-diagonal color correlations. When an event is accepted, we compute probabilities for all color states and can choose one of them. <>= public :: decay_chain_t <>= type :: decay_chain_t private type(process_instance_t), pointer :: process_instance => null () integer :: selected_term = 0 type(evaluator_t) :: correlated_trace type(decay_chain_entry_t), pointer :: last => null () contains <> end type decay_chain_t @ %def decay_chain_t @ The finalizer recursively deletes and deallocates the entries. <>= procedure :: final => decay_chain_final <>= subroutine decay_chain_final (object) class(decay_chain_t), intent(inout) :: object type(decay_chain_entry_t), pointer :: entry do while (associated (object%last)) entry => object%last object%last => entry%previous call entry%final () deallocate (entry) end do call object%correlated_trace%final () end subroutine decay_chain_final @ %def decay_chain_final @ Doing output recursively allows us to display the chain in chronological order. <>= procedure :: write => decay_chain_write <>= subroutine decay_chain_write (object, unit) class(decay_chain_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) call write_separator (u, 2) write (u, "(1x,A)") "Decay chain:" call write_entries (object%last) call write_separator (u, 2) write (u, "(1x,A)") "Evaluator (correlated trace of the decay chain):" call write_separator (u) call object%correlated_trace%write (u) call write_separator (u, 2) contains recursive subroutine write_entries (entry) type(decay_chain_entry_t), intent(in), pointer :: entry if (associated (entry)) then call write_entries (entry%previous) call write_separator (u, 2) write (u, "(1x,A,I0)") "Decay #", entry%index call entry%config%write_header (u) write (u, "(3x,A,I0)") "Selected MCI = ", entry%selected_mci write (u, "(3x,A,I0)") "Selected term = ", entry%selected_term call entry%config%term_config(entry%selected_term)%write (u, indent=1) call entry%write (u) end if end subroutine write_entries end subroutine decay_chain_write @ %def decay_chain_write @ Build a decay chain, recursively following the selected decays and terms in a decay tree. Before start, we finalize the chain, deleting any previous contents. <>= procedure :: build => decay_chain_build <>= subroutine decay_chain_build (chain, decay_root) class(decay_chain_t), intent(inout), target :: chain type(decay_root_t), intent(in) :: decay_root type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask type(interaction_t), pointer :: int_last_decay call chain%final () if (decay_root%selected_term > 0) then chain%process_instance => decay_root%process_instance chain%selected_term = decay_root%selected_term call chain%build_term_entries (decay_root%term(decay_root%selected_term)) end if int_last_decay => chain%last%get_matrix_int_ptr () allocate (qn_mask (int_last_decay%get_n_tot ())) call qn_mask%init (mask_f = .true., mask_c = .true., mask_h = .true.) call chain%correlated_trace%init_qn_sum (int_last_decay, qn_mask) end subroutine decay_chain_build @ %def decay_chain_build @ Build the entries that correspond to a decay term. We have to scan all unstable particles. <>= procedure :: build_term_entries => decay_chain_build_term_entries <>= recursive subroutine decay_chain_build_term_entries (chain, term) class(decay_chain_t), intent(inout) :: chain type(decay_term_t), intent(in) :: term integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t) if (unstable%selected_decay > 0) then call chain%build_decay_entries & (unstable%decay(unstable%selected_decay)) end if end select end do end subroutine decay_chain_build_term_entries @ %def decay_chain_build_term_entries @ Build the entries that correspond to a specific decay. The decay term should have been determined, so we allocate a decay chain entry and fill it, then proceed to child decays. For the first entry, we convolute the connected state of the parent process instance with the isolated state of the current decay (which does not contain an extra beam entry for the parent). For subsequent entries, we take the previous entry as first factor. In principle, each chain entry (as a parton state) is capable of holding a subevent object and associated expressions. We currently do not make use of that feature. Before generating the decays, factor out the trace of the helicity density matrix of the parent parton state. This trace has been used for unweighting the original event (unweighted case) or it determines the overall weight, so it should not be taken into account in the decay chain generation. <>= procedure :: build_decay_entries => decay_chain_build_decay_entries <>= recursive subroutine decay_chain_build_decay_entries (chain, decay) class(decay_chain_t), intent(inout) :: chain type(decay_t), intent(in) :: decay type(decay_chain_entry_t), pointer :: entry type(connected_state_t), pointer :: previous_state type(isolated_state_t), pointer :: current_decay type(helicity_t) :: hel type(quantum_numbers_t) :: qn_filter_conn allocate (entry) if (associated (chain%last)) then entry%previous => chain%last entry%index = entry%previous%index + 1 previous_state => entry%previous%connected_state_t else entry%index = 1 previous_state => & chain%process_instance%get_connected_state_ptr (chain%selected_term) end if entry%config => decay%config entry%selected_mci = decay%selected_mci entry%selected_term = decay%selected_term current_decay => decay%process_instance%get_isolated_state_ptr & (decay%selected_term) call entry%setup_connected_trace & (current_decay, previous_state%get_trace_int_ptr (), resonant=.true.) if (entry%config%flv%has_decay_helicity ()) then call hel%init (entry%config%flv%get_decay_helicity ()) call qn_filter_conn%init (hel) call entry%setup_connected_matrix & (current_decay, previous_state%get_matrix_int_ptr (), & resonant=.true., qn_filter_conn = qn_filter_conn) call entry%setup_connected_flows & (current_decay, previous_state%get_flows_int_ptr (), & resonant=.true., qn_filter_conn = qn_filter_conn) else call entry%setup_connected_matrix & (current_decay, previous_state%get_matrix_int_ptr (), & resonant=.true.) call entry%setup_connected_flows & (current_decay, previous_state%get_flows_int_ptr (), & resonant=.true.) end if chain%last => entry call chain%build_term_entries (decay%term(decay%selected_term)) end subroutine decay_chain_build_decay_entries @ %def decay_chain_build_decay_entries @ Recursively fill the decay chain with momenta and evaluate the matrix elements. Since all evaluators should have correct source entries at this point, momenta are automatically retrieved from the appropriate process instance. Like we did above for the parent process, factor out the trace for each subsequent decay (the helicity density matrix in the isolated state, which is taken for the convolution). <>= procedure :: evaluate => decay_chain_evaluate <>= subroutine decay_chain_evaluate (chain) class(decay_chain_t), intent(inout) :: chain call evaluate (chain%last) call chain%correlated_trace%receive_momenta () call chain%correlated_trace%evaluate () contains recursive subroutine evaluate (entry) type(decay_chain_entry_t), intent(inout), pointer :: entry if (associated (entry)) then call evaluate (entry%previous) call entry%receive_kinematics () call entry%evaluate_trace () call entry%evaluate_event_data () end if end subroutine evaluate end subroutine decay_chain_evaluate @ %def decay_chain_evaluate @ Return the probability of a decay chain. This is given as the trace of the density matrix with intermediate helicity correlations, normalized by the product of the uncorrelated density matrix traces. This works only if an event has been evaluated and the [[correlated_trace]] evaluator is filled. By definition, this evaluator has only one matrix element, and this must be real. <>= procedure :: get_probability => decay_chain_get_probability <>= function decay_chain_get_probability (chain) result (x) class(decay_chain_t), intent(in) :: chain real(default) :: x x = real (chain%correlated_trace%get_matrix_element (1)) end function decay_chain_get_probability @ %def decay_chain_get_probability @ \subsection{Decay as Event Transform} The [[evt_decay]] object combines decay configuration, decay tree, and chain in a single object, as an implementation of the [[evt]] (event transform) abstract type. The [[var_list]] may be a pointer to the user variable list, which could contain overridden parameters for the decay processes. <>= public :: evt_decay_t <>= type, extends (evt_t) :: evt_decay_t private type(decay_root_config_t) :: decay_root_config type(decay_root_t) :: decay_root type(decay_chain_t) :: decay_chain type(var_list_t), pointer :: var_list => null () contains <> end type evt_decay_t @ %def evt_decay_t @ <>= procedure :: write_name => evt_decay_write_name <>= subroutine evt_decay_write_name (evt, unit) class(evt_decay_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: partonic decays" end subroutine evt_decay_write_name @ %def evt_decay_write_name @ Output. We display the currently selected decay tree, which includes configuration data, and the decay chain, i.e., the evaluators. <>= procedure :: write => evt_decay_write <>= subroutine evt_decay_write (evt, unit, verbose, more_verbose, testflag) class(evt_decay_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag logical :: verb, verb2 integer :: u u = given_output_unit (unit) verb = .true.; if (present (verbose)) verb = verbose verb2 = .false.; if (present (more_verbose)) verb2 = more_verbose call write_separator (u, 2) call evt%write_name (u) call write_separator (u, 2) call evt%base_write (u, testflag = testflag) if (associated (evt%var_list)) then call write_separator (u) write (u, "(1x,A)") "Variable list for simulation: & &[associated, not shown]" end if if (verb) then call write_separator (u) call evt%decay_root%write (u) if (verb2) then call evt%decay_chain%write (u) call evt%decay_root%write_process_instances (u, verb) end if else call write_separator (u, 2) end if end subroutine evt_decay_write @ %def evt_decay_write @ Set the pointer to a user variable list. <>= procedure :: set_var_list => evt_decay_set_var_list <>= subroutine evt_decay_set_var_list (evt, var_list) class(evt_decay_t), intent(inout) :: evt type(var_list_t), intent(in), target :: var_list evt%var_list => var_list end subroutine evt_decay_set_var_list @ %def evt_decay_set_var_list @ Connect with a process instance and process. This initializes the decay configuration. The process stack is used to look for process objects that implement daughter decays. When all processes are assigned, configure the decay tree instance, using the decay tree configuration. First obtain the branching ratios, then allocate the decay tree. This is done once for all events. <>= procedure :: connect => evt_decay_connect <>= subroutine evt_decay_connect (evt, process_instance, model, process_stack) class(evt_decay_t), intent(inout), target :: evt type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack call evt%base_connect (process_instance, model) if (associated (evt%var_list)) then call evt%decay_root_config%connect (process_instance%process, & model, process_stack, process_instance, evt%var_list) else call evt%decay_root_config%connect (process_instance%process, & model, process_stack, process_instance) end if call evt%decay_root_config%compute () call evt%decay_root%init (evt%decay_root_config, evt%process_instance) end subroutine evt_decay_connect @ %def evt_decay_connect @ Prepare a new event: Select a decay chain and build the corresponding chain object. <>= procedure :: prepare_new_event => evt_decay_prepare_new_event <>= subroutine evt_decay_prepare_new_event (evt, i_mci, i_term) class(evt_decay_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () evt%decay_root%selected_mci = i_mci evt%decay_root%selected_term = i_term call evt%decay_root%select_chain () call evt%decay_chain%build (evt%decay_root) end subroutine evt_decay_prepare_new_event @ %def evt_decay_prepare_new_event @ Generate a weighted event and assign the resulting weight (probability). We use a chain initialized by the preceding subroutine, fill it with momenta and evaluate. <>= procedure :: generate_weighted => evt_decay_generate_weighted <>= subroutine evt_decay_generate_weighted (evt, probability) class(evt_decay_t), intent(inout) :: evt real(default), intent(inout) :: probability call evt%decay_root%generate () if (signal_is_pending ()) return call evt%decay_chain%evaluate () probability = evt%decay_chain%get_probability () end subroutine evt_decay_generate_weighted @ %def evt_decay_generate_weighted @ To create a usable event, we have to transform the interaction into a particle set; this requires factorization for the correlated density matrix, according to the factorization mode. <>= procedure :: make_particle_set => evt_decay_make_particle_set <>= subroutine evt_decay_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_decay_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r type(interaction_t), pointer :: int_matrix, int_flows type(decay_chain_entry_t), pointer :: last_entry last_entry => evt%decay_chain%last int_matrix => last_entry%get_matrix_int_ptr () int_flows => last_entry%get_flows_int_ptr () call evt%factorize_interactions (int_matrix, int_flows, & factorization_mode, keep_correlations, r) call evt%tag_incoming () end subroutine evt_decay_make_particle_set @ %def event_decay_make_particle_set @ \subsubsection{Auxiliary} Eliminate numerical noise for the associated process instances. <>= public :: pacify <>= interface pacify module procedure pacify_decay module procedure pacify_decay_gen module procedure pacify_term module procedure pacify_unstable end interface pacify <>= subroutine pacify_decay (evt) class(evt_decay_t), intent(inout) :: evt call pacify_decay_gen (evt%decay_root) end subroutine pacify_decay recursive subroutine pacify_decay_gen (decay) class(decay_gen_t), intent(inout) :: decay if (associated (decay%process_instance)) then call pacify (decay%process_instance) end if if (decay%selected_term > 0) then call pacify_term (decay%term(decay%selected_term)) end if end subroutine pacify_decay_gen recursive subroutine pacify_term (term) class(decay_term_t), intent(inout) :: term integer :: i do i = 1, size (term%particle_out) select type (unstable => term%particle_out(i)%c) type is (unstable_t); call pacify_unstable (unstable) end select end do end subroutine pacify_term recursive subroutine pacify_unstable (unstable) class(unstable_t), intent(inout) :: unstable if (unstable%selected_decay > 0) then call pacify_decay_gen (unstable%decay(unstable%selected_decay)) end if end subroutine pacify_unstable @ %def pacify @ Prepare specific configurations for use in unit tests. <>= procedure :: init_test_case1 procedure :: init_test_case2 <>= subroutine init_test_case1 (unstable, i, flv, integral, relerr, model) class(unstable_config_t), intent(inout) :: unstable integer, intent(in) :: i type(flavor_t), dimension(:,:), intent(in) :: flv real(default), intent(in) :: integral real(default), intent(in) :: relerr class(model_data_t), intent(in), target :: model associate (decay => unstable%decay_config(i)) allocate (decay%term_config (1)) call decay%init_term (1, flv, stable = [.true., .true.], model=model) decay%integral = integral decay%abs_error = integral * relerr end associate end subroutine init_test_case1 subroutine init_test_case2 (unstable, flv1, flv21, flv22, model) class(unstable_config_t), intent(inout) :: unstable type(flavor_t), dimension(:,:), intent(in) :: flv1, flv21, flv22 class(model_data_t), intent(in), target :: model associate (decay => unstable%decay_config(1)) decay%integral = 1.e-3_default decay%abs_error = decay%integral * .01_default allocate (decay%term_config (1)) call decay%init_term (1, flv1, stable = [.false., .true.], model=model) select type (w => decay%term_config(1)%prt(1)%c) type is (unstable_config_t) associate (w_decay => w%decay_config(1)) w_decay%integral = 2._default allocate (w_decay%term_config (1)) call w_decay%init_term (1, flv21, stable = [.true., .true.], & model=model) end associate associate (w_decay => w%decay_config(2)) w_decay%integral = 1._default allocate (w_decay%term_config (1)) call w_decay%init_term (1, flv22, stable = [.true., .true.], & model=model) end associate call w%compute () end select end associate end subroutine init_test_case2 @ %def init_test_case1 @ %def init_test_case2 @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[decays_ut.f90]]>>= <> module decays_ut use unit_tests use decays_uti <> <> <> contains <> end module decays_ut @ %def decays_ut @ <<[[decays_uti.f90]]>>= <> module decays_uti <> <> use os_interface use sm_qcd use model_data use models use state_matrices, only: FM_IGNORE_HELICITY use interactions, only: reset_interaction_counter use flavors use process_libraries use rng_base use mci_base use mci_midpoint use phs_base use phs_single use prc_core use prc_test, only: prc_test_create_library use process, only: process_t use instances, only: process_instance_t use process_stacks use decays use rng_base_ut, only: rng_test_t, rng_test_factory_t <> <> <> contains <> <> end module decays_uti @ %def decays_uti @ API: driver for the unit tests below. <>= public :: decays_test <>= subroutine decays_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine decays_test @ %def decays_test @ \subsubsection{Testbed} As a variation of the [[prepare_test_process]] routine used elsewhere, we define here a routine that creates two processes (scattering $ss\to ss$ and decay $s\to f\bar f$), compiles and integrates them and prepares for event generation. <>= public :: prepare_testbed <>= subroutine prepare_testbed & (lib, process_stack, prefix, os_data, & scattering, decay, decay_rest_frame) type(process_library_t), intent(out), target :: lib type(process_stack_t), intent(out) :: process_stack type(string_t), intent(in) :: prefix type(os_data_t), intent(in) :: os_data logical, intent(in) :: scattering, decay logical, intent(in), optional :: decay_rest_frame type(model_t), target :: model type(model_t), target :: model_copy type(string_t) :: libname, procname1, procname2 type(process_entry_t), pointer :: process type(process_instance_t), allocatable, target :: process_instance class(phs_config_t), allocatable :: phs_config_template type(field_data_t), pointer :: field_data real(default) :: sqrts libname = prefix // "_lib" procname1 = prefix // "_p" procname2 = prefix // "_d" call model%init_test () call model%set_par (var_str ("ff"), 0.4_default) call model%set_par (var_str ("mf"), & model%get_real (var_str ("ff")) * model%get_real (var_str ("ms"))) if (scattering .and. decay) then field_data => model%get_field_ptr (25) call field_data%set (p_is_stable = .false.) end if call prc_test_create_library (libname, lib, & scattering = .true., decay = .true., & procname1 = procname1, procname2 = procname2) call reset_interaction_counter () allocate (phs_single_config_t :: phs_config_template) if (scattering) then call model_copy%init (model%get_name (), & model%get_n_real (), & model%get_n_complex (), & model%get_n_field (), & model%get_n_vtx ()) call model_copy%copy_from (model) allocate (process) call process%init (procname1, lib, os_data, model_copy) call process%setup_test_cores () call process%init_components (phs_config_template) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test_midpoint) call process%setup_terms () allocate (process_instance) call process_instance%init (process%process_t) call process_instance%integrate (1, n_it = 1, n_calls = 100) call process%final_integration (1) call process_instance%final () deallocate (process_instance) call process%prepare_simulation (1) call process_stack%push (process) end if if (decay) then call model_copy%init (model%get_name (), & model%get_n_real (), & model%get_n_complex (), & model%get_n_field (), & model%get_n_vtx ()) call model_copy%copy_from (model) allocate (process) call process%init (procname2, lib, os_data, model_copy) call process%setup_test_cores () call process%init_components (phs_config_template) if (present (decay_rest_frame)) then call process%setup_beams_decay (rest_frame = decay_rest_frame, i_core = 1) else call process%setup_beams_decay (rest_frame = .not. scattering, i_core = 1) end if call process%configure_phs () call process%setup_mci (dispatch_mci_test_midpoint) call process%setup_terms () allocate (process_instance) call process_instance%init (process%process_t) call process_instance%integrate (1, n_it=1, n_calls=100) call process%final_integration (1) call process_instance%final () deallocate (process_instance) call process%prepare_simulation (1) call process_stack%push (process) end if call model%final () call model_copy%final () end subroutine prepare_testbed @ %def prepare_testbed @ MCI record prepared for midpoint integrator. <>= subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo) use variables, only: var_list_t class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_midpoint_t :: mci) end subroutine dispatch_mci_test_midpoint @ %def dispatch_mci_test_midpoint @ \subsubsection{Simple decay configuration} We define a branching configuration with two decay modes. We set the integral values by hand, so we do not need to evaluate processes, yet. <>= call test (decays_1, "decays_1", & "branching and decay configuration", & u, results) <>= public :: decays_1 <>= subroutine decays_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t) :: flv_h type(flavor_t), dimension(2,1) :: flv_hbb, flv_hgg type(unstable_config_t), allocatable :: unstable write (u, "(A)") "* Test output: decays_1" write (u, "(A)") "* Purpose: Set up branching and decay configuration" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call os_data%init () call model%init_sm_test () call flv_h%init (25, model) call flv_hbb(:,1)%init ([5, -5], model) call flv_hgg(:,1)%init ([22, 22], model) write (u, "(A)") "* Set up branching and decay" write (u, "(A)") allocate (unstable) call unstable%init (flv_h) call unstable%init_decays ([var_str ("h_bb"), var_str ("h_gg")], model) call unstable%init_test_case1 & (1, flv_hbb, 1.234e-3_default, .02_default, model) call unstable%init_test_case1 & (2, flv_hgg, 3.085e-4_default, .08_default, model) call unstable%compute () call unstable%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call unstable%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_1" end subroutine decays_1 @ %def decays_1 @ \subsubsection{Cascade decay configuration} We define a branching configuration with one decay, which is followed by another branching. <>= call test (decays_2, "decays_2", & "cascade decay configuration", & u, results) <>= public :: decays_2 <>= subroutine decays_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_data_t), target :: model type(flavor_t) :: flv_h, flv_wp, flv_wm type(flavor_t), dimension(2,1) :: flv_hww, flv_wud, flv_wen type(unstable_config_t), allocatable :: unstable write (u, "(A)") "* Test output: decays_2" write (u, "(A)") "* Purpose: Set up cascade branching" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call os_data%init () call model%init_sm_test () call model%set_unstable (25, [var_str ("h_ww")]) call model%set_unstable (24, [var_str ("w_ud"), var_str ("w_en")]) call flv_h%init (25, model) call flv_hww(:,1)%init ([24, -24], model) call flv_wp%init (24, model) call flv_wm%init (-24, model) call flv_wud(:,1)%init ([2, -1], model) call flv_wen(:,1)%init ([-11, 12], model) write (u, "(A)") "* Set up branching and decay" write (u, "(A)") allocate (unstable) call unstable%init (flv_h, set_decays=.true., model=model) call unstable%init_test_case2 (flv_hww, flv_wud, flv_wen, model) call unstable%compute () call unstable%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call unstable%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_2" end subroutine decays_2 @ %def decays_2 @ \subsubsection{Decay and Process Object} We define a branching configuration with one decay and connect this with an actual process object. <>= call test (decays_3, "decays_3", & "associate process", & u, results) <>= public :: decays_3 <>= subroutine decays_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_library_t), target :: lib type(string_t) :: prefix type(string_t) :: procname2 type(process_stack_t) :: process_stack type(process_t), pointer :: process type(unstable_config_t), allocatable :: unstable type(flavor_t) :: flv write (u, "(A)") "* Test output: decays_3" write (u, "(A)") "* Purpose: Connect a decay configuration & &with a process" write (u, "(A)") write (u, "(A)") "* Initialize environment and integrate process" write (u, "(A)") call os_data%init () prefix = "decays_3" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.false., decay=.true., decay_rest_frame=.false.) procname2 = prefix // "_d" process => process_stack%get_process_ptr (procname2) model => process%get_model_ptr () call process%write (.false., u) write (u, "(A)") write (u, "(A)") "* Set up branching and decay" write (u, "(A)") call flv%init (25, model) allocate (unstable) call unstable%init (flv) call unstable%init_decays ([procname2], model) write (u, "(A)") "* Connect decay with process object" write (u, "(A)") call unstable%connect_decay (1, process, model) call unstable%compute () call unstable%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call unstable%final () call process_stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_3" end subroutine decays_3 @ %def decays_3 @ \subsubsection{Decay and Process Object} Building upon the previous test, we set up a decay instance and generate a decay event. <>= call test (decays_4, "decays_4", & "decay instance", & u, results) <>= public :: decays_4 <>= subroutine decays_4 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_library_t), target :: lib type(string_t) :: prefix, procname2 class(rng_t), allocatable :: rng type(process_stack_t) :: process_stack type(process_t), pointer :: process type(unstable_config_t), allocatable, target :: unstable type(flavor_t) :: flv type(unstable_t), allocatable :: instance write (u, "(A)") "* Test output: decays_4" write (u, "(A)") "* Purpose: Create a decay process and evaluate & &an instance" write (u, "(A)") write (u, "(A)") "* Initialize environment, process, & &and decay configuration" write (u, "(A)") call os_data%init () prefix = "decays_4" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.false., decay=.true., decay_rest_frame = .false.) procname2 = prefix // "_d" process => process_stack%get_process_ptr (procname2) model => process%get_model_ptr () call flv%init (25, model) allocate (unstable) call unstable%init (flv) call unstable%init_decays ([procname2], model) call model%set_unstable (25, [procname2]) call unstable%connect_decay (1, process, model) call unstable%compute () allocate (rng_test_t :: rng) allocate (instance) call instance%init (unstable) call instance%import_rng (rng) call instance%select_chain () call instance%generate () call instance%write (u) write (u, *) call instance%write_process_instances (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call instance%final () call process_stack%final () call unstable%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_4" end subroutine decays_4 @ %def decays_4 @ \subsubsection{Decay with Parent Process} We define a scattering process $ss\to ss$ and subsequent decays $s\to f\bar f$. <>= call test (decays_5, "decays_5", & "parent process and decay", & u, results) <>= public :: decays_5 <>= subroutine decays_5 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_library_t), target :: lib type(string_t) :: prefix, procname1, procname2 type(process_stack_t) :: process_stack type(process_t), pointer :: process type(process_instance_t), allocatable, target :: process_instance type(decay_root_config_t), target :: decay_root_config type(decay_root_t) :: decay_root type(decay_chain_t) :: decay_chain write (u, "(A)") "* Test output: decays_5" write (u, "(A)") "* Purpose: Handle a process with subsequent decays" write (u, "(A)") write (u, "(A)") "* Initialize environment and parent process" write (u, "(A)") call os_data%init () prefix = "decays_5" procname1 = prefix // "_p" procname2 = prefix // "_d" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.true., decay=.true.) write (u, "(A)") "* Initialize decay process" write (u, "(A)") process => process_stack%get_process_ptr (procname1) model => process%get_model_ptr () call model%set_unstable (25, [procname2]) write (u, "(A)") "* Initialize decay tree configuration" write (u, "(A)") call decay_root_config%connect (process, model, process_stack) call decay_root_config%compute () call decay_root_config%write (u) write (u, "(A)") write (u, "(A)") "* Initialize decay tree" allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () call process_instance%init_simulation (1) call decay_root%init (decay_root_config, process_instance) write (u, "(A)") write (u, "(A)") "* Select decay chain" write (u, "(A)") call decay_root%set_mci (1) !!! Not yet implemented; there is only one term anyway: ! call process_instance%select_i_term (decay_root%selected_term) call decay_root%set_term (1) call decay_root%select_chain () call decay_chain%build (decay_root) call decay_root%write (u) write (u, "(A)") write (u, "(A)") "* Generate event" write (u, "(A)") call process_instance%generate_unweighted_event (decay_root%get_mci ()) call process_instance%evaluate_event_data () call decay_root%generate () call pacify (decay_root) write (u, "(A)") "* Process instances" write (u, "(A)") call decay_root%write_process_instances (u) write (u, "(A)") write (u, "(A)") "* Generate decay chain" write (u, "(A)") call decay_chain%evaluate () call decay_chain%write (u) write (u, *) write (u, "(A,ES19.12)") "chain probability =", & decay_chain%get_probability () write (u, "(A)") write (u, "(A)") "* Cleanup" call decay_chain%final () call decay_root%final () call decay_root_config%final () call process_instance%final () deallocate (process_instance) call process_stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_5" end subroutine decays_5 @ %def decays_5 @ \subsubsection{Decay as Event Transform} Again, we define a scattering process $ss\to ss$ and subsequent decays $s\to f\bar f$. <>= call test (decays_6, "decays_6", & "evt_decay object", & u, results) <>= public :: decays_6 <>= subroutine decays_6 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(process_library_t), target :: lib type(string_t) :: prefix, procname1, procname2 type(process_stack_t) :: process_stack type(process_t), pointer :: process type(process_instance_t), allocatable, target :: process_instance type(evt_decay_t), target :: evt_decay integer :: factorization_mode logical :: keep_correlations write (u, "(A)") "* Test output: decays_6" write (u, "(A)") "* Purpose: Handle a process with subsequent decays" write (u, "(A)") write (u, "(A)") "* Initialize environment and parent process" write (u, "(A)") call os_data%init () prefix = "decays_6" procname1 = prefix // "_p" procname2 = prefix // "_d" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.true., decay=.true.) write (u, "(A)") "* Initialize decay process" process => process_stack%get_process_ptr (procname1) model => process%get_model_ptr () call model%set_unstable (25, [procname2]) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () call process_instance%init_simulation (1) write (u, "(A)") write (u, "(A)") "* Initialize decay object" call evt_decay%connect (process_instance, model, process_stack) write (u, "(A)") write (u, "(A)") "* Generate scattering event" call process_instance%generate_unweighted_event (1) call process_instance%evaluate_event_data () write (u, "(A)") write (u, "(A)") "* Select decay chain and generate event" write (u, "(A)") call evt_decay%prepare_new_event (1, 1) call evt_decay%generate_unweighted () factorization_mode = FM_IGNORE_HELICITY keep_correlations = .false. call evt_decay%make_particle_set (factorization_mode, keep_correlations) call evt_decay%write (u, verbose = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_decay%final () call process_instance%final () deallocate (process_instance) call process_stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: decays_6" end subroutine decays_6 @ %def decays_6 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Tau decays} <<[[tau_decays.f90]]>>= <> module tau_decays <> use io_units use format_utils, only: write_separator use sm_qcd use model_data use models use event_transforms <> <> <> contains <> end module tau_decays @ %def tau_decays \subsection{Tau Decays Event Transform} This is the type for the tau decay event transform. <>= public :: evt_tau_decays_t <>= type, extends (evt_t) :: evt_tau_decays_t type(model_t), pointer :: model_hadrons => null() type(qcd_t) :: qcd contains <> end type evt_tau_decays_t @ %def evt_tau_decays_t <>= procedure :: write_name => evt_tau_decays_write_name <>= subroutine evt_tau_decays_write_name (evt, unit) class(evt_tau_decays_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: tau decays" end subroutine evt_tau_decays_write_name @ %def evt_tau_decays_write_name @ Output. <>= procedure :: write => evt_tau_decays_write <>= subroutine evt_tau_decays_write (evt, unit, verbose, more_verbose, testflag) class(evt_tau_decays_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u) call evt%base_write (u, testflag = testflag, show_set = .false.) if (evt%particle_set_exists) & call evt%particle_set%write & (u, summary = .true., compressed = .true., testflag = testflag) call write_separator (u) end subroutine evt_tau_decays_write @ %def evt_tau_decays_write @ Here we take the particle set from the previous event transform and apply the tau decays. What probability should be given back, the product of branching ratios of the corresponding tau decays? <>= procedure :: generate_weighted => evt_tau_decays_generate_weighted <>= subroutine evt_tau_decays_generate_weighted (evt, probability) class(evt_tau_decays_t), intent(inout) :: evt real(default), intent(inout) :: probability logical :: valid evt%particle_set = evt%previous%particle_set !!! To be checked or expanded probability = 1 valid = .true. evt%particle_set_exists = valid end subroutine evt_tau_decays_generate_weighted @ %def evt_tau_decays_generate_weighted @ The factorization parameters are irrelevant. <>= procedure :: make_particle_set => evt_tau_decays_make_particle_set <>= subroutine evt_tau_decays_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_tau_decays_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r logical :: valid !!! to be checked and expanded valid = .true. evt%particle_set_exists = evt%particle_set_exists .and. valid end subroutine evt_tau_decays_make_particle_set @ %def event_tau_decays_make_particle_set @ <>= procedure :: prepare_new_event => evt_tau_decays_prepare_new_event <>= subroutine evt_tau_decays_prepare_new_event (evt, i_mci, i_term) class(evt_tau_decays_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term call evt%reset () end subroutine evt_tau_decays_prepare_new_event @ %def evt_tau_decays_prepare_new_event @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Shower} We might use matrix elements of LO and NLO to increase the accuracy of the shower in the sense of matching as well as merging. <<[[shower.f90]]>>= <> module shower <> <> <> use io_units use format_utils, only: write_separator use system_defs, only: LF use os_interface use diagnostics use lorentz use pdf use subevents, only: PRT_BEAM_REMNANT, PRT_INCOMING, PRT_OUTGOING use shower_base use matching_base use powheg_matching, only: powheg_matching_t use sm_qcd use model_data use rng_base use event_transforms use models use hep_common use process, only: process_t use instances, only: process_instance_t use process_stacks <> <> <> <> contains <> end module shower @ %def shower @ \subsection{Configuration Parameters} [[POWHEG_TESTING]] allows to disable the parton shower for validation and testing of the POWHEG procedure. <>= logical, parameter :: POWHEG_TESTING = .false. @ %def POWHEG_TESTING @ \subsection{Event Transform} The event transforms can do more than mere showering. Especially, it may reweight showered events to fixed-order matrix elements. The [[model_hadrons]] is supposed to be the SM variant that contains all hadrons that can be generated in the shower. <>= public :: evt_shower_t <>= type, extends (evt_t) :: evt_shower_t class(shower_base_t), allocatable :: shower class(matching_t), allocatable :: matching type(model_t), pointer :: model_hadrons => null () type(qcd_t) :: qcd type(pdf_data_t) :: pdf_data type(os_data_t) :: os_data logical :: is_first_event contains <> end type evt_shower_t @ %def evt_shower_t @ <>= procedure :: write_name => evt_shower_write_name <>= subroutine evt_shower_write_name (evt, unit) class(evt_shower_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: shower" end subroutine evt_shower_write_name @ %def evt_shower_write_name @ Output. <>= procedure :: write => evt_shower_write <>= subroutine evt_shower_write (evt, unit, verbose, more_verbose, testflag) class(evt_shower_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u) call evt%base_write (u, testflag = testflag, show_set = .false.) if (evt%particle_set_exists) call evt%particle_set%write & (u, summary = .true., compressed = .true., testflag = testflag) call write_separator (u) call evt%shower%settings%write (u) end subroutine evt_shower_write @ %def evt_shower_write <>= procedure :: connect => evt_shower_connect <>= subroutine evt_shower_connect & (evt, process_instance, model, process_stack) class(evt_shower_t), intent(inout), target :: evt type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack call evt%base_connect (process_instance, model, process_stack) call evt%make_rng (evt%process) if (allocated (evt%matching)) then call evt%matching%connect (process_instance, model, evt%shower) end if end subroutine evt_shower_connect @ %def evt_shower_connect @ Initialize the event transformation. This will be executed once during dispatching. The [[model_hadrons]] is supposed to be the SM variant that contains all hadrons that may be generated in the shower. <>= procedure :: init => evt_shower_init <>= subroutine evt_shower_init (evt, model_hadrons, os_data) class(evt_shower_t), intent(out) :: evt type(model_t), intent(in), target :: model_hadrons type(os_data_t), intent(in) :: os_data evt%os_data = os_data evt%model_hadrons => model_hadrons evt%is_first_event = .true. end subroutine evt_shower_init @ %def evt_shower_init @ Create RNG instances, spawned by the process object. <>= procedure :: make_rng => evt_shower_make_rng <>= subroutine evt_shower_make_rng (evt, process) class(evt_shower_t), intent(inout) :: evt type(process_t), intent(inout) :: process class(rng_t), allocatable :: rng call process%make_rng (rng) call evt%shower%import_rng (rng) if (allocated (evt%matching)) then call process%make_rng (rng) call evt%matching%import_rng (rng) end if end subroutine evt_shower_make_rng @ %def evt_shower_make_rng @ Things we want to do for a new event before the whole event transformation chain is evaluated. <>= procedure :: prepare_new_event => evt_shower_prepare_new_event <>= subroutine evt_shower_prepare_new_event (evt, i_mci, i_term) class(evt_shower_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term real(default) :: fac_scale, alpha_s fac_scale = evt%process_instance%get_fac_scale (i_term) alpha_s = evt%process_instance%get_alpha_s (i_term) call evt%reset () call evt%shower%prepare_new_event (fac_scale, alpha_s) end subroutine evt_shower_prepare_new_event @ %def evt_shower_prepare_new_event @ <>= procedure :: first_event => evt_shower_first_event <>= subroutine evt_shower_first_event (evt) class(evt_shower_t), intent(inout) :: evt double precision :: pdftest if (debug_on) call msg_debug (D_TRANSFORMS, "evt_shower_first_event") associate (settings => evt%shower%settings) settings%hadron_collision = .false. !!! !!! !!! Workaround for PGF90 v16.1 !!! if (all (evt%particle_set%prt(1:2)%flv%get_pdg_abs () <= 39)) then if (evt%particle_set%prt(1)%flv%get_pdg_abs () <= 39 .and. & evt%particle_set%prt(2)%flv%get_pdg_abs () <= 39) then settings%hadron_collision = .false. !!! else if (all (evt%particle_set%prt(1:2)%flv%get_pdg_abs () >= 100)) then else if (evt%particle_set%prt(1)%flv%get_pdg_abs () >= 100 .and. & evt%particle_set%prt(2)%flv%get_pdg_abs () >= 100) then settings%hadron_collision = .true. else call msg_fatal ("evt_shower didn't recognize beams setup") end if if (debug_on) call msg_debug (D_TRANSFORMS, "hadron_collision", settings%hadron_collision) if (allocated (evt%matching)) then evt%matching%is_hadron_collision = settings%hadron_collision call evt%matching%first_event () end if if (.not. settings%hadron_collision .and. settings%isr_active) then call msg_fatal ("?ps_isr_active is only intended for hadron-collisions") end if if (evt%pdf_data%type == STRF_LHAPDF5) then if (settings%isr_active .and. settings%hadron_collision) then call GetQ2max (0, pdftest) if (pdftest < epsilon (pdftest)) then call msg_bug ("ISR QCD shower enabled, but LHAPDF not " // & "initialized," // LF // " aborting simulation") return end if end if else if (evt%pdf_data%type == STRF_PDF_BUILTIN .and. & settings%method == PS_PYTHIA6) then call msg_fatal ("Builtin PDFs cannot be used for PYTHIA showers," & // LF // " aborting simulation") return end if end associate evt%is_first_event = .false. end subroutine evt_shower_first_event @ %def evt_shower_first_event @ Here we take the particle set from the previous event transform (assuming that there is always one) and apply the shower algorithm. The result is stored in the event transform of the current object. We always return a probability of unity as we don't have the analytic weight of the combination of shower, MLM matching and hadronization. A subdivision into multiple event transformations is under construction. Invalid or vetoed events have to be discarded by the caller which is why we mark the particle set as invalid. This procedure directly takes the (MLM) matching into account. <>= procedure :: generate_weighted => evt_shower_generate_weighted <>= subroutine evt_shower_generate_weighted (evt, probability) class(evt_shower_t), intent(inout) :: evt real(default), intent(inout) :: probability logical :: valid, vetoed if (debug_on) call msg_debug (D_TRANSFORMS, "evt_shower_generate_weighted") if (signal_is_pending ()) return evt%particle_set = evt%previous%particle_set valid = .true.; vetoed = .false. if (evt%is_first_event) call evt%first_event () call evt%shower%import_particle_set (evt%particle_set) if (allocated (evt%matching)) then call evt%matching%before_shower (evt%particle_set, vetoed) if (msg_level(D_TRANSFORMS) >= DEBUG) then if (debug_on) call msg_debug (D_TRANSFORMS, "Matching before generate emissions") call evt%matching%write () end if end if if (.not. (vetoed .or. POWHEG_TESTING)) then if (evt%shower%settings%method == PS_PYTHIA6 .or. & evt%shower%settings%hadronization_active) then call assure_heprup (evt%particle_set) end if call evt%shower%generate_emissions (valid) end if probability = 1 evt%particle_set_exists = valid .and. .not. vetoed end subroutine evt_shower_generate_weighted @ %def evt_shower_generate_weighted @ Here, we fill the particle set with the partons from the shower. The factorization parameters are irrelevant. We make a sanity check that the initial energy lands either in the outgoing particles or add to the beam remnant. <>= procedure :: make_particle_set => evt_shower_make_particle_set <>= subroutine evt_shower_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_shower_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r type(vector4_t) :: sum_vec_in, sum_vec_out, sum_vec_beamrem, & sum_vec_beamrem_before logical :: vetoed, sane if (evt%particle_set_exists) then vetoed = .false. sum_vec_beamrem_before = sum (evt%particle_set%prt%p, & mask=evt%particle_set%prt%get_status () == PRT_BEAM_REMNANT) call evt%shower%make_particle_set (evt%particle_set, & evt%model, evt%model_hadrons) if (allocated (evt%matching)) then call evt%matching%after_shower (evt%particle_set, vetoed) end if if (debug_active (D_TRANSFORMS)) then call msg_debug (D_TRANSFORMS, & "Shower: obtained particle set after shower + matching") call evt%particle_set%write (summary = .true., compressed = .true.) end if sum_vec_in = sum (evt%particle_set%prt%p, & mask=evt%particle_set%prt%get_status () == PRT_INCOMING) sum_vec_out = sum (evt%particle_set%prt%p, & mask=evt%particle_set%prt%get_status () == PRT_OUTGOING) sum_vec_beamrem = sum (evt%particle_set%prt%p, & mask=evt%particle_set%prt%get_status () == PRT_BEAM_REMNANT) sum_vec_beamrem = sum_vec_beamrem - sum_vec_beamrem_before sane = abs(sum_vec_out%p(0) - sum_vec_in%p(0)) < & sum_vec_in%p(0) / 10 .or. & abs((sum_vec_out%p(0) + sum_vec_beamrem%p(0)) - sum_vec_in%p(0)) < & sum_vec_in%p(0) / 10 sane = .true. evt%particle_set_exists = .not. vetoed .and. sane end if end subroutine evt_shower_make_particle_set @ %def event_shower_make_particle_set @ <>= procedure :: contains_powheg_matching => evt_shower_contains_powheg_matching <>= function evt_shower_contains_powheg_matching (evt) result (val) logical :: val class(evt_shower_t), intent(in) :: evt val = .false. if (allocated (evt%matching)) & val = evt%matching%get_method () == "POWHEG" end function evt_shower_contains_powheg_matching @ %def evt_shower_contains_powheg_matching @ <>= procedure :: disable_powheg_matching => evt_shower_disable_powheg_matching <>= subroutine evt_shower_disable_powheg_matching (evt) class(evt_shower_t), intent(inout) :: evt select type (matching => evt%matching) type is (powheg_matching_t) matching%active = .false. class default call msg_fatal ("Trying to disable powheg but no powheg matching is allocated!") end select end subroutine evt_shower_disable_powheg_matching @ %def evt_shower_disable_powheg_matching @ <>= procedure :: enable_powheg_matching => evt_shower_enable_powheg_matching <>= subroutine evt_shower_enable_powheg_matching (evt) class(evt_shower_t), intent(inout) :: evt select type (matching => evt%matching) type is (powheg_matching_t) matching%active = .true. class default call msg_fatal ("Trying to enable powheg but no powheg matching is allocated!") end select end subroutine evt_shower_enable_powheg_matching @ %def evt_shower_enable_powheg_matching @ <>= procedure :: final => evt_shower_final <>= subroutine evt_shower_final (evt) class(evt_shower_t), intent(inout) :: evt call evt%base_final () if (allocated (evt%matching)) call evt%matching%final () end subroutine evt_shower_final @ %def evt_shower_final @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[shower_ut.f90]]>>= <> module shower_ut use unit_tests use shower_uti <> <> contains <> end module shower_ut @ %def shower_ut @ <<[[shower_uti.f90]]>>= <> module shower_uti <> <> use format_utils, only: write_separator use os_interface use sm_qcd use physics_defs, only: BORN use model_data use models use state_matrices, only: FM_IGNORE_HELICITY use process_libraries use rng_base use rng_tao use dispatch_rng, only: dispatch_rng_factory_fallback use mci_base use mci_midpoint use phs_base use phs_single use prc_core_def, only: prc_core_def_t use prc_core use prc_omega use variables use event_transforms use tauola_interface !NODEP! use process, only: process_t use instances, only: process_instance_t use pdf use shower_base use shower_core use dispatch_rng_ut, only: dispatch_rng_factory_tao use shower <> <> contains <> end module shower_uti @ %def shower_uti @ API: driver for the unit tests below. <>= public :: shower_test <>= subroutine shower_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine shower_test @ %def shower_test @ \subsubsection{Testbed} This sequence sets up a two-jet process, ready for generating events. <>= <> @ <>= subroutine setup_testbed & (prefix, os_data, lib, model_list, process, process_instance) type(string_t), intent(in) :: prefix type(os_data_t), intent(out) :: os_data type(process_library_t), intent(out), target :: lib type(model_list_t), intent(out) :: model_list type(model_t), pointer :: model type(model_t), pointer :: model_tmp type(process_t), target, intent(out) :: process type(process_instance_t), target, intent(out) :: process_instance type(var_list_t), pointer :: model_vars type(string_t) :: model_name, libname, procname type(process_def_entry_t), pointer :: entry type(string_t), dimension(:), allocatable :: prt_in, prt_out class(prc_core_t), allocatable :: core_template class(phs_config_t), allocatable :: phs_config_template real(default) :: sqrts model_name = "SM" libname = prefix // "_lib" procname = prefix // "p" call os_data%init () dispatch_rng_factory_fallback => dispatch_rng_factory_tao allocate (model_tmp) call model_list%read_model (model_name, model_name // ".mdl", & os_data, model_tmp) model_vars => model_tmp%get_var_list_ptr () call model_vars%set_real (var_str ("me"), 0._default, & is_known = .true.) model => model_tmp call lib%init (libname) allocate (prt_in (2), source = [var_str ("e-"), var_str ("e+")]) allocate (prt_out (2), source = [var_str ("d"), var_str ("dbar")]) allocate (entry) call entry%init (procname, model, n_in = 2, n_components = 1) call omega_make_process_component (entry, 1, & model_name, prt_in, prt_out, & report_progress=.true.) call lib%append (entry) call lib%configure (os_data) call lib%write_makefile (os_data, force = .true., verbose = .false.) call lib%clean (os_data, distclean = .false.) call lib%write_driver (force = .true.) call lib%load (os_data) call process%init (procname, lib, os_data, model) allocate (prc_omega_t :: core_template) allocate (phs_single_config_t :: phs_config_template) call process%setup_cores (dispatch_core_omega_test) call process%init_components (phs_config_template) sqrts = 1000 call process%setup_beams_sqrts (sqrts, i_core = 1) call process%configure_phs () call process%setup_mci (dispatch_mci_test_midpoint) call process%setup_terms () call process_instance%init (process) call process_instance%integrate (1, 1, 1000) call process%final_integration (1) call process_instance%setup_event_data (i_core = 1) call process_instance%init_simulation (1) call process_instance%generate_weighted_event (1) call process_instance%evaluate_event_data () end subroutine setup_testbed @ %def setup_testbed @ A minimal dispatcher version that allocates the core object for testing. <>= subroutine dispatch_core_omega_test (core, core_def, model, & helicity_selection, qcd, use_color_factors, has_beam_pol) class(prc_core_t), allocatable, intent(inout) :: core class(prc_core_def_t), intent(in) :: core_def class(model_data_t), intent(in), target, optional :: model type(helicity_selection_t), intent(in), optional :: helicity_selection type(qcd_t), intent(in), optional :: qcd logical, intent(in), optional :: use_color_factors logical, intent(in), optional :: has_beam_pol allocate (prc_omega_t :: core) select type (core) type is (prc_omega_t) call core%set_parameters (model) end select end subroutine dispatch_core_omega_test @ %def dispatch_core_omega_test @ MCI record prepared for midpoint integrator. <>= subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo) use variables, only: var_list_t class(mci_t), allocatable, intent(out) :: mci type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_id logical, intent(in), optional :: is_nlo allocate (mci_midpoint_t :: mci) end subroutine dispatch_mci_test_midpoint @ %def dispatch_mci_test_midpoint @ \subsubsection{Trivial Test} We generate a two-jet event and shower it using default settings, i.e. in disabled mode. <>= call test (shower_1, "shower_1", & "disabled shower", & u, results) <>= public :: shower_1 <>= subroutine shower_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(process_library_t), target :: lib type(model_list_t) :: model_list class(model_data_t), pointer :: model type(model_t), pointer :: model_hadrons type(process_t), target :: process type(process_instance_t), target :: process_instance type(pdf_data_t) :: pdf_data integer :: factorization_mode logical :: keep_correlations class(evt_t), allocatable, target :: evt_trivial class(evt_t), allocatable, target :: evt_shower type(shower_settings_t) :: settings type(taudec_settings_t) :: taudec_settings write (u, "(A)") "* Test output: shower_1" write (u, "(A)") "* Purpose: Two-jet event with disabled shower" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"), & os_data, model_hadrons) call setup_testbed (var_str ("shower_1"), & os_data, lib, model_list, process, process_instance) write (u, "(A)") "* Set up trivial transform" write (u, "(A)") allocate (evt_trivial_t :: evt_trivial) model => process%get_model_ptr () call evt_trivial%connect (process_instance, model) call evt_trivial%prepare_new_event (1, 1) call evt_trivial%generate_unweighted () factorization_mode = FM_IGNORE_HELICITY keep_correlations = .false. call evt_trivial%make_particle_set (factorization_mode, keep_correlations) select type (evt_trivial) type is (evt_trivial_t) call evt_trivial%write (u) call write_separator (u, 2) end select write (u, "(A)") write (u, "(A)") "* Set up shower event transform" write (u, "(A)") allocate (evt_shower_t :: evt_shower) select type (evt_shower) type is (evt_shower_t) call evt_shower%init (model_hadrons, os_data) allocate (shower_t :: evt_shower%shower) call evt_shower%shower%init (settings, taudec_settings, pdf_data, os_data) call evt_shower%connect (process_instance, model) end select evt_trivial%next => evt_shower evt_shower%previous => evt_trivial call evt_shower%prepare_new_event (1, 1) call evt_shower%generate_unweighted () call evt_shower%make_particle_set (factorization_mode, keep_correlations) select type (evt_shower) type is (evt_shower_t) call evt_shower%write (u) call write_separator (u, 2) end select write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_shower%final () call evt_trivial%final () call process_instance%final () call process%final () call lib%final () call model_hadrons%final () deallocate (model_hadrons) call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: shower_1" end subroutine shower_1 @ %def shower_1 @ \subsubsection{FSR Shower} We generate a two-jet event and shower it with the Whizard FSR shower. <>= call test (shower_2, "shower_2", & "final-state shower", & u, results) <>= public :: shower_2 <>= subroutine shower_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(process_library_t), target :: lib type(model_list_t) :: model_list type(model_t), pointer :: model_hadrons class(model_data_t), pointer :: model type(process_t), target :: process type(process_instance_t), target :: process_instance integer :: factorization_mode logical :: keep_correlations type(pdf_data_t) :: pdf_data class(evt_t), allocatable, target :: evt_trivial class(evt_t), allocatable, target :: evt_shower type(shower_settings_t) :: settings type(taudec_settings_t) :: taudec_settings write (u, "(A)") "* Test output: shower_2" write (u, "(A)") "* Purpose: Two-jet event with FSR shower" write (u, "(A)") write (u, "(A)") "* Initialize environment" write (u, "(A)") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM_hadrons"), var_str ("SM_hadrons.mdl"), & os_data, model_hadrons) call setup_testbed (var_str ("shower_2"), & os_data, lib, model_list, process, process_instance) model => process%get_model_ptr () write (u, "(A)") "* Set up trivial transform" write (u, "(A)") allocate (evt_trivial_t :: evt_trivial) call evt_trivial%connect (process_instance, model) call evt_trivial%prepare_new_event (1, 1) call evt_trivial%generate_unweighted () factorization_mode = FM_IGNORE_HELICITY keep_correlations = .false. call evt_trivial%make_particle_set (factorization_mode, keep_correlations) select type (evt_trivial) type is (evt_trivial_t) call evt_trivial%write (u) call write_separator (u, 2) end select write (u, "(A)") write (u, "(A)") "* Set up shower event transform" write (u, "(A)") settings%fsr_active = .true. allocate (evt_shower_t :: evt_shower) select type (evt_shower) type is (evt_shower_t) call evt_shower%init (model_hadrons, os_data) allocate (shower_t :: evt_shower%shower) call evt_shower%shower%init (settings, taudec_settings, pdf_data, os_data) call evt_shower%connect (process_instance, model) end select evt_trivial%next => evt_shower evt_shower%previous => evt_trivial call evt_shower%prepare_new_event (1, 1) call evt_shower%generate_unweighted () call evt_shower%make_particle_set (factorization_mode, keep_correlations) select type (evt_shower) type is (evt_shower_t) call evt_shower%write (u, testflag = .true.) call write_separator (u, 2) end select write (u, "(A)") write (u, "(A)") "* Cleanup" call evt_shower%final () call evt_trivial%final () call process_instance%final () call process%final () call lib%final () call model_hadrons%final () deallocate (model_hadrons) call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: shower_2" end subroutine shower_2 @ %def shower_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Fixed Order NLO Events} This section deals with the generation of weighted event samples which take into account next-to-leading order corrections. An approach generating unweighted events is not possible here, because negative weights might occur due to subtraction. Note that the events produced this way are not physical in the sense that they will not keep NLO-accuracy when interfaced to a parton shower. They are rather useful for theoretical consistency checks and a fast estimate of NLO effects.\\ We generate NLO events in the following way: First, the integration is carried out using the complete divergence-subtracted NLO matrix element. In the subsequent simulation, $N$-particle kinematics are generated using $\mathcal{B}+\mathcal{V}+\mathcal{C}$ as weight. After that, the program loops over all singular regions and for each of them generates an event with $N+1$-particle kinematics. The weight for those events corresponds to the real matrix element $\mathcal{R}^\alpha$ evaluated at the $\alpha$-region's emitter's phase space point, multiplied with $S_\alpha$. This procedure is implemented using the [[evt_nlo]] transform. <<[[evt_nlo.f90]]>>= <> module evt_nlo <> <> <> use io_units, only: given_output_unit use constants use lorentz use phs_points, only: phs_point_t use phs_points, only: assignment(=), operator(*), size use diagnostics use numeric_utils, only: nearly_equal use format_utils, only: write_separator use physics_defs, only: BORN, NLO_REAL use sm_qcd use model_data use interactions, only: interaction_t use particles use instances, only: process_instance_t use pcm, only: pcm_nlo_t, pcm_nlo_workspace_t use process_stacks use event_transforms use prc_core, only: prc_core_t use prc_external, only: prc_external_t use quantum_numbers, only: quantum_numbers_t use phs_fks, only: phs_fks_t, phs_fks_generator_t use phs_fks, only: phs_identifier_t, phs_point_set_t use resonances, only: resonance_contributors_t use fks_regions, only: region_data_t <> <> <> <> contains <> end module evt_nlo @ %def evt_nlo @ <>= type :: nlo_event_deps_t logical :: lab_is_cm = .true. type(phs_point_set_t) :: p_born_cms type(phs_point_set_t) :: p_born_lab type(phs_point_set_t) :: p_real_cms type(phs_point_set_t) :: p_real_lab type(resonance_contributors_t), dimension(:), allocatable :: contributors type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers integer, dimension(:), allocatable :: alr_to_i_con integer :: n_phs = 0 end type nlo_event_deps_t @ %def nlo_event_deps_t @ This event transformation is for the generation of fixed-order NLO events. It takes an event with Born kinematics and creates $N_\alpha + 1$ modified weighted events. The first one has Born kinematics and its weight is the sum of Born, virtual, subtraction and, if present, also DGLAP matrix elements. The other $N_\alpha$ events have a weight which is equal to the real matrix element, evaluated with the phase space corresponding to the emitter of the $\alpha$-region. As the NLO event transforms have different kinematics, they also differ in their [[particle_set]]s. The NLO [[event_t]] object carries a single pointer to a [[particle_set]]. To avoid interference between the different NLO [[particle_set]]s, we save the [[particle_set]] of the current $\alpha$-region in the array [[particle_set_nlo]]. Otherwise it would be unretrievable if the usual particle set of the event object was used. <>= integer, parameter, public :: EVT_NLO_UNDEFINED = 0 integer, parameter, public :: EVT_NLO_SEPARATE_BORNLIKE = 1 integer, parameter, public :: EVT_NLO_SEPARATE_REAL = 2 integer, parameter, public :: EVT_NLO_COMBINED = 3 <>= public :: evt_nlo_t <>= type, extends (evt_t) :: evt_nlo_t type(phs_fks_generator_t) :: phs_fks_generator real(default) :: sqme_rad = zero integer :: i_evaluation = 0 type(particle_set_t), dimension(:), allocatable :: particle_set_nlo type(qcd_t) :: qcd type(nlo_event_deps_t) :: event_deps integer :: mode = EVT_NLO_UNDEFINED integer, dimension(:), allocatable :: & i_evaluation_to_i_phs, i_evaluation_to_emitter, & i_evaluation_to_i_term logical :: keep_failed_events = .false. integer :: selected_i_flv = 0 contains <> end type evt_nlo_t @ %def evt_nlo_t @ <>= procedure :: write_name => evt_nlo_write_name <>= subroutine evt_nlo_write_name (evt, unit) class(evt_nlo_t), intent(in) :: evt integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event transform: NLO" end subroutine evt_nlo_write_name @ %def evt_nlo_write_name @ <>= procedure :: write => evt_nlo_write <>= subroutine evt_nlo_write (evt, unit, verbose, more_verbose, testflag) class(evt_nlo_t), intent(in) :: evt integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, more_verbose, testflag integer :: u, i u = given_output_unit (unit) call write_separator (u, 2) call evt%write_name (u) call write_separator (u) call evt%base_write (u, testflag = testflag, show_set = .true.) write (u,'(A,ES16.9)') "sqme_rad = ", evt%sqme_rad write (u, "(3x,A,I0)") "i_evaluation = ", evt%i_evaluation call write_separator (u) write (u, "(1x,A)") "Radiated particle sets:" do i = 1, size (evt%particle_set_nlo) call evt%particle_set_nlo(i)%write (u, testflag = testflag) call write_separator (u) end do end subroutine evt_nlo_write @ %def evt_nlo_write @ Connects the event transform to the process. Here also the phase space is set up by making [[real_kinematics]] point to the corresponding object in the [[pcm_instance]]. <>= procedure :: connect => evt_nlo_connect <>= subroutine evt_nlo_connect (evt, process_instance, model, process_stack) class(evt_nlo_t), intent(inout), target :: evt type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack if (debug_on) call msg_debug (D_TRANSFORMS, "evt_nlo_connect") call evt%base_connect (process_instance, model, process_stack) select type (pcm_work => process_instance%pcm_work) class is (pcm_nlo_workspace_t) select type (pcm => process_instance%pcm) type is (pcm_nlo_t) call pcm%setup_phs_generator (pcm_work, evt%phs_fks_generator, & process_instance%get_sqrts ()) call evt%set_i_evaluation_mappings (pcm%region_data, & pcm_work%real_kinematics%alr_to_i_phs) end select end select call evt%set_mode (process_instance) call evt%setup_general_event_kinematics (process_instance) if (evt%mode > EVT_NLO_SEPARATE_BORNLIKE) & call evt%setup_real_event_kinematics (process_instance) if (debug_on) call msg_debug2 (D_TRANSFORMS, "evt_nlo_connect: success") end subroutine evt_nlo_connect @ %def evt_nlo_connect @ <>= procedure :: set_i_evaluation_mappings => evt_nlo_set_i_evaluation_mappings <>= subroutine evt_nlo_set_i_evaluation_mappings (evt, reg_data, alr_to_i_phs) class(evt_nlo_t), intent(inout) :: evt type(region_data_t), intent(in) :: reg_data integer, intent(in), dimension(:) :: alr_to_i_phs integer :: n_phs, alr integer :: i_evaluation, i_phs, emitter logical :: checked type :: registered_triple_t integer, dimension(2) :: phs_em type(registered_triple_t), pointer :: next => null () end type registered_triple_t type(registered_triple_t), allocatable, target :: check_list i_evaluation = 1 n_phs = reg_data%n_phs allocate (evt%i_evaluation_to_i_phs (n_phs), source = 0) allocate (evt%i_evaluation_to_emitter (n_phs), source = -1) allocate (evt%i_evaluation_to_i_term (0 : n_phs), source = 0) do alr = 1, reg_data%n_regions i_phs = alr_to_i_phs (alr) emitter = reg_data%regions(alr)%emitter call search_check_list (checked) if (.not. checked) then evt%i_evaluation_to_i_phs (i_evaluation) = i_phs evt%i_evaluation_to_emitter (i_evaluation) = emitter i_evaluation = i_evaluation + 1 end if end do call fill_i_evaluation_to_i_term () if (.not. (all (evt%i_evaluation_to_i_phs > 0) & .and. all (evt%i_evaluation_to_emitter > -1))) then call msg_fatal ("evt_nlo: Inconsistent mappings!") else if (debug2_active (D_TRANSFORMS)) then print *, 'evt_nlo Mappings, i_evaluation -> ' print *, 'i_phs: ', evt%i_evaluation_to_i_phs print *, 'emitter: ', evt%i_evaluation_to_emitter end if end if contains subroutine fill_i_evaluation_to_i_term () integer :: i_term, i_evaluation, term_emitter !!! First find subtraction component i_evaluation = 1 do i_term = 1, evt%process%get_n_terms () if (evt%process_instance%term(i_term)%nlo_type /= NLO_REAL) cycle term_emitter = evt%process_instance%kin(i_term)%emitter if (term_emitter < 0) then evt%i_evaluation_to_i_term (0) = i_term else if (evt%i_evaluation_to_emitter(i_evaluation) == term_emitter) then evt%i_evaluation_to_i_term (i_evaluation) = i_term i_evaluation = i_evaluation + 1 end if end do end subroutine fill_i_evaluation_to_i_term subroutine search_check_list (found) logical, intent(out) :: found type(registered_triple_t), pointer :: current_triple => null () if (allocated (check_list)) then current_triple => check_list do if (all (current_triple%phs_em == [i_phs, emitter])) then found = .true. exit end if if (.not. associated (current_triple%next)) then allocate (current_triple%next) current_triple%next%phs_em = [i_phs, emitter] found = .false. exit else current_triple => current_triple%next end if end do else allocate (check_list) check_list%phs_em = [i_phs, emitter] found = .false. end if end subroutine search_check_list end subroutine evt_nlo_set_i_evaluation_mappings @ %def evt_nlo_set_i_evaluation_mappings @ <>= procedure :: get_i_phs => evt_nlo_get_i_phs <>= function evt_nlo_get_i_phs (evt) result (i_phs) integer :: i_phs class(evt_nlo_t), intent(in) :: evt i_phs = evt%i_evaluation_to_i_phs (evt%i_evaluation) end function evt_nlo_get_i_phs @ %def evt_nlo_get_i_phs @ <>= procedure :: get_emitter => evt_nlo_get_emitter <>= function evt_nlo_get_emitter (evt) result (emitter) integer :: emitter class(evt_nlo_t), intent(in) :: evt emitter = evt%i_evaluation_to_emitter (evt%i_evaluation) end function evt_nlo_get_emitter @ %def evt_nlo_get_emitter @ <>= procedure :: get_i_term => evt_nlo_get_i_term <>= function evt_nlo_get_i_term (evt) result (i_term) integer :: i_term class(evt_nlo_t), intent(in) :: evt if (evt%mode >= EVT_NLO_SEPARATE_REAL) then i_term = evt%i_evaluation_to_i_term (evt%i_evaluation) else i_term = evt%process_instance%get_first_active_i_term () end if end function evt_nlo_get_i_term @ %def evt_nlo_get_i_term @ The event transform has a variable which counts the number of times it has already been called for one generation point. If this variable, [[i_evaluation]], is zero, this means that [[evt_nlo_generate_weighted]] is called for the first time, so that the generation of an $N$-particle event is required. In all other cases, emission events are generated. During a separate integration of the real component, the first event of each event group will become the counterevent. In this case, we return the sum of all subtraction matrix elements. During a combined integration, the first event will be a combination of all Born-like events. To get the sum of their matrix elements, we subtract the sum of all real emissions from the sum of all matrix elements as the real contribution is the only non-Born contribution. Note that the argument named [[probablity]], the use of the routine [[generate_weighted]] and the procedure we use to generate NLO events via an event transformation is an abuse of the interface which should be refactored. <>= procedure :: generate_weighted => evt_nlo_generate_weighted <>= subroutine evt_nlo_generate_weighted (evt, probability) class(evt_nlo_t), intent(inout) :: evt real(default), intent(inout) :: probability real(default) :: sqme call print_debug_info () sqme = probability if (evt%mode > EVT_NLO_SEPARATE_BORNLIKE) then if (evt%i_evaluation == 0) then call evt%reset_phs_identifiers () call evt%evaluate_real_kinematics () if (evt%mode == EVT_NLO_SEPARATE_REAL) then sqme = evt%compute_subtraction_sqmes () else sqme = sqme - evt%compute_all_sqme_rad () end if else call evt%compute_real () sqme = evt%sqme_rad end if end if probability = sqme if (debug_on) call msg_debug (D_TRANSFORMS, "probability (after)", probability) contains function status_code_to_string (mode) result (smode) type(string_t) :: smode integer, intent(in) :: mode select case (mode) case (EVT_NLO_UNDEFINED) smode = var_str ("Undefined") case (EVT_NLO_SEPARATE_BORNLIKE) smode = var_str ("Born-like") case (EVT_NLO_SEPARATE_REAL) smode = var_str ("Real") case (EVT_NLO_COMBINED) smode = var_str ("Combined") end select end function status_code_to_string subroutine print_debug_info () if (debug_on) call msg_debug (D_TRANSFORMS, "evt_nlo_generate_weighted") if (debug_on) call msg_debug (D_TRANSFORMS, char ("mode: " // status_code_to_string (evt%mode))) if (debug_on) call msg_debug (D_TRANSFORMS, "probability (before)", probability) if (debug_on) call msg_debug (D_TRANSFORMS, "evt%i_evaluation", evt%i_evaluation) if (debug2_active (D_TRANSFORMS)) then if (evt%mode > EVT_NLO_SEPARATE_BORNLIKE) then if (evt%i_evaluation == 0) then print *, 'Evaluate subtraction component' else print *, 'Evaluate radiation component' end if end if end if end subroutine print_debug_info end subroutine evt_nlo_generate_weighted @ %def evt_nlo_generate_weighted @ <>= procedure :: reset_phs_identifiers => evt_nlo_reset_phs_identifiers <>= subroutine evt_nlo_reset_phs_identifiers (evt) class(evt_nlo_t), intent(inout) :: evt evt%event_deps%phs_identifiers%evaluated = .false. end subroutine evt_nlo_reset_phs_identifiers @ %def evt_nlo_reset_phs_identifiers @ The routine [[make_factorized_particle_set]] will setup the subevent momenta from the [[connected%matrix]]. Its initial state momenta correspond to the Born process without IS splitting and thus need to be updated with the real momenta from the [[int_hard]] to get correct momenta in the events with real radiation. Ideally the [[int_hard]] and the [[connected]] would be setup with correct [[source_link]]s to real momenta so that we would not need to replace momenta of the [[connected]] here. The parameter [[n_in]] from the [[int_matrix]] is still $0$ as it has been shifted to [[n_vir]]. We thus take [[n_in]] from the [[particle_set]]. <>= procedure :: connected_set_real_IS_momenta => evt_nlo_connected_set_real_IS_momenta <>= subroutine evt_nlo_connected_set_real_IS_momenta (evt) class(evt_nlo_t), intent(inout) :: evt type(vector4_t) :: p_hard, p_beam, p_remn type(interaction_t), pointer :: int_matrix integer :: i, i_term, n_in, i_in_beam, i_in_hard, i_in_remn i_term = evt%get_i_term () int_matrix => evt%process_instance%get_matrix_int_ptr (i_term) n_in = evt%particle_set%get_n_in () do i = 1, n_in i_in_beam = i i_in_hard = n_in + i i_in_remn = 2 * n_in + i p_hard = evt%process_instance%term(i_term)%int_hard%get_momentum (i) p_beam = int_matrix%get_momentum (i_in_beam) p_remn = p_beam - p_hard call int_matrix%set_momentum (p_hard , i_in_hard) call int_matrix%set_momentum (p_remn , i_in_remn) end do end subroutine evt_nlo_connected_set_real_IS_momenta @ %def evt_nlo_connected_set_real_IS_momenta @ <>= procedure :: make_particle_set => evt_nlo_make_particle_set <>= subroutine evt_nlo_make_particle_set & (evt, factorization_mode, keep_correlations, r) class(evt_nlo_t), intent(inout) :: evt integer, intent(in) :: factorization_mode logical, intent(in) :: keep_correlations real(default), dimension(:), intent(in), optional :: r if (evt%mode >= EVT_NLO_SEPARATE_BORNLIKE) then call make_factorized_particle_set (evt, factorization_mode, & keep_correlations, r, evt%get_i_term (), & evt%get_selected_quantum_numbers (evt%selected_i_flv)) else call make_factorized_particle_set (evt, factorization_mode, & keep_correlations, r) end if end subroutine evt_nlo_make_particle_set @ %def evt_nlo_make_particle_set @ <>= procedure :: evaluate_real_kinematics => evt_nlo_evaluate_real_kinematics <>= subroutine evt_nlo_evaluate_real_kinematics (evt) class(evt_nlo_t), intent(inout) :: evt integer :: alr, i_phs, i_con, emitter real(default), dimension(3) :: x_rad logical :: use_contributors integer :: n_regions integer :: i_term type(vector4_t), dimension(:), allocatable :: p_real select type (pcm_work => evt%process_instance%pcm_work) class is (pcm_nlo_workspace_t) x_rad = pcm_work%real_kinematics%x_rad associate (event_deps => evt%event_deps) i_term = evt%get_i_term () event_deps%p_born_lab%phs_point(1) = & evt%process_instance%term(i_term)%p_seed event_deps%p_born_cms%phs_point(1) & = evt%boost_to_cms (event_deps%p_born_lab%phs_point(1)) call evt%phs_fks_generator%set_sqrts_hat & (event_deps%p_born_cms%get_energy (1, 1)) use_contributors = allocated (event_deps%contributors) select type (pcm => evt%process_instance%pcm) type is (pcm_nlo_t) n_regions = pcm%region_data%n_regions end select do alr = 1, n_regions i_phs = pcm_work%real_kinematics%alr_to_i_phs(alr) if (event_deps%phs_identifiers(i_phs)%evaluated) cycle emitter = event_deps%phs_identifiers(i_phs)%emitter associate (generator => evt%phs_fks_generator) if (emitter <= evt%process%get_n_in ()) then call generator%prepare_generation (x_rad, i_phs, emitter, & event_deps%p_born_cms%phs_point(1)%get (), & event_deps%phs_identifiers) ! TODO wk 19-02-28: intent of p_real (also below)? p_real = event_deps%p_real_lab%phs_point(i_phs) call generator%generate_isr (i_phs, & event_deps%p_born_lab%phs_point(1)%get (), & p_real) event_deps%p_real_lab%phs_point(i_phs) = p_real event_deps%p_real_cms%phs_point(i_phs) & = evt%boost_to_cms (event_deps%p_real_lab%phs_point(i_phs)) else if (use_contributors) then i_con = event_deps%alr_to_i_con(alr) call generator%prepare_generation (x_rad, i_phs, emitter, & event_deps%p_born_cms%phs_point(1)%get (), & event_deps%phs_identifiers, event_deps%contributors, i_con) p_real = event_deps%p_real_cms%phs_point(i_phs) call generator%generate_fsr (emitter, i_phs, i_con, & event_deps%p_born_cms%phs_point(1)%get (), & p_real) event_deps%p_real_cms%phs_point(i_phs) = p_real else call generator%prepare_generation (x_rad, i_phs, emitter, & event_deps%p_born_cms%phs_point(1)%get (), & event_deps%phs_identifiers) p_real = event_deps%p_real_cms%phs_point(i_phs) call generator%generate_fsr (emitter, i_phs, & event_deps%p_born_cms%phs_point(1)%get (), & p_real) event_deps%p_real_cms%phs_point(i_phs) = p_real end if event_deps%p_real_lab%phs_point(i_phs) & = evt%boost_to_lab (event_deps%p_real_cms%phs_point(i_phs)) end if end associate call pcm_work%set_momenta & (event_deps%p_born_lab%phs_point(1)%get (), & event_deps%p_real_lab%phs_point(i_phs)%get (), & i_phs) call pcm_work%set_momenta & (event_deps%p_born_cms%phs_point(1)%get (), & event_deps%p_real_cms%phs_point(i_phs)%get (), & i_phs, cms = .true.) event_deps%phs_identifiers(i_phs)%evaluated = .true. end do end associate end select end subroutine evt_nlo_evaluate_real_kinematics @ %def evt_nlo_evaluate_real_kinematics @ This routine calls the evaluation of the singular regions only for the subtraction terms. <>= procedure :: compute_subtraction_sqmes => evt_nlo_compute_subtraction_sqmes <>= function evt_nlo_compute_subtraction_sqmes (evt) result (sqme) class(evt_nlo_t), intent(inout) :: evt real(default) :: sqme integer :: i_phs, i_term if (debug_on) call msg_debug (D_TRANSFORMS, "evt_nlo_compute_subtraction_sqmes") sqme = zero associate (event_deps => evt%event_deps) i_phs = 1; i_term = evt%i_evaluation_to_i_term(0) call evt%process_instance%compute_sqme_rad (i_term, i_phs, is_subtraction = .true.) sqme = sqme + evt%process_instance%get_sqme (i_term) end associate end function evt_nlo_compute_subtraction_sqmes @ %def evt_nlo_compute_subtraction_sqmes @ This routine calls the evaluation of the singular regions only for emission matrix elements. <>= procedure :: compute_real => evt_nlo_compute_real <>= subroutine evt_nlo_compute_real (evt) class(evt_nlo_t), intent(inout) :: evt integer :: i_phs, i_term if (debug_on) call msg_debug (D_TRANSFORMS, "evt_nlo_compute_real") i_phs = evt%get_i_phs () i_term = evt%i_evaluation_to_i_term (evt%i_evaluation) associate (event_deps => evt%event_deps) call evt%process_instance%compute_sqme_rad (i_term, i_phs, & is_subtraction = .false.) evt%sqme_rad = evt%process_instance%get_sqme (i_term) end associate end subroutine evt_nlo_compute_real @ %def evt_nlo_compute_real @ This routine calls the evaluation of the singular regions only for all emission matrix elements. This is needed for the combined mode. It returns the sum of all valid real matrix elements. <>= procedure :: compute_all_sqme_rad => evt_nlo_compute_all_sqme_rad <>= function evt_nlo_compute_all_sqme_rad (evt) result (sqme) class(evt_nlo_t), intent(inout) :: evt real(default) :: sqme integer :: i_phs, i_term if (debug_on) call msg_debug (D_TRANSFORMS, "evt_nlo_compute_all_sqme_rad") sqme = zero do i_term = 1, size (evt%process_instance%term) if (evt%is_valid_event (i_term)) then associate (term => evt%process_instance%term(i_term)) if (term%nlo_type == NLO_REAL .and. .not. term%is_subtraction ()) then i_phs = evt%process_instance%kin(i_term)%i_phs call evt%process_instance%compute_sqme_rad ( & i_term, i_phs, is_subtraction = .false.) sqme = sqme + evt%process_instance%get_sqme (i_term) end if end associate end if end do end function evt_nlo_compute_all_sqme_rad @ %def evt_nlo_compute_all_sqme_rad @ Boosts the given four vector [[p_lab]] to the Born or real CMS depending on the number of given momenta. Unfortunately, all boosts available via [[get_boost_to_cms]] are Born-like, so we need to compute the boost to the real CMS here manually. We cannot rely on [[i_term]] in order to determine whether to apply a Born-like or a real boost as we also need a real boost to compute the weights of the Born-like subevents as implemented in [[evt_nlo_generate_weighted]]. <>= procedure :: boost_to_cms => evt_nlo_boost_to_cms <>= function evt_nlo_boost_to_cms (evt, p_lab) result (p_cms) type(phs_point_t), intent(in) :: p_lab type(vector4_t) :: p0, p1 class(evt_nlo_t), intent(in) :: evt type(phs_point_t) :: p_cms type(lorentz_transformation_t) :: lt_lab_to_cms, lt real(default) :: sqrts_hat integer :: i_boost, n_legs_born if (evt%event_deps%lab_is_cm) then lt_lab_to_cms = identity else n_legs_born = size (evt%event_deps%p_born_lab%phs_point(1)) if (size (p_lab) == n_legs_born) then i_boost = evt%get_i_term () lt_lab_to_cms = evt%process_instance%get_boost_to_cms (i_boost) else sqrts_hat = (p_lab%select (1) + p_lab%select (2))**1 p0 = p_lab%select (1) + p_lab%select (2) lt = boost (p0, sqrts_hat) p1 = inverse(lt) * p_lab%select (1) lt_lab_to_cms = inverse (lt * rotation_to_2nd (3, space_part (p1))) end if end if p_cms = lt_lab_to_cms * p_lab end function evt_nlo_boost_to_cms @ %def evt_nlo_boost_to_cms @ Boosts the given four vector [[p_cms]] from the Born CMS to the lab system. It should not be called for ISR as in this case, the Born CMS and the real CMS differ. <>= procedure :: boost_to_lab => evt_nlo_boost_to_lab <>= function evt_nlo_boost_to_lab (evt, p_cms) result (p_lab) type(phs_point_t) :: p_lab class(evt_nlo_t), intent(in) :: evt type(phs_point_t), intent(in) :: p_cms type(lorentz_transformation_t) :: lt_cms_to_lab integer :: i_boost if (evt%event_deps%lab_is_cm) then lt_cms_to_lab = identity else i_boost = evt%get_i_term () lt_cms_to_lab = evt%process_instance%get_boost_to_lab (i_boost) end if p_lab = lt_cms_to_lab * p_cms end function evt_nlo_boost_to_lab @ %def evt_nlo_boost_to_lab @ <>= procedure :: setup_general_event_kinematics => evt_nlo_setup_general_event_kinematics <>= subroutine evt_nlo_setup_general_event_kinematics (evt, process_instance) class(evt_nlo_t), intent(inout) :: evt type(process_instance_t), intent(in) :: process_instance integer :: n_born associate (event_deps => evt%event_deps) event_deps%lab_is_cm = process_instance%lab_is_cm (1) select type (pcm => process_instance%pcm) type is (pcm_nlo_t) n_born = pcm%region_data%n_legs_born end select call event_deps%p_born_cms%init (n_born, 1) call event_deps%p_born_lab%init (n_born, 1) end associate end subroutine evt_nlo_setup_general_event_kinematics @ %def evt_nlo_setup_general_event_kinematics @ <>= procedure :: setup_real_event_kinematics => evt_nlo_setup_real_event_kinematics <>= subroutine evt_nlo_setup_real_event_kinematics (evt, process_instance) class(evt_nlo_t), intent(inout) :: evt type(process_instance_t), intent(in) :: process_instance integer :: n_real, n_phs integer :: i_real associate (event_deps => evt%event_deps) select type (pcm => process_instance%pcm) class is (pcm_nlo_t) n_real = pcm%region_data%n_legs_real end select i_real = evt%process%get_first_real_term () select type (phs => process_instance%kin(i_real)%phs) type is (phs_fks_t) event_deps%phs_identifiers = phs%phs_identifiers end select n_phs = size (event_deps%phs_identifiers) call event_deps%p_real_cms%init (n_real, n_phs) call event_deps%p_real_lab%init (n_real, n_phs) select type (pcm => process_instance%pcm) type is (pcm_nlo_t) if (allocated (pcm%region_data%alr_contributors)) then allocate (event_deps%contributors (size (pcm%region_data%alr_contributors))) event_deps%contributors = pcm%region_data%alr_contributors end if if (allocated (pcm%region_data%alr_to_i_contributor)) then allocate (event_deps%alr_to_i_con & (size (pcm%region_data%alr_to_i_contributor))) event_deps%alr_to_i_con = pcm%region_data%alr_to_i_contributor end if end select end associate end subroutine evt_nlo_setup_real_event_kinematics @ %def evt_nlo_setup_real_event_kinematics @ <>= procedure :: set_mode => evt_nlo_set_mode <>= subroutine evt_nlo_set_mode (evt, process_instance) class(evt_nlo_t), intent(inout) :: evt type(process_instance_t), intent(in) :: process_instance integer :: i_real select type (pcm => process_instance%pcm) type is (pcm_nlo_t) if (pcm%settings%combined_integration) then evt%mode = EVT_NLO_COMBINED else i_real = evt%process%get_first_real_component () if (i_real == evt%process%extract_active_component_mci ()) then evt%mode = EVT_NLO_SEPARATE_REAL else evt%mode = EVT_NLO_SEPARATE_BORNLIKE end if end if end select end subroutine evt_nlo_set_mode @ %def evt_nlo_set_mode @ <>= procedure :: is_valid_event => evt_nlo_is_valid_event <>= function evt_nlo_is_valid_event (evt, i_term) result (valid) logical :: valid class(evt_nlo_t), intent(in) :: evt integer, intent(in) :: i_term valid = evt%process_instance%term(i_term)%passed end function evt_nlo_is_valid_event @ %def evt_nlo_is_valid_event @ Retrieves the actual quantum numbers chosen in [[evt_nlo_prepare_new_event]]. <>= procedure :: get_selected_quantum_numbers => evt_nlo_get_selected_quantum_numbers <>= function evt_nlo_get_selected_quantum_numbers (evt, i_flv) result (qn_select) class(evt_nlo_t), intent(in) :: evt integer, intent(in) :: i_flv type(quantum_numbers_t), dimension(:), allocatable :: qn_select integer :: i_term, index i_term = evt%get_i_term () associate (term => evt%process_instance%term(i_term)) index = term%connected%matrix%get_qn_index (i_flv, i_sub = 0) qn_select = term%connected%matrix%get_quantum_numbers (index) end associate end function evt_nlo_get_selected_quantum_numbers @ %def evt_nlo_get_selected_quantum_numbers @ Selects a flavor structure for Born subevents, such that each possible flavor structure is as probable as its portion of the sum of Born matrix elements over all flavors. For non-Born Born-like subevents, no Born matrix elements are available. We always choose [[i_flv = 1]] in this case. If all terms are active, i.e. in a full NLO calculation, the flavors of Born-like subevents will be distributed according to the Born matrix elements only, to avoid issues with matrix elements of different sign and assure a LO flavor distribution. Likewise, the real-like event flavors are distributed according to the real matrix elements. Here, we need to make sure to not mix matrix elements from different real terms and instead determine the flavor for each subevent based on just the matrix elements for one of the terms. The implementation below assumes that in the sequence of NLO terms, the Born term is immediately followed by all the real terms which are again followed by the subtraction, the virtual and the DGLAP term. Both flavor structures can be determined without correlation as the flavors will only become important for events to be matched to a parton shower and in this case we will only generate either a single Born-like or a single real-like event which are not part of an event group. In case all subevents failed the cuts, all [[sqme]]s were set to $0$ so we cannot determine the flavor in this way. In this case, we always choose the first flavor structure given by the matrix-element generator with [[i_flv = 1]]. Ideally, having to choose a particle set here would not be necessary as it is also chosen in [[particle_set_init_interaction]] which in the current approach is disabled by supplying [[qn_select]] explicitly based on the flavors chosen here. <>= procedure :: prepare_new_event => evt_nlo_prepare_new_event <>= subroutine evt_nlo_prepare_new_event (evt, i_mci, i_term) class(evt_nlo_t), intent(inout) :: evt integer, intent(in) :: i_mci, i_term real(default) :: s, x real(default) :: sqme_total real(default), dimension(:), allocatable :: sqme_flv integer :: i, i_flv, i_core, emitter, n_in logical, save :: warn_once = .true. class(prc_core_t), pointer :: core => null () call evt%reset () call evt%rng%generate (x) do i = 1, size (evt%process_instance%term) associate (term => evt%process_instance%term(i)) if (evt%i_evaluation == 0) then if (term%nlo_type == BORN) then allocate (sqme_flv (term%config%data%n_flv)) exit end if else if (term%nlo_type == NLO_REAL .and. .not. term%is_subtraction()) then allocate (sqme_flv (term%config%data%n_flv)) exit end if end if end associate end do sqme_total = zero sqme_flv = zero i_core = evt%process%get_i_core (i_term) core => evt%process%get_core_ptr (i_core) do i = 1, size (evt%process_instance%term) associate (term => evt%process_instance%term(i)) if (i == evt%i_evaluation + 1 .and. (term%nlo_type == BORN .or. & (term%nlo_type == NLO_REAL .and. .not. term%is_subtraction())) ) then sqme_total = sqme_total + real (sum ( term%connected%matrix%get_matrix_element ())) !!! TODO (VR 2020-02-19) figure out why this select type is needed for prc_omega_t !!! For NLO and prc_omega_t the connected trace seems to be set up incorrectly! !!! (PS 2020-11-05) This leads to real events of processes with structure functions !!! having a wrong flavor distribution if computed with O'Mega. !!! The flavor distributions are identical with and also without the special case !!! for O'Mega and wrong in both cases. !!! However, this case it is not critical as long as O'Mega does not provide matrix elements !!! exclusive in coupling orders and is thus only rarely used for NLO applications anyways select type (core) class is (prc_external_t) do i_flv = 1, size (sqme_flv) sqme_flv(i_flv) = sqme_flv(i_flv) & + real (term%connected%matrix%get_matrix_element ( & term%connected%matrix%get_qn_index (i_flv, i_sub = 0))) end do class default sqme_flv = sqme_flv & + real (term%connected%matrix%get_matrix_element ()) emitter = evt%process_instance%kin(i)%emitter n_in = evt%process_instance%kin(i)%n_in if (warn_once .and. term%nlo_type == NLO_REAL .and. emitter <= n_in) then warn_once = .false. call msg_warning("evt_nlo_prepare_new_event: fNLO flavor& & distributions with O'Mega are wrong.") end if end select end if end associate end do if (debug2_active (D_TRANSFORMS)) then if (.not. nearly_equal(sqme_total, sum (sqme_flv))) then call msg_warning ("evt_nlo_prepare_new_event: & &sum over flavored sqmes does not match total sqme.") end if end if !!! Need absolute values to take into account negative weights x = x * abs (sqme_total) s = abs (sqme_flv (1)) evt%selected_i_flv = 1 if (s < x) then do i_flv = 2, size (sqme_flv) s = s + abs (sqme_flv (i_flv)) if (s > x) then evt%selected_i_flv = i_flv exit end if end do end if if (debug2_active (D_TRANSFORMS)) then call msg_print_color ("Selected i_flv: ", COL_GREEN) print *, evt%selected_i_flv end if end subroutine evt_nlo_prepare_new_event @ %def evt_nlo_prepare_new_event @ \section{Complete Events} This module combines hard processes with decay chains, shower, and hadronization (not implemented yet) to complete events. It also manages the input and output of event records in various formats. <<[[events.f90]]>>= <> module events <> <> <> use constants, only: one use io_units use format_utils, only: pac_fmt, write_separator use format_defs, only: FMT_12, FMT_19 use numeric_utils use diagnostics use variables use expr_base use model_data use state_matrices, only: FM_IGNORE_HELICITY, & FM_SELECT_HELICITY, FM_FACTOR_HELICITY, FM_CORRELATED_HELICITY use particles use subevt_expr use rng_base use process, only: process_t use instances, only: process_instance_t use pcm, only: pcm_nlo_workspace_t use process_stacks use event_base use event_transforms use decays use evt_nlo <> <> <> <> contains <> end module events @ %def events @ \subsection{Event configuration} The parameters govern the transformation of an event to a particle set. The [[safety_factor]] reduces the acceptance probability for unweighting. If greater than one, excess events become less likely, but the reweighting efficiency also drops. The [[sigma]] and [[n]] values, if nontrivial, allow for reweighting the events according to the requested [[norm_mode]]. Various [[parse_node_t]] objects are taken from the SINDARIN input. They encode expressions that apply to the current event. The workspaces for evaluating those expressions are set up in the [[event_expr_t]] objects. Note that these are really pointers, so the actual nodes are not stored inside the event object. <>= type :: event_config_t logical :: unweighted = .false. integer :: norm_mode = NORM_UNDEFINED integer :: factorization_mode = FM_IGNORE_HELICITY logical :: keep_correlations = .false. logical :: colorize_subevt = .false. real(default) :: sigma = 1 integer :: n = 1 real(default) :: safety_factor = 1 class(expr_factory_t), allocatable :: ef_selection class(expr_factory_t), allocatable :: ef_reweight class(expr_factory_t), allocatable :: ef_analysis contains <> end type event_config_t @ %def event_config_t @ Output. <>= procedure :: write => event_config_write <>= subroutine event_config_write (object, unit, show_expressions) class(event_config_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: show_expressions integer :: u u = given_output_unit (unit) write (u, "(3x,A,L1)") "Unweighted = ", object%unweighted write (u, "(3x,A,A)") "Normalization = ", & char (event_normalization_string (object%norm_mode)) write (u, "(3x,A)", advance="no") "Helicity handling = " select case (object%factorization_mode) case (FM_IGNORE_HELICITY) write (u, "(A)") "drop" case (FM_SELECT_HELICITY) write (u, "(A)") "select" case (FM_FACTOR_HELICITY) write (u, "(A)") "factorize" end select write (u, "(3x,A,L1)") "Keep correlations = ", object%keep_correlations if (object%colorize_subevt) then write (u, "(3x,A,L1)") "Colorize subevent = ", object%colorize_subevt end if if (.not. nearly_equal (object%safety_factor, one)) then write (u, "(3x,A," // FMT_12 // ")") & "Safety factor = ", object%safety_factor end if if (present (show_expressions)) then if (show_expressions) then if (allocated (object%ef_selection)) then call write_separator (u) write (u, "(3x,A)") "Event selection expression:" call object%ef_selection%write (u) end if if (allocated (object%ef_reweight)) then call write_separator (u) write (u, "(3x,A)") "Event reweighting expression:" call object%ef_reweight%write (u) end if if (allocated (object%ef_analysis)) then call write_separator (u) write (u, "(3x,A)") "Analysis expression:" call object%ef_analysis%write (u) end if end if end if end subroutine event_config_write @ %def event_config_write @ \subsection{The event type} This is the concrete implementation of the [[generic_event_t]] core that is defined above in the [[event_base]] module. The core manages the main (dressed) particle set pointer and the current values for weights and sqme. The implementation adds configuration data, expressions, process references, and event transforms. Each event refers to a single elementary process. This process may be dressed by a shower, a decay chain etc. We maintain pointers to a process instance. A list of event transforms (class [[evt_t]]) transform the connected interactions of the process instance into the final particle set. In this list, the first transform is always the trivial one, which just factorizes the process instance. Subsequent transforms may apply decays, etc. The [[particle_set]] pointer identifies the particle set that we want to be analyzed and returned by the event, usually the last one. Squared matrix element and weight values: when reading events from file, the [[ref]] value is the number in the file, while the [[prc]] value is the number that we calculate from the momenta in the file, possibly with different parameters. When generating events the first time, or if we do not recalculate, the numbers should coincide. Furthermore, the array of [[alt]] values is copied from an array of alternative event records. These values should represent calculated values. The [[sqme]] and [[weight]] values mirror corresponding values in the [[expr]] subobject. The idea is that when generating or reading events, the event record is filled first, then the [[expr]] object acquires copies. These copies are used for writing events and as targets for pointer variables in the analysis expression. All data that involve user-provided expressions (selection, reweighting, analysis) are handled by the [[expr]] subobject. In particular, evaluating the event-selection expression sets the [[passed]] flag. Furthermore, the [[expr]] subobject collects data that can be used in the analysis and should be written to file, including copies of [[sqme]] and [[weight]]. <>= public :: event_t <>= type, extends (generic_event_t) :: event_t type(event_config_t) :: config type(process_t), pointer :: process => null () type(process_instance_t), pointer :: instance => null () class(rng_t), allocatable :: rng integer :: selected_i_mci = 0 integer :: selected_i_term = 0 integer :: selected_channel = 0 logical :: is_complete = .false. class(evt_t), pointer :: transform_first => null () class(evt_t), pointer :: transform_last => null () type(event_expr_t) :: expr logical :: selection_evaluated = .false. logical :: passed = .false. real(default), allocatable :: alpha_qcd_forced real(default), allocatable :: scale_forced real(default) :: reweight = 1 logical :: analysis_flag = .false. integer :: i_event = 0 contains <> end type event_t @ %def event_t @ <>= procedure :: clone => event_clone <>= subroutine event_clone (event, event_new) class(event_t), intent(in), target :: event class(event_t), intent(out), target:: event_new type(string_t) :: id integer :: num_id event_new%config = event%config event_new%process => event%process event_new%instance => event%instance if (allocated (event%rng)) & allocate(event_new%rng, source=event%rng) event_new%selected_i_mci = event%selected_i_mci event_new%selected_i_term = event%selected_i_term event_new%selected_channel = event%selected_channel event_new%is_complete = event%is_complete event_new%transform_first => event%transform_first event_new%transform_last => event%transform_last event_new%selection_evaluated = event%selection_evaluated event_new%passed = event%passed if (allocated (event%alpha_qcd_forced)) & allocate(event_new%alpha_qcd_forced, source=event%alpha_qcd_forced) if (allocated (event%scale_forced)) & allocate(event_new%scale_forced, source=event%scale_forced) event_new%reweight = event%reweight event_new%analysis_flag = event%analysis_flag event_new%i_event = event%i_event id = event_new%process%get_id () if (id /= "") call event_new%expr%set_process_id (id) num_id = event_new%process%get_num_id () if (num_id /= 0) call event_new%expr%set_process_num_id (num_id) call event_new%expr%setup_vars (event_new%process%get_sqrts ()) call event_new%expr%link_var_list (event_new%process%get_var_list_ptr ()) end subroutine event_clone @ %def event_clone @ Finalizer: the list of event transforms is deleted iteratively. <>= procedure :: final => event_final <>= subroutine event_final (object) class(event_t), intent(inout) :: object class(evt_t), pointer :: evt if (allocated (object%rng)) call object%rng%final () call object%expr%final () do while (associated (object%transform_first)) evt => object%transform_first object%transform_first => evt%next call evt%final () deallocate (evt) end do end subroutine event_final @ %def event_final @ Output. The event index is written in the header, it should coincide with the [[event_index]] variable that can be used in selection and analysis. Particle set: this is a pointer to one of the event transforms, so it should suffice to print the latter. <>= procedure :: write => event_write <>= subroutine event_write (object, unit, show_process, show_transforms, & show_decay, verbose, testflag) class(event_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: show_process, show_transforms, show_decay logical, intent(in), optional :: verbose logical, intent(in), optional :: testflag logical :: prc, trans, dec, verb class(evt_t), pointer :: evt character(len=7) :: fmt integer :: u, i call pac_fmt (fmt, FMT_19, FMT_12, testflag) u = given_output_unit (unit) prc = .true.; if (present (show_process)) prc = show_process trans = .true.; if (present (show_transforms)) trans = show_transforms dec = .true.; if (present (show_decay)) dec = show_decay verb = .false.; if (present (verbose)) verb = verbose call write_separator (u, 2) write (u, "(1x,A)", advance="no") "Event" if (object%has_index ()) then write (u, "(1x,'#',I0)", advance="no") object%get_index () end if if (object%is_complete) then write (u, *) else write (u, "(1x,A)") "[incomplete]" end if call write_separator (u) call object%config%write (u) if (object%sqme_ref_is_known () .or. object%weight_ref_is_known ()) then call write_separator (u) end if if (object%sqme_ref_is_known ()) then write (u, "(3x,A," // fmt // ")") & "Squared matrix el. (ref) = ", object%get_sqme_ref () if (object%sqme_alt_is_known ()) then do i = 1, object%get_n_alt () write (u, "(5x,A," // fmt // ",1x,I0)") & "alternate sqme = ", object%get_sqme_alt(i), i end do end if end if if (object%sqme_prc_is_known ()) & write (u, "(3x,A," // fmt // ")") & "Squared matrix el. (prc) = ", object%get_sqme_prc () if (object%weight_ref_is_known ()) then write (u, "(3x,A," // fmt // ")") & "Event weight (ref) = ", object%get_weight_ref () if (object%weight_alt_is_known ()) then do i = 1, object%get_n_alt () write (u, "(5x,A," // fmt // ",1x,I0)") & "alternate weight = ", object%get_weight_alt(i), i end do end if end if if (object%weight_prc_is_known ()) & write (u, "(3x,A," // fmt // ")") & "Event weight (prc) = ", object%get_weight_prc () if (object%selected_i_mci /= 0) then call write_separator (u) write (u, "(3x,A,I0)") "Selected MCI group = ", object%selected_i_mci write (u, "(3x,A,I0)") "Selected term = ", object%selected_i_term write (u, "(3x,A,I0)") "Selected channel = ", object%selected_channel end if if (object%selection_evaluated) then call write_separator (u) write (u, "(3x,A,L1)") "Passed selection = ", object%passed if (object%passed) then write (u, "(3x,A," // fmt // ")") & "Reweighting factor = ", object%reweight write (u, "(3x,A,L1)") & "Analysis flag = ", object%analysis_flag end if end if if (associated (object%instance)) then if (prc) then if (verb) then call object%instance%write (u, testflag) else call object%instance%write_header (u) end if end if if (trans) then evt => object%transform_first do while (associated (evt)) select type (evt) type is (evt_decay_t) call evt%write (u, verbose = dec, more_verbose = verb, & testflag = testflag) class default call evt%write (u, verbose = verb, testflag = testflag) end select call write_separator (u, 2) evt => evt%next end do else call write_separator (u, 2) end if if (object%expr%subevt_filled) then call object%expr%write (u, pacified = testflag) call write_separator (u, 2) end if else call write_separator (u, 2) write (u, "(1x,A)") "Process instance: [undefined]" call write_separator (u, 2) end if end subroutine event_write @ %def event_write @ \subsection{Initialization} Initialize: set configuration parameters, using a variable list. We do not call this [[init]], because this method name will be used by a type extension. The default normalization is [[NORM_SIGMA]], since the default generation mode is weighted. For unweighted events, we may want to a apply a safety factor to event rejection. (By default, this factor is unity and can be ignored.) We also allocate the trivial event transform, which is always the first one. <>= procedure :: basic_init => event_init <>= subroutine event_init (event, var_list, n_alt) class(event_t), intent(out) :: event type(var_list_t), intent(in), optional :: var_list integer, intent(in), optional :: n_alt type(string_t) :: norm_string, mode_string logical :: polarized_events if (present (n_alt)) then call event%base_init (n_alt) call event%expr%init (n_alt) else call event%base_init (0) end if if (present (var_list)) then event%config%unweighted = var_list%get_lval (& var_str ("?unweighted")) norm_string = var_list%get_sval (& var_str ("$sample_normalization")) event%config%norm_mode = & event_normalization_mode (norm_string, event%config%unweighted) polarized_events = & var_list%get_lval (var_str ("?polarized_events")) if (polarized_events) then mode_string = & var_list%get_sval (var_str ("$polarization_mode")) select case (char (mode_string)) case ("ignore") event%config%factorization_mode = FM_IGNORE_HELICITY case ("helicity") event%config%factorization_mode = FM_SELECT_HELICITY case ("factorized") event%config%factorization_mode = FM_FACTOR_HELICITY case ("correlated") event%config%factorization_mode = FM_CORRELATED_HELICITY case default call msg_fatal ("Polarization mode " & // char (mode_string) // " is undefined") end select else event%config%factorization_mode = FM_IGNORE_HELICITY end if event%config%colorize_subevt = & var_list%get_lval (var_str ("?colorize_subevt")) if (event%config%unweighted) then event%config%safety_factor = var_list%get_rval (& var_str ("safety_factor")) end if else event%config%norm_mode = NORM_SIGMA end if allocate (evt_trivial_t :: event%transform_first) event%transform_last => event%transform_first end subroutine event_init @ %def event_init @ Set the [[sigma]] and [[n]] values in the configuration record that determine non-standard event normalizations. If these numbers are not set explicitly, the default value for both is unity, and event renormalization has no effect. <>= procedure :: set_sigma => event_set_sigma procedure :: set_n => event_set_n <>= elemental subroutine event_set_sigma (event, sigma) class(event_t), intent(inout) :: event real(default), intent(in) :: sigma event%config%sigma = sigma end subroutine event_set_sigma elemental subroutine event_set_n (event, n) class(event_t), intent(inout) :: event integer, intent(in) :: n event%config%n = n end subroutine event_set_n @ %def event_set_n @ Append an event transform (decays, etc.). The transform is not yet connected to a process. The transform is then considered to belong to the event object, and will be finalized together with it. The original pointer is removed. We can assume that the trivial transform is already present in the event object, at least. <>= procedure :: import_transform => event_import_transform <>= subroutine event_import_transform (event, evt) class(event_t), intent(inout) :: event class(evt_t), intent(inout), pointer :: evt event%transform_last%next => evt evt%previous => event%transform_last event%transform_last => evt evt => null () end subroutine event_import_transform @ %def event_import_transform @ We link the event to an existing process instance. This includes the variable list, which is linked to the process variable list. Note that this is not necessarily identical to the variable list used for event initialization. The variable list will contain pointers to [[event]] subobjects, therefore the [[target]] attribute. Once we have a process connected, we can use it to obtain an event generator instance. The model and process stack may be needed by event transforms. The current model setting may be different from the model in the process (regarding unstable particles, etc.). The process stack can be used for assigning extra processes that we need for the event transforms. <>= procedure :: connect => event_connect <>= subroutine event_connect (event, process_instance, model, process_stack) class(event_t), intent(inout), target :: event type(process_instance_t), intent(in), target :: process_instance class(model_data_t), intent(in), target :: model type(process_stack_t), intent(in), optional :: process_stack type(string_t) :: id integer :: num_id class(evt_t), pointer :: evt event%process => process_instance%process event%instance => process_instance id = event%process%get_id () if (id /= "") call event%expr%set_process_id (id) num_id = event%process%get_num_id () if (num_id /= 0) call event%expr%set_process_num_id (num_id) call event%expr%setup_vars (event%process%get_sqrts ()) call event%expr%link_var_list (event%process%get_var_list_ptr ()) call event%process%make_rng (event%rng) evt => event%transform_first do while (associated (evt)) call evt%connect (process_instance, model, process_stack) evt => evt%next end do end subroutine event_connect @ %def event_connect @ Set the parse nodes for the associated expressions, individually. The parse-node pointers may be null. <>= procedure :: set_selection => event_set_selection procedure :: set_reweight => event_set_reweight procedure :: set_analysis => event_set_analysis <>= subroutine event_set_selection (event, ef_selection) class(event_t), intent(inout) :: event class(expr_factory_t), intent(in) :: ef_selection allocate (event%config%ef_selection, source = ef_selection) end subroutine event_set_selection subroutine event_set_reweight (event, ef_reweight) class(event_t), intent(inout) :: event class(expr_factory_t), intent(in) :: ef_reweight allocate (event%config%ef_reweight, source = ef_reweight) end subroutine event_set_reweight subroutine event_set_analysis (event, ef_analysis) class(event_t), intent(inout) :: event class(expr_factory_t), intent(in) :: ef_analysis allocate (event%config%ef_analysis, source = ef_analysis) end subroutine event_set_analysis @ %def event_set_selection @ %def event_set_reweight @ %def event_set_analysis @ Create evaluation trees from the parse trees. The [[target]] attribute is required because the expressions contain pointers to event subobjects. <>= procedure :: setup_expressions => event_setup_expressions <>= subroutine event_setup_expressions (event) class(event_t), intent(inout), target :: event call event%expr%setup_selection (event%config%ef_selection) call event%expr%setup_analysis (event%config%ef_analysis) call event%expr%setup_reweight (event%config%ef_reweight) call event%expr%colorize (event%config%colorize_subevt) end subroutine event_setup_expressions @ %def event_setup_expressions @ \subsection{Evaluation} To fill the [[particle_set]], i.e., the event record proper, we have to apply all event transforms in order. The last transform should fill its associated particle set, factorizing the state matrix according to the current settings. There are several parameters in the event configuration that control this. We always fill the particle set for the first transform (the hard process) and the last transform, if different from the first (the fully dressed process). Each event transform is an event generator of its own. We choose to generate an \emph{unweighted} event for each of them, even if the master event is assumed to be weighted. Thus, the overall event weight is the one of the hard process only. (There may be more options in future extensions.) We can generate the two random numbers that the factorization needs. For testing purpose, we allow for providing them explicitly, as an option. <>= procedure :: evaluate_transforms => event_evaluate_transforms <>= subroutine event_evaluate_transforms (event, r) class(event_t), intent(inout) :: event real(default), dimension(:), intent(in), optional :: r class(evt_t), pointer :: evt real(default) :: weight_over_sqme integer :: i_term, emitter, n_in logical :: failed_but_keep failed_but_keep = .false. if (debug_on) call msg_debug (D_TRANSFORMS, "event_evaluate_transforms") call event%discard_particle_set () call event%check () if (event%instance%is_complete_event ()) then i_term = event%instance%select_i_term () event%selected_i_term = i_term evt => event%transform_first do while (associated (evt)) call evt%prepare_new_event & (event%selected_i_mci, event%selected_i_term) evt => evt%next end do if (debug_on) call msg_debug & (D_TRANSFORMS, "Before event transformations") if (debug_on) call msg_debug & (D_TRANSFORMS, "event%weight_prc", event%weight_prc) if (debug_on) call msg_debug & (D_TRANSFORMS, "event%sqme_prc", event%sqme_prc) evt => event%transform_first do while (associated (evt)) call print_transform_name_if_debug () if (evt%only_weighted_events) then select type (evt) type is (evt_nlo_t) i_term = evt%get_i_term () failed_but_keep = .not. evt%is_valid_event (i_term) & .and. evt%keep_failed_events if (.not. any(evt%process_instance%term%passed .and. evt%process_instance%term%active) & .and. .not. evt%keep_failed_events) return end select if (abs (event%weight_prc) > 0._default) then weight_over_sqme = event%weight_prc / event%sqme_prc call evt%generate_weighted (event%sqme_prc) event%weight_prc = weight_over_sqme * event%sqme_prc select type (evt) type is (evt_nlo_t) if (.not. evt%is_valid_event (i_term)) event%weight_prc = 0 end select else if (.not. failed_but_keep) exit end if else call evt%generate_unweighted () end if if (signal_is_pending ()) return select type (evt) type is (evt_nlo_t) if (evt%i_evaluation > 0) then emitter = evt%process_instance%kin(i_term)%emitter n_in = evt%process_instance%kin(i_term)%n_in if (emitter <= n_in) then call evt%connected_set_real_IS_momenta () end if end if end select call evt%make_particle_set (event%config%factorization_mode, & event%config%keep_correlations) if (signal_is_pending ()) return if (.not. evt%particle_set_exists) exit evt => evt%next end do evt => event%transform_last if ((associated (evt) .and. evt%particle_set_exists) .or. failed_but_keep) then if (event%is_nlo ()) then select type (evt) type is (evt_nlo_t) evt%particle_set_nlo (event%i_event + 1) = evt%particle_set evt%i_evaluation = evt%i_evaluation + 1 call event%link_particle_set & (evt%particle_set_nlo(event%i_event + 1)) end select else call event%link_particle_set (evt%particle_set) end if end if if (debug_on) call msg_debug & (D_TRANSFORMS, "After event transformations") if (debug_on) call msg_debug & (D_TRANSFORMS, "event%weight_prc", event%weight_prc) if (debug_on) call msg_debug & (D_TRANSFORMS, "event%sqme_prc", event%sqme_prc) if (debug_on) call msg_debug & (D_TRANSFORMS, "evt%particle_set_exists", evt%particle_set_exists) end if contains subroutine print_transform_name_if_debug () if (debug_active (D_TRANSFORMS)) then print *, 'Current event transform: ' call evt%write_name () end if end subroutine print_transform_name_if_debug end subroutine event_evaluate_transforms @ %def event_evaluate_transforms @ Set / increment the event index for the current event. There is no condition for this to happen. The event index is actually stored in the subevent expression, because this allows us to access it in subevent expressions as a variable. <>= procedure :: set_index => event_set_index procedure :: increment_index => event_increment_index <>= subroutine event_set_index (event, index) class(event_t), intent(inout) :: event integer, intent(in) :: index call event%expr%set_event_index (index) end subroutine event_set_index subroutine event_increment_index (event, offset) class(event_t), intent(inout) :: event integer, intent(in), optional :: offset call event%expr%increment_event_index (offset) end subroutine event_increment_index @ %def event_set_index @ %def event_increment_index @ Evaluate the event-related expressions, given a valid [[particle_set]]. If [[update_sqme]] is set, we use the process instance for the [[sqme_prc]] value. The [[sqme_ref]] value is always taken from the event record. <>= procedure :: evaluate_expressions => event_evaluate_expressions <>= subroutine event_evaluate_expressions (event) class(event_t), intent(inout) :: event if (event%has_valid_particle_set ()) then call event%expr%fill_subevt (event%get_particle_set_ptr ()) end if if (event%weight_ref_is_known ()) then call event%expr%set (weight_ref = event%get_weight_ref ()) end if if (event%weight_prc_is_known ()) then call event%expr%set (weight_prc = event%get_weight_prc ()) end if if (event%excess_prc_is_known ()) then call event%expr%set (excess_prc = event%get_excess_prc ()) end if if (event%sqme_ref_is_known ()) then call event%expr%set (sqme_ref = event%get_sqme_ref ()) end if if (event%sqme_prc_is_known ()) then call event%expr%set (sqme_prc = event%get_sqme_prc ()) end if if (event%has_valid_particle_set ()) then call event%expr%evaluate & (event%passed, event%reweight, event%analysis_flag) event%selection_evaluated = .true. end if end subroutine event_evaluate_expressions @ %def event_evaluate_expressions @ Report the result of the [[selection]] evaluation. <>= procedure :: passed_selection => event_passed_selection <>= function event_passed_selection (event) result (flag) class(event_t), intent(in) :: event logical :: flag flag = event%passed end function event_passed_selection @ %def event_passed_selection @ Set alternate sqme and weight arrays. This should be merged with the previous routine, if the expressions are allowed to refer to these values. <>= procedure :: store_alt_values => event_store_alt_values <>= subroutine event_store_alt_values (event) class(event_t), intent(inout) :: event if (event%weight_alt_is_known ()) then call event%expr%set (weight_alt = event%get_weight_alt ()) end if if (event%sqme_alt_is_known ()) then call event%expr%set (sqme_alt = event%get_sqme_alt ()) end if end subroutine event_store_alt_values @ %def event_store_alt_values @ <>= procedure :: is_nlo => event_is_nlo <>= function event_is_nlo (event) result (is_nlo) logical :: is_nlo class(event_t), intent(in) :: event if (associated (event%instance)) then select type (pcm_work => event%instance%pcm_work) type is (pcm_nlo_workspace_t) is_nlo = pcm_work%is_fixed_order_nlo_events () class default is_nlo = .false. end select else is_nlo = .false. end if end function event_is_nlo @ %def event_is_nlo @ \subsection{Reset to empty state} Applying this, current event contents are marked as incomplete but are not deleted. In particular, the initialization is kept. The event index is also kept, this can be reset separately. <>= procedure :: reset_contents => event_reset_contents procedure :: reset_index => event_reset_index <>= subroutine event_reset_contents (event) class(event_t), intent(inout) :: event class(evt_t), pointer :: evt call event%base_reset_contents () event%selected_i_mci = 0 event%selected_i_term = 0 event%selected_channel = 0 event%is_complete = .false. call event%expr%reset_contents () event%selection_evaluated = .false. event%passed = .false. event%analysis_flag = .false. if (associated (event%instance)) then call event%instance%reset (reset_mci = .true.) end if if (allocated (event%alpha_qcd_forced)) deallocate (event%alpha_qcd_forced) if (allocated (event%scale_forced)) deallocate (event%scale_forced) evt => event%transform_first do while (associated (evt)) call evt%reset () evt => evt%next end do end subroutine event_reset_contents subroutine event_reset_index (event) class(event_t), intent(inout) :: event call event%expr%reset_event_index () end subroutine event_reset_index @ %def event_reset_contents @ %def event_reset_index @ \subsection{Squared Matrix Element and Weight} Transfer the result of the process instance calculation to the event record header. <>= procedure :: import_instance_results => event_import_instance_results <>= subroutine event_import_instance_results (event) class(event_t), intent(inout) :: event if (associated (event%instance)) then if (event%instance%has_evaluated_trace ()) then call event%set ( & sqme_prc = event%instance%get_sqme (), & weight_prc = event%instance%get_weight (), & excess_prc = event%instance%get_excess (), & n_dropped = event%instance%get_n_dropped () & ) end if end if end subroutine event_import_instance_results @ %def event_import_instance_results @ Duplicate the instance result / the reference result in the event record. <>= procedure :: accept_sqme_ref => event_accept_sqme_ref procedure :: accept_sqme_prc => event_accept_sqme_prc procedure :: accept_weight_ref => event_accept_weight_ref procedure :: accept_weight_prc => event_accept_weight_prc <>= subroutine event_accept_sqme_ref (event) class(event_t), intent(inout) :: event if (event%sqme_ref_is_known ()) then call event%set (sqme_prc = event%get_sqme_ref ()) end if end subroutine event_accept_sqme_ref subroutine event_accept_sqme_prc (event) class(event_t), intent(inout) :: event if (event%sqme_prc_is_known ()) then call event%set (sqme_ref = event%get_sqme_prc ()) end if end subroutine event_accept_sqme_prc subroutine event_accept_weight_ref (event) class(event_t), intent(inout) :: event if (event%weight_ref_is_known ()) then call event%set (weight_prc = event%get_weight_ref ()) end if end subroutine event_accept_weight_ref subroutine event_accept_weight_prc (event) class(event_t), intent(inout) :: event if (event%weight_prc_is_known ()) then call event%set (weight_ref = event%get_weight_prc ()) end if end subroutine event_accept_weight_prc @ %def event_accept_sqme_ref @ %def event_accept_sqme_prc @ %def event_accept_weight_ref @ %def event_accept_weight_prc @ Update the weight normalization, just after generation. Unweighted and weighted events are generated with a different default normalization. The intended normalization is stored in the configuration record. <>= procedure :: update_normalization => event_update_normalization <>= subroutine event_update_normalization (event, mode_ref) class(event_t), intent(inout) :: event integer, intent(in), optional :: mode_ref integer :: mode_old real(default) :: weight, excess if (present (mode_ref)) then mode_old = mode_ref else if (event%config%unweighted) then mode_old = NORM_UNIT else mode_old = NORM_SIGMA end if weight = event%get_weight_prc () call event_normalization_update (weight, & event%config%sigma, event%config%n, & mode_new = event%config%norm_mode, & mode_old = mode_old) call event%set_weight_prc (weight) excess = event%get_excess_prc () call event_normalization_update (excess, & event%config%sigma, event%config%n, & mode_new = event%config%norm_mode, & mode_old = mode_old) call event%set_excess_prc (excess) end subroutine event_update_normalization @ %def event_update_normalization @ The event is complete if it has a particle set plus valid entries for the sqme and weight values. <>= procedure :: check => event_check <>= subroutine event_check (event) class(event_t), intent(inout) :: event event%is_complete = event%has_valid_particle_set () & .and. event%sqme_ref_is_known () & .and. event%sqme_prc_is_known () & .and. event%weight_ref_is_known () & .and. event%weight_prc_is_known () if (event%get_n_alt () /= 0) then event%is_complete = event%is_complete & .and. event%sqme_alt_is_known () & .and. event%weight_alt_is_known () end if end subroutine event_check @ %def event_check @ @ \subsection{Generation} Assuming that we have a valid process associated to the event, we generate an event. We complete the event data, then factorize the spin density matrix and transfer it to the particle set. When done, we retrieve squared matrix element and weight. In case of explicit generation, the reference values coincide with the process values, so we [[accept]] the latter. The explicit random number argument [[r]] should be generated by a random-number generator. It is taken for the factorization algorithm, bypassing the event-specific random-number generator. This is useful for deterministic testing. <>= procedure :: generate => event_generate <>= subroutine event_generate (event, i_mci, r, i_nlo) class(event_t), intent(inout) :: event integer, intent(in) :: i_mci real(default), dimension(:), intent(in), optional :: r integer, intent(in), optional :: i_nlo logical :: generate_new generate_new = .true. if (present (i_nlo)) generate_new = (i_nlo == 1) if (generate_new) call event%reset_contents () event%selected_i_mci = i_mci if (event%config%unweighted) then call event%instance%generate_unweighted_event (i_mci) if (signal_is_pending ()) return call event%instance%evaluate_event_data () call event%instance%normalize_weight () else if (generate_new) & call event%instance%generate_weighted_event (i_mci) if (signal_is_pending ()) return call event%instance%evaluate_event_data () end if event%selected_channel = event%instance%get_channel () call event%import_instance_results () call event%accept_sqme_prc () call event%update_normalization () call event%accept_weight_prc () call event%evaluate_transforms (r) if (signal_is_pending ()) return call event%check () end subroutine event_generate @ %def event_generate @ Get a copy of the particle set belonging to the hard process. <>= procedure :: get_hard_particle_set => event_get_hard_particle_set <>= subroutine event_get_hard_particle_set (event, pset) class(event_t), intent(in) :: event type(particle_set_t), intent(out) :: pset class(evt_t), pointer :: evt evt => event%transform_first pset = evt%particle_set end subroutine event_get_hard_particle_set @ %def event_get_hard_particle_set @ \subsection{Recovering an event} Select MC group, term, and integration channel. <>= procedure :: select => event_select <>= subroutine event_select (event, i_mci, i_term, channel) class(event_t), intent(inout) :: event integer, intent(in) :: i_mci, i_term, channel if (associated (event%instance)) then event%selected_i_mci = i_mci event%selected_i_term = i_term event%selected_channel = channel else event%selected_i_mci = 0 event%selected_i_term = 0 event%selected_channel = 0 end if end subroutine event_select @ %def event_select @ Copy a particle set into the event record. We deliberately use the first (the trivial) transform for this, i.e., the hard process. The event reader may either read in the transformed event separately, or apply all event transforms to the hard particle set to (re)generate a fully dressed event. Since this makes all subsequent event transforms invalid, we call [[reset]] on them. <>= procedure :: set_hard_particle_set => event_set_hard_particle_set <>= subroutine event_set_hard_particle_set (event, particle_set) class(event_t), intent(inout) :: event type(particle_set_t), intent(in) :: particle_set class(evt_t), pointer :: evt evt => event%transform_first call evt%set_particle_set (particle_set, & event%selected_i_mci, event%selected_i_term) call event%link_particle_set (evt%particle_set) evt => evt%next do while (associated (evt)) call evt%reset () evt => evt%next end do end subroutine event_set_hard_particle_set @ %def event_set_hard_particle_set @ Set the $\alpha_s$ value that should be used in a recalculation. This should be called only if we explicitly want to override the QCD setting of the process core. <>= procedure :: set_alpha_qcd_forced => event_set_alpha_qcd_forced <>= subroutine event_set_alpha_qcd_forced (event, alpha_qcd) class(event_t), intent(inout) :: event real(default), intent(in) :: alpha_qcd if (allocated (event%alpha_qcd_forced)) then event%alpha_qcd_forced = alpha_qcd else allocate (event%alpha_qcd_forced, source = alpha_qcd) end if end subroutine event_set_alpha_qcd_forced @ %def event_set_alpha_qcd_forced @ Analogously, for the common scale. This forces also renormalization and factorization scale. <>= procedure :: set_scale_forced => event_set_scale_forced <>= subroutine event_set_scale_forced (event, scale) class(event_t), intent(inout) :: event real(default), intent(in) :: scale if (allocated (event%scale_forced)) then event%scale_forced = scale else allocate (event%scale_forced, source = scale) end if end subroutine event_set_scale_forced @ %def event_set_scale_forced @ Here we try to recover an event from the [[particle_set]] subobject and recalculate the structure functions and matrix elements. We have the appropriate [[process]] object and an initialized [[process_instance]] at hand, so beam and configuration data are known. From the [[particle_set]], we get the momenta. The quantum-number information may be incomplete, e.g., helicity information may be partial or absent. We recover the event just from the momentum configuration. We do not transfer the matrix element from the process instance to the event record, as we do when generating an event. The event record may contain the matrix element as read from file, and the current calculation may use different parameters. We thus can compare old and new values. The event [[weight]] may also be known already. If yes, we pass it to the [[evaluate_event_data]] procedure. It should already be normalized. If we have a [[weight_factor]] value, we obtain the event weight by multiplying the computed [[sqme]] by this factor. Otherwise, we make use of the MCI setup (which should be valid then) to compute the event weight, and we should normalize the result just as when generating events. Evaluating event expressions must also be done separately. If [[recover_phs]] is set (and false), do not attempt any phase-space calculation, including MCI evaluation. Useful if we need only matrix elements. <>= procedure :: recalculate => event_recalculate <>= subroutine event_recalculate (event, update_sqme, weight_factor, & recover_beams, recover_phs, check_match, success) class(event_t), intent(inout) :: event logical, intent(in) :: update_sqme real(default), intent(in), optional :: weight_factor logical, intent(in), optional :: recover_beams logical, intent(in), optional :: recover_phs logical, intent(in), optional :: check_match logical, intent(out), optional :: success type(particle_set_t), pointer :: particle_set integer :: i_mci, i_term, channel logical :: rec_phs_mci rec_phs_mci = .true.; if (present (recover_phs)) rec_phs_mci = recover_phs if (present (success)) success = .false. if (event%has_valid_particle_set ()) then particle_set => event%get_particle_set_ptr () i_mci = event%selected_i_mci i_term = event%selected_i_term channel = event%selected_channel if (i_mci == 0 .or. i_term == 0 .or. channel == 0) then call msg_bug ("Event: recalculate: undefined selection parameters") end if call event%instance%choose_mci (i_mci) call event%instance%set_trace & (particle_set, i_term, recover_beams, check_match, success) if (present (success)) then if (.not. success) return end if if (allocated (event%alpha_qcd_forced)) then call event%instance%set_alpha_qcd_forced & (i_term, event%alpha_qcd_forced) end if call event%instance%recover (channel, i_term, & update_sqme, rec_phs_mci, event%scale_forced) if (signal_is_pending ()) return if (update_sqme .and. present (weight_factor)) then call event%instance%evaluate_event_data & (weight = event%instance%get_sqme () * weight_factor) else if (event%weight_ref_is_known ()) then call event%instance%evaluate_event_data & (weight = event%get_weight_ref ()) else if (rec_phs_mci) then call event%instance%recover_event () if (signal_is_pending ()) return call event%instance%evaluate_event_data () if (event%config%unweighted) then call event%instance%normalize_weight () end if end if if (signal_is_pending ()) return if (update_sqme) then call event%import_instance_results () else call event%accept_sqme_ref () call event%accept_weight_ref () end if else call msg_bug ("Event: can't recalculate, particle set is undefined") end if end subroutine event_recalculate @ %def event_recalculate @ \subsection{Access content} Pointer to the associated process object (the associated model). <>= procedure :: get_process_ptr => event_get_process_ptr procedure :: get_process_instance_ptr => event_get_process_instance_ptr procedure :: get_model_ptr => event_get_model_ptr <>= function event_get_process_ptr (event) result (ptr) class(event_t), intent(in) :: event type(process_t), pointer :: ptr ptr => event%process end function event_get_process_ptr function event_get_process_instance_ptr (event) result (ptr) class(event_t), intent(in) :: event type(process_instance_t), pointer :: ptr ptr => event%instance end function event_get_process_instance_ptr function event_get_model_ptr (event) result (model) class(event_t), intent(in) :: event class(model_data_t), pointer :: model if (associated (event%process)) then model => event%process%get_model_ptr () else model => null () end if end function event_get_model_ptr @ %def event_get_process_ptr @ %def event_get_process_instance_ptr @ %def event_get_model_ptr @ Return the current values of indices: the MCI group of components, the term index (different terms corresponding, potentially, to different effective kinematics), and the MC integration channel. The [[i_mci]] call is delegated to the current process instance. <>= procedure :: get_i_mci => event_get_i_mci procedure :: get_i_term => event_get_i_term procedure :: get_channel => event_get_channel <>= function event_get_i_mci (event) result (i_mci) class(event_t), intent(in) :: event integer :: i_mci i_mci = event%selected_i_mci end function event_get_i_mci function event_get_i_term (event) result (i_term) class(event_t), intent(in) :: event integer :: i_term i_term = event%selected_i_term end function event_get_i_term function event_get_channel (event) result (channel) class(event_t), intent(in) :: event integer :: channel channel = event%selected_channel end function event_get_channel @ %def event_get_i_mci @ %def event_get_i_term @ %def event_get_channel @ This flag tells us whether the event consists just of a hard process (i.e., holds at most the first, trivial transform), or is a dressed events with additional transforms. <>= procedure :: has_transform => event_has_transform <>= function event_has_transform (event) result (flag) class(event_t), intent(in) :: event logical :: flag if (associated (event%transform_first)) then flag = associated (event%transform_first%next) else flag = .false. end if end function event_has_transform @ %def event_has_transform @ Return the currently selected normalization mode, or alternate normalization mode. <>= procedure :: get_norm_mode => event_get_norm_mode <>= elemental function event_get_norm_mode (event) result (norm_mode) class(event_t), intent(in) :: event integer :: norm_mode norm_mode = event%config%norm_mode end function event_get_norm_mode @ %def event_get_norm_mode @ Return the kinematical weight, defined as the ratio of event weight and squared matrix element. <>= procedure :: get_kinematical_weight => event_get_kinematical_weight <>= function event_get_kinematical_weight (event) result (f) class(event_t), intent(in) :: event real(default) :: f if (event%sqme_ref_is_known () .and. event%weight_ref_is_known () & .and. abs (event%get_sqme_ref ()) > 0) then f = event%get_weight_ref () / event%get_sqme_ref () else f = 0 end if end function event_get_kinematical_weight @ %def event_get_kinematical_weight @ Return data used by external event formats. <>= procedure :: has_index => event_has_index procedure :: get_index => event_get_index procedure :: get_fac_scale => event_get_fac_scale procedure :: get_alpha_s => event_get_alpha_s procedure :: get_sqrts => event_get_sqrts procedure :: get_polarization => event_get_polarization procedure :: get_beam_file => event_get_beam_file procedure :: get_process_name => event_get_process_name <>= function event_has_index (event) result (flag) class(event_t), intent(in) :: event logical :: flag flag = event%expr%has_event_index () end function event_has_index function event_get_index (event) result (index) class(event_t), intent(in) :: event integer :: index index = event%expr%get_event_index () end function event_get_index function event_get_fac_scale (event) result (fac_scale) class(event_t), intent(in) :: event real(default) :: fac_scale fac_scale = event%instance%get_fac_scale (event%selected_i_term) end function event_get_fac_scale function event_get_alpha_s (event) result (alpha_s) class(event_t), intent(in) :: event real(default) :: alpha_s alpha_s = event%instance%get_alpha_s (event%selected_i_term) end function event_get_alpha_s function event_get_sqrts (event) result (sqrts) class(event_t), intent(in) :: event real(default) :: sqrts sqrts = event%instance%get_sqrts () end function event_get_sqrts function event_get_polarization (event) result (pol) class(event_t), intent(in) :: event real(default), dimension(:), allocatable :: pol pol = event%instance%get_polarization () end function event_get_polarization function event_get_beam_file (event) result (file) class(event_t), intent(in) :: event type(string_t) :: file file = event%instance%get_beam_file () end function event_get_beam_file function event_get_process_name (event) result (name) class(event_t), intent(in) :: event type(string_t) :: name name = event%instance%get_process_name () end function event_get_process_name @ %def event_get_index @ %def event_get_fac_scale @ %def event_get_alpha_s @ %def event_get_sqrts @ %def event_get_polarization @ %def event_get_beam_file @ %def event_get_process_name @ Return the actual number of calls, as stored in the process instance. <>= procedure :: get_actual_calls_total => event_get_actual_calls_total <>= elemental function event_get_actual_calls_total (event) result (n) class(event_t), intent(in) :: event integer :: n if (associated (event%instance)) then n = event%instance%get_actual_calls_total () else n = 0 end if end function event_get_actual_calls_total @ %def event_get_actual_calls_total @ Eliminate numerical noise in the [[subevt]] expression and in the event transforms (which includes associated process instances). <>= public :: pacify <>= interface pacify module procedure pacify_event end interface pacify <>= subroutine pacify_event (event) class(event_t), intent(inout) :: event class(evt_t), pointer :: evt call event%pacify_particle_set () if (event%expr%subevt_filled) call pacify (event%expr) evt => event%transform_first do while (associated (evt)) select type (evt) type is (evt_decay_t); call pacify (evt) end select evt => evt%next end do end subroutine pacify_event @ %def pacify @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[events_ut.f90]]>>= <> module events_ut use unit_tests use events_uti <> <> contains <> end module events_ut @ %def events_ut @ <<[[events_uti.f90]]>>= <> module events_uti <> <> use os_interface use model_data use particles use process_libraries use process_stacks use event_transforms use decays use decays_ut, only: prepare_testbed use process, only: process_t use instances, only: process_instance_t use events <> <> contains <> end module events_uti @ %def events_uti @ API: driver for the unit tests below. <>= public :: events_test <>= subroutine events_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine events_test @ %def events_test @ \subsubsection{Empty event record} <>= call test (events_1, "events_1", & "empty event record", & u, results) <>= public :: events_1 <>= subroutine events_1 (u) integer, intent(in) :: u type(event_t), target :: event write (u, "(A)") "* Test output: events_1" write (u, "(A)") "* Purpose: display an empty event object" write (u, "(A)") call event%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: events_1" end subroutine events_1 @ %def events_1 @ \subsubsection{Simple event} <>= call test (events_2, "events_2", & "generate event", & u, results) <>= public :: events_2 <>= subroutine events_2 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(model_data_t), target :: model write (u, "(A)") "* Test output: events_2" write (u, "(A)") "* Purpose: generate and display an event" write (u, "(A)") call model%init_test () write (u, "(A)") "* Generate test process event" allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model) call process_instance%setup_event_data () write (u, "(A)") write (u, "(A)") "* Initialize event object" allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) write (u, "(A)") write (u, "(A)") "* Generate test process event" call process_instance%generate_weighted_event (1) write (u, "(A)") write (u, "(A)") "* Fill event object" write (u, "(A)") call event%generate (1, [0.4_default, 0.4_default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call event%final () deallocate (event) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: events_2" end subroutine events_2 @ %def events_2 @ \subsubsection{Recovering an event} Generate an event and store the particle set. Then reset the event record, recall the particle set, and recover the event from that. <>= call test (events_4, "events_4", & "recover event", & u, results) <>= public :: events_4 <>= subroutine events_4 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(process_t), allocatable, target :: process2 type(process_instance_t), allocatable, target :: process2_instance type(particle_set_t) :: particle_set type(model_data_t), target :: model write (u, "(A)") "* Test output: events_4" write (u, "(A)") "* Purpose: generate and recover an event" write (u, "(A)") call model%init_test () write (u, "(A)") "* Generate test process event and save particle set" write (u, "(A)") allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call event%generate (1, [0.4_default, 0.4_default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) particle_set = event%get_particle_set_ptr () ! NB: 'particle_set' contains pointers to the model within 'process' call event%final () deallocate (event) write (u, "(A)") write (u, "(A)") "* Recover event from particle set" write (u, "(A)") allocate (process2) allocate (process2_instance) call prepare_test_process (process2, process2_instance, model) call process2_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process2_instance, process2%get_model_ptr ()) call event%select (1, 1, 1) call event%set_hard_particle_set (particle_set) call event%recalculate (update_sqme = .true.) call event%write (u) write (u, "(A)") write (u, "(A)") "* Transfer sqme and evaluate expressions" write (u, "(A)") call event%accept_sqme_prc () call event%accept_weight_prc () call event%check () call event%set_index (1) call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Reset contents" write (u, "(A)") call event%reset_contents () call event%reset_index () event%transform_first%particle_set_exists = .false. call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call particle_set%final () call event%final () deallocate (event) call cleanup_test_process (process2, process2_instance) deallocate (process2_instance) deallocate (process2) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: events_4" end subroutine events_4 @ %def events_4 @ \subsubsection{Partially Recovering an event} Generate an event and store the particle set. Then reset the event record, recall the particle set, and recover the event as far as possible without recomputing the squared matrix element. <>= call test (events_5, "events_5", & "partially recover event", & u, results) <>= public :: events_5 <>= subroutine events_5 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(process_t), allocatable, target :: process2 type(process_instance_t), allocatable, target :: process2_instance type(particle_set_t) :: particle_set real(default) :: sqme, weight type(model_data_t), target :: model write (u, "(A)") "* Test output: events_5" write (u, "(A)") "* Purpose: generate and recover an event" write (u, "(A)") call model%init_test () write (u, "(A)") "* Generate test process event and save particle set" write (u, "(A)") allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call event%generate (1, [0.4_default, 0.4_default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) particle_set = event%get_particle_set_ptr () sqme = event%get_sqme_ref () weight = event%get_weight_ref () call event%final () deallocate (event) write (u, "(A)") write (u, "(A)") "* Recover event from particle set" write (u, "(A)") allocate (process2) allocate (process2_instance) call prepare_test_process (process2, process2_instance, model) call process2_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process2_instance, process2%get_model_ptr ()) call event%select (1, 1, 1) call event%set_hard_particle_set (particle_set) call event%recalculate (update_sqme = .false.) call event%write (u) write (u, "(A)") write (u, "(A)") "* Manually set sqme and evaluate expressions" write (u, "(A)") call event%set (sqme_ref = sqme, weight_ref = weight) call event%accept_sqme_ref () call event%accept_weight_ref () call event%set_index (1) call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call particle_set%final () call event%final () deallocate (event) call cleanup_test_process (process2, process2_instance) deallocate (process2_instance) deallocate (process2) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: events_5" end subroutine events_5 @ %def events_5 @ \subsubsection{Decays} Generate an event with subsequent decays. <>= call test (events_6, "events_6", & "decays", & u, results) <>= public :: events_6 <>= subroutine events_6 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(string_t) :: prefix, procname1, procname2 type(process_library_t), target :: lib type(process_stack_t) :: process_stack class(evt_t), pointer :: evt_decay type(event_t), allocatable, target :: event type(process_t), pointer :: process type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: events_6" write (u, "(A)") "* Purpose: generate an event with subsequent decays" write (u, "(A)") write (u, "(A)") "* Generate test process and decay" write (u, "(A)") call os_data%init () prefix = "events_6" procname1 = prefix // "_p" procname2 = prefix // "_d" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.true., decay=.true.) write (u, "(A)") "* Initialize decay process" process => process_stack%get_process_ptr (procname1) model => process%get_model_ptr () call model%set_unstable (25, [procname2]) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () call process_instance%init_simulation (1) write (u, "(A)") write (u, "(A)") "* Initialize event transform: decay" allocate (evt_decay_t :: evt_decay) call evt_decay%connect (process_instance, model, process_stack) write (u, "(A)") write (u, "(A)") "* Initialize event object" write (u, "(A)") allocate (event) call event%basic_init () call event%connect (process_instance, model) call event%import_transform (evt_decay) call event%write (u, show_decay = .true.) write (u, "(A)") write (u, "(A)") "* Generate event" write (u, "(A)") call event%generate (1, [0.4_default, 0.4_default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call event%final () deallocate (event) call process_instance%final () deallocate (process_instance) call process_stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: events_6" end subroutine events_6 @ %def events_6 @ \subsubsection{Decays} Generate a decay event with varying options. <>= call test (events_7, "events_7", & "decay options", & u, results) <>= public :: events_7 <>= subroutine events_7 (u) integer, intent(in) :: u type(os_data_t) :: os_data class(model_data_t), pointer :: model type(string_t) :: prefix, procname2 type(process_library_t), target :: lib type(process_stack_t) :: process_stack type(process_t), pointer :: process type(process_instance_t), allocatable, target :: process_instance write (u, "(A)") "* Test output: events_7" write (u, "(A)") "* Purpose: check decay options" write (u, "(A)") write (u, "(A)") "* Prepare test process" write (u, "(A)") call os_data%init () prefix = "events_7" procname2 = prefix // "_d" call prepare_testbed & (lib, process_stack, prefix, os_data, & scattering=.false., decay=.true.) write (u, "(A)") "* Generate decay event, default options" write (u, "(A)") process => process_stack%get_process_ptr (procname2) model => process%get_model_ptr () call model%set_unstable (25, [procname2]) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data (model) call process_instance%init_simulation (1) call process_instance%generate_weighted_event (1) call process_instance%write (u) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Generate decay event, helicity-diagonal decay" write (u, "(A)") process => process_stack%get_process_ptr (procname2) model => process%get_model_ptr () call model%set_unstable (25, [procname2], diagonal = .true.) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data (model) call process_instance%init_simulation (1) call process_instance%generate_weighted_event (1) call process_instance%write (u) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Generate decay event, isotropic decay, & &polarized final state" write (u, "(A)") process => process_stack%get_process_ptr (procname2) model => process%get_model_ptr () call model%set_unstable (25, [procname2], isotropic = .true.) call model%set_polarized (6) call model%set_polarized (-6) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data (model) call process_instance%init_simulation (1) call process_instance%generate_weighted_event (1) call process_instance%write (u) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Cleanup" call process_stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: events_7" end subroutine events_7 @ %def events_7 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Raw Event I/O} The raw format is for internal use only. All data are stored unformatted, so they can be efficiently be re-read on the same machine, but not necessarily on another machine. This module explicitly depends on the [[events]] module which provides the concrete implementation of [[event_base]]. The other I/O formats access only the methods that are defined in [[event_base]]. <<[[eio_raw.f90]]>>= <> module eio_raw <> <> use io_units use diagnostics use model_data use particles use event_base use event_handles, only: event_handle_t use eio_data use eio_base use events <> <> <> <> contains <> end module eio_raw @ %def eio_raw @ \subsection{File Format Version} This is the current default file version. <>= integer, parameter :: CURRENT_FILE_VERSION = 2 @ %def CURRENT_FILE_VERSION @ The user may change this number; this should force some compatibility mode for reading and writing. In any case, the file version stored in a event file that we read has to match the expected file version. History of version numbers: \begin{enumerate} \item Format for WHIZARD 2.2.0 to 2.2.3. No version number stored in the raw file. \item Format from 2.2.4 on. File contains version number. The file contains the transformed particle set (if applicable) after the hard-process particle set. \end{enumerate} @ \subsection{Type} Note the file version number. The default may be reset during initialization, which should enforce some compatibility mode. <>= public :: eio_raw_t <>= type, extends (eio_t) :: eio_raw_t logical :: reading = .false. logical :: writing = .false. integer :: unit = 0 integer :: norm_mode = NORM_UNDEFINED real(default) :: sigma = 1 integer :: n = 1 integer :: n_alt = 0 logical :: check = .false. logical :: use_alphas_from_file = .false. logical :: use_scale_from_file = .false. logical :: fixed_order_nlo = .false. integer :: file_version = CURRENT_FILE_VERSION contains <> end type eio_raw_t @ %def eio_raw_t @ Output. This is not the actual event format, but a readable account of the current object status. <>= procedure :: write => eio_raw_write <>= subroutine eio_raw_write (object, unit) class(eio_raw_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Raw event stream:" write (u, "(3x,A,L1)") "Check MD5 sum = ", object%check if (object%n_alt > 0) then write (u, "(3x,A,I0)") "Alternate weights = ", object%n_alt end if write (u, "(3x,A,L1)") "Alpha_s from file = ", & object%use_alphas_from_file write (u, "(3x,A,L1)") "Scale from file = ", & object%use_scale_from_file write (u, "(3x,A,L1)") "Events for fNLO = ", & object%fixed_order_nlo if (object%reading) then write (u, "(3x,A,A)") "Reading from file = ", char (object%filename) else if (object%writing) then write (u, "(3x,A,A)") "Writing to file = ", char (object%filename) else write (u, "(3x,A)") "[closed]" end if end subroutine eio_raw_write @ %def eio_raw_write @ Finalizer: close any open file. <>= procedure :: final => eio_raw_final <>= subroutine eio_raw_final (object) class(eio_raw_t), intent(inout) :: object if (object%reading .or. object%writing) then write (msg_buffer, "(A,A,A)") "Events: closing raw file '", & char (object%filename), "'" call msg_message () close (object%unit) object%reading = .false. object%writing = .false. end if end subroutine eio_raw_final @ %def eio_raw_final @ Set the [[check]] flag which determines whether we compare checksums on input. <>= procedure :: set_parameters => eio_raw_set_parameters <>= subroutine eio_raw_set_parameters (eio, check, use_alphas_from_file, & use_scale_from_file, fixed_order_nlo, version_string, extension) class(eio_raw_t), intent(inout) :: eio logical, intent(in), optional :: check, use_alphas_from_file, & use_scale_from_file, fixed_order_nlo type(string_t), intent(in), optional :: version_string type(string_t), intent(in), optional :: extension if (present (check)) eio%check = check if (present (use_alphas_from_file)) eio%use_alphas_from_file = & use_alphas_from_file if (present (use_scale_from_file)) eio%use_scale_from_file = & use_scale_from_file if (present (fixed_order_nlo)) eio%fixed_order_nlo = & fixed_order_nlo if (present (version_string)) then select case (char (version_string)) case ("", "2.2.4") eio%file_version = CURRENT_FILE_VERSION case ("2.2") eio%file_version = 1 case default call msg_fatal ("Raw event I/O: unsupported version '" & // char (version_string) // "'") eio%file_version = 0 end select end if if (present (extension)) then eio%extension = extension else eio%extension = "evx" end if end subroutine eio_raw_set_parameters @ %def eio_raw_set_parameters @ Initialize event writing. <>= procedure :: init_out => eio_raw_init_out <>= subroutine eio_raw_init_out (eio, sample, data, success, extension) class(eio_raw_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success type(string_t), intent(in), optional :: extension character(32) :: md5sum_prc, md5sum_cfg character(32), dimension(:), allocatable :: md5sum_alt integer :: i if (present (extension)) then eio%extension = extension else eio%extension = "evx" end if eio%filename = sample // "." // eio%extension eio%unit = free_unit () write (msg_buffer, "(A,A,A)") "Events: writing to raw file '", & char (eio%filename), "'" call msg_message () eio%writing = .true. if (present (data)) then md5sum_prc = data%md5sum_prc md5sum_cfg = data%md5sum_cfg eio%norm_mode = data%norm_mode eio%sigma = data%total_cross_section eio%n = data%n_evt eio%n_alt = data%n_alt if (eio%n_alt > 0) then !!! !!! !!! Workaround for gfortran 5.0 ICE allocate (md5sum_alt (data%n_alt)) md5sum_alt = data%md5sum_alt !!! allocate (md5sum_alt (data%n_alt), source = data%md5sum_alt) end if else md5sum_prc = "" md5sum_cfg = "" end if open (eio%unit, file = char (eio%filename), form = "unformatted", & action = "write", status = "replace") select case (eio%file_version) case (2:); write (eio%unit) eio%file_version end select write (eio%unit) md5sum_prc write (eio%unit) md5sum_cfg write (eio%unit) eio%norm_mode write (eio%unit) eio%n_alt if (allocated (md5sum_alt)) then do i = 1, eio%n_alt write (eio%unit) md5sum_alt(i) end do end if if (present (success)) success = .true. end subroutine eio_raw_init_out @ %def eio_raw_init_out @ Initialize event reading. <>= procedure :: init_in => eio_raw_init_in <>= subroutine eio_raw_init_in (eio, sample, data, success, extension) class(eio_raw_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success type(string_t), intent(in), optional :: extension character(32) :: md5sum_prc, md5sum_cfg character(32), dimension(:), allocatable :: md5sum_alt integer :: i, file_version if (present (success)) success = .true. if (present (extension)) then eio%extension = extension else eio%extension = "evx" end if eio%filename = sample // "." // eio%extension eio%unit = free_unit () if (present (data)) then eio%sigma = data%total_cross_section eio%n = data%n_evt end if write (msg_buffer, "(A,A,A)") "Events: reading from raw file '", & char (eio%filename), "'" call msg_message () eio%reading = .true. open (eio%unit, file = char (eio%filename), form = "unformatted", & action = "read", status = "old") select case (eio%file_version) case (2:); read (eio%unit) file_version case default; file_version = 1 end select if (file_version /= eio%file_version) then call msg_error ("Reading event file: raw-file version mismatch.") if (present (success)) success = .false. return else if (file_version /= CURRENT_FILE_VERSION) then call msg_warning ("Reading event file: compatibility mode.") end if read (eio%unit) md5sum_prc read (eio%unit) md5sum_cfg read (eio%unit) eio%norm_mode read (eio%unit) eio%n_alt if (present (data)) then if (eio%n_alt /= data%n_alt) then if (present (success)) success = .false. return end if end if allocate (md5sum_alt (eio%n_alt)) do i = 1, eio%n_alt read (eio%unit) md5sum_alt(i) end do if (present (success)) then if (present (data)) then if (eio%check) then if (data%md5sum_prc /= "") then success = success .and. md5sum_prc == data%md5sum_prc end if if (data%md5sum_cfg /= "") then success = success .and. md5sum_cfg == data%md5sum_cfg end if do i = 1, eio%n_alt if (data%md5sum_alt(i) /= "") then success = success .and. md5sum_alt(i) == data%md5sum_alt(i) end if end do else call msg_warning ("Reading event file: MD5 sum check disabled") end if end if end if end subroutine eio_raw_init_in @ %def eio_raw_init_in @ Switch from input to output: reopen the file for reading. <>= procedure :: switch_inout => eio_raw_switch_inout <>= subroutine eio_raw_switch_inout (eio, success) class(eio_raw_t), intent(inout) :: eio logical, intent(out), optional :: success write (msg_buffer, "(A,A,A)") "Events: appending to raw file '", & char (eio%filename), "'" call msg_message () close (eio%unit, status = "keep") eio%reading = .false. open (eio%unit, file = char (eio%filename), form = "unformatted", & action = "write", position = "append", status = "old") eio%writing = .true. if (present (success)) success = .true. end subroutine eio_raw_switch_inout @ %def eio_raw_switch_inout @ Output an event. Write first the event indices, then weight and squared matrix element, then the particle set. We always write the particle set of the hard process. (Note: this should be reconsidered.) We do make a physical copy. On output, we write the [[prc]] values for weight and sqme, since these are the values just computed. On input, we store the values as [[ref]] values. The caller can then decide whether to recompute values and thus obtain distinct [[prc]] values, or just accept them. The [[passed]] flag is not written. This allow us to apply different selection criteria upon rereading. <>= procedure :: output => eio_raw_output <>= subroutine eio_raw_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_raw_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle integer, intent(in) :: i_prc type(particle_set_t), pointer :: pset integer :: i if (eio%writing) then if (event%has_valid_particle_set ()) then select type (event) type is (event_t) write (eio%unit) i_prc write (eio%unit) event%get_index () write (eio%unit) event%get_i_mci () write (eio%unit) event%get_i_term () write (eio%unit) event%get_channel () write (eio%unit) event%expr%weight_prc write (eio%unit) event%expr%excess_prc write (eio%unit) event%get_n_dropped () write (eio%unit) event%expr%sqme_prc do i = 1, eio%n_alt write (eio%unit) event%expr%weight_alt(i) write (eio%unit) event%expr%sqme_alt(i) end do allocate (pset) call event%get_hard_particle_set (pset) call pset%write_raw (eio%unit) call pset%final () deallocate (pset) select case (eio%file_version) case (2:) if (event%has_transform ()) then write (eio%unit) .true. pset => event%get_particle_set_ptr () call pset%write_raw (eio%unit) else write (eio%unit) .false. end if end select class default call msg_bug ("Event: write raw: defined only for full event_t") end select else call msg_bug ("Event: write raw: particle set is undefined") end if else call eio%write () call msg_fatal ("Raw event file is not open for writing") end if end subroutine eio_raw_output @ %def eio_raw_output @ Input an event. Note: the particle set is physically copied. If there is a performance issue, we might choose to pointer-assign it instead, with a different version of [[event%set_hard_particle_set]]. <>= procedure :: input_i_prc => eio_raw_input_i_prc procedure :: input_event => eio_raw_input_event <>= subroutine eio_raw_input_i_prc (eio, i_prc, iostat) class(eio_raw_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat if (eio%reading) then read (eio%unit, iostat = iostat) i_prc else call eio%write () call msg_fatal ("Raw event file is not open for reading") end if end subroutine eio_raw_input_i_prc subroutine eio_raw_input_event (eio, event, iostat, event_handle) class(eio_raw_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle integer :: event_index, i_mci, i_term, channel, i real(default) :: weight, excess, sqme integer :: n_dropped real(default), dimension(:), allocatable :: weight_alt, sqme_alt logical :: has_transform type(particle_set_t), pointer :: pset class(model_data_t), pointer :: model if (eio%reading) then select type (event) type is (event_t) read (eio%unit, iostat = iostat) event_index if (iostat /= 0) return read (eio%unit, iostat = iostat) i_mci if (iostat /= 0) return read (eio%unit, iostat = iostat) i_term if (iostat /= 0) return read (eio%unit, iostat = iostat) channel if (iostat /= 0) return read (eio%unit, iostat = iostat) weight if (iostat /= 0) return read (eio%unit, iostat = iostat) excess if (iostat /= 0) return read (eio%unit, iostat = iostat) n_dropped if (iostat /= 0) return read (eio%unit, iostat = iostat) sqme if (iostat /= 0) return call event%reset_contents () call event%set_index (event_index) call event%select (i_mci, i_term, channel) if (eio%norm_mode /= NORM_UNDEFINED) then call event_normalization_update (weight, & eio%sigma, eio%n, event%get_norm_mode (), eio%norm_mode) call event_normalization_update (excess, & eio%sigma, eio%n, event%get_norm_mode (), eio%norm_mode) end if call event%set (sqme_ref = sqme, weight_ref = weight, & excess_prc = excess, & n_dropped = n_dropped) if (eio%n_alt /= 0) then allocate (sqme_alt (eio%n_alt), weight_alt (eio%n_alt)) do i = 1, eio%n_alt read (eio%unit, iostat = iostat) weight_alt(i) if (iostat /= 0) return read (eio%unit, iostat = iostat) sqme_alt(i) if (iostat /= 0) return end do call event%set (sqme_alt = sqme_alt, weight_alt = weight_alt) end if model => null () if (associated (event%process)) then model => event%process%get_model_ptr () end if allocate (pset) call pset%read_raw (eio%unit, iostat) if (iostat /= 0) return if (associated (model)) call pset%set_model (model) call event%set_hard_particle_set (pset) if (eio%use_alphas_from_file .or. eio%use_scale_from_file) then call event%recalculate (update_sqme = .true.) if (eio%fixed_order_nlo) then if (event%weight_prc /= event%weight_ref .and. & event%weight_prc == 0) then event%weight_prc = event%weight_ref end if end if end if call pset%final () deallocate (pset) select case (eio%file_version) case (2:) read (eio%unit, iostat = iostat) has_transform if (iostat /= 0) return if (has_transform) then allocate (pset) call pset%read_raw (eio%unit, iostat) if (iostat /= 0) return if (associated (model)) & call pset%set_model (model) call event%link_particle_set (pset) end if end select class default call msg_bug ("Event: read raw: defined only for full event_t") end select else call eio%write () call msg_fatal ("Raw event file is not open for reading") end if end subroutine eio_raw_input_event @ %def eio_raw_input_i_prc @ %def eio_raw_input_event @ <>= procedure :: skip => eio_raw_skip <>= subroutine eio_raw_skip (eio, iostat) class(eio_raw_t), intent(inout) :: eio integer, intent(out) :: iostat if (eio%reading) then read (eio%unit, iostat = iostat) else call eio%write () call msg_fatal ("Raw event file is not open for reading") end if end subroutine eio_raw_skip @ %def eio_raw_skip @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eio_raw_ut.f90]]>>= <> module eio_raw_ut use unit_tests use eio_raw_uti <> <> contains <> end module eio_raw_ut @ %def eio_raw_ut @ <<[[eio_raw_uti.f90]]>>= <> module eio_raw_uti <> <> use model_data use variables use events use eio_data use eio_base use eio_raw use process, only: process_t use instances, only: process_instance_t <> <> contains <> end module eio_raw_uti @ %def eio_raw_uti @ API: driver for the unit tests below. <>= public :: eio_raw_test <>= subroutine eio_raw_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_raw_test @ %def eio_raw_test @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= call test (eio_raw_1, "eio_raw_1", & "read and write event contents", & u, results) <>= public :: eio_raw_1 <>= subroutine eio_raw_1 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(model_data_t), target :: model type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance class(eio_t), allocatable :: eio integer :: i_prc, iostat type(string_t) :: sample write (u, "(A)") "* Test output: eio_raw_1" write (u, "(A)") "* Purpose: generate and read/write an event" write (u, "(A)") write (u, "(A)") "* Initialize test process" call model%init_test () allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model, & run_id = var_str ("run_test")) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_raw_1" allocate (eio_raw_t :: eio) call eio%init_out (sample) call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) write (u, "(A)") call eio%output (event, i_prc = 42) call eio%write (u) call eio%final () call event%final () deallocate (event) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Re-read the event" write (u, "(A)") call eio%init_in (sample) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call eio%input_i_prc (i_prc, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (i_prc):", iostat call eio%input_event (event, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (event):", iostat call eio%write (u) write (u, "(A)") write (u, "(1x,A,I0)") "i_prc = ", i_prc write (u, "(A)") call event%write (u) write (u, "(A)") write (u, "(A)") "* Generate and append another event" write (u, "(A)") call eio%switch_inout () call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call event%write (u) write (u, "(A)") call eio%output (event, i_prc = 5) call eio%write (u) call eio%final () call event%final () deallocate (event) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Re-read both events" write (u, "(A)") call eio%init_in (sample) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () allocate (event) call event%basic_init () call event%connect (process_instance, process%get_model_ptr ()) call eio%input_i_prc (i_prc, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (i_prc/1):", iostat call eio%input_event (event, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (event/1):", iostat call eio%input_i_prc (i_prc, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (i_prc/2):", iostat call eio%input_event (event, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (event/2):", iostat call eio%write (u) write (u, "(A)") write (u, "(1x,A,I0)") "i_prc = ", i_prc write (u, "(A)") call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () deallocate (eio) call event%final () deallocate (event) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: eio_raw_1" end subroutine eio_raw_1 @ %def eio_raw_1 @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= call test (eio_raw_2, "eio_raw_2", & "handle multiple weights", & u, results) <>= public :: eio_raw_2 <>= subroutine eio_raw_2 (u) use processes_ut, only: prepare_test_process, cleanup_test_process integer, intent(in) :: u type(model_data_t), target :: model type(var_list_t) :: var_list type(event_t), allocatable, target :: event type(process_t), allocatable, target :: process type(process_instance_t), allocatable, target :: process_instance type(event_sample_data_t) :: data class(eio_t), allocatable :: eio integer :: i_prc, iostat type(string_t) :: sample write (u, "(A)") "* Test output: eio_raw_2" write (u, "(A)") "* Purpose: generate and read/write an event" write (u, "(A)") "* with multiple weights" write (u, "(A)") call model%init_test () write (u, "(A)") "* Initialize test process" allocate (process) allocate (process_instance) call prepare_test_process (process, process_instance, model, & run_id = var_str ("run_test")) call process_instance%setup_event_data () call data%init (n_proc = 1, n_alt = 2) call var_list_append_log (var_list, var_str ("?unweighted"), .false., & intrinsic = .true.) call var_list_append_string (var_list, var_str ("$sample_normalization"), & var_str ("auto"), intrinsic = .true.) call var_list_append_real (var_list, var_str ("safety_factor"), & 1._default, intrinsic = .true.) allocate (event) call event%basic_init (var_list, n_alt = 2) call event%connect (process_instance, process%get_model_ptr ()) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_raw_2" allocate (eio_raw_t :: eio) call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call event%set (sqme_alt = [2._default, 3._default]) call event%set (weight_alt = & [2 * event%get_weight_ref (), 3 * event%get_weight_ref ()]) call event%store_alt_values () call event%check () call event%write (u) write (u, "(A)") call eio%output (event, i_prc = 42) call eio%write (u) call eio%final () call event%final () deallocate (event) call process_instance%final () deallocate (process_instance) write (u, "(A)") write (u, "(A)") "* Re-read the event" write (u, "(A)") call eio%init_in (sample, data) allocate (process_instance) call process_instance%init (process) call process_instance%setup_event_data () allocate (event) call event%basic_init (var_list, n_alt = 2) call event%connect (process_instance, process%get_model_ptr ()) call eio%input_i_prc (i_prc, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (i_prc):", iostat call eio%input_event (event, iostat) if (iostat /= 0) write (u, "(A,I0)") "I/O error (event):", iostat call eio%write (u) write (u, "(A)") write (u, "(1x,A,I0)") "i_prc = ", i_prc write (u, "(A)") call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () deallocate (eio) call event%final () deallocate (event) call cleanup_test_process (process, process_instance) deallocate (process_instance) deallocate (process) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: eio_raw_2" end subroutine eio_raw_2 @ %def eio_raw_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Dispatch} An event transform is responsible for dressing a partonic event. Since event transforms are not mutually exclusive but are concatenated, we provide individual dispatchers for each of them. <<[[dispatch_transforms.f90]]>>= <> module dispatch_transforms <> <> use process use variables use system_defs, only: LF use system_dependencies, only: LHAPDF6_AVAILABLE use sf_lhapdf, only: lhapdf_initialize use diagnostics use models use os_interface use beam_structures use resonances, only: resonance_history_set_t use instances, only: process_instance_t, process_instance_hook_t use event_base, only: event_callback_t, event_callback_nop_t use hepmc_interface, only: HEPMC3_MODE_HEPMC2, HEPMC3_MODE_HEPMC3 use hepmc_interface, only: HEPMC3_MODE_ROOT, HEPMC3_MODE_ROOTTREE use hepmc_interface, only: HEPMC3_MODE_HEPEVT use eio_base use eio_raw use eio_checkpoints use eio_callback use eio_lhef use eio_hepmc use eio_lcio use eio_stdhep use eio_ascii use eio_weights use eio_dump use event_transforms use resonance_insertion use isr_epa_handler use decays use shower_base use shower_core use shower use shower_pythia6 use shower_pythia8 use hadrons use mlm_matching use powheg_matching use ckkw_matching use tauola_interface !NODEP! use evt_nlo <> <> contains <> end module dispatch_transforms @ %def dispatch_transforms @ <>= public :: dispatch_evt_nlo <>= subroutine dispatch_evt_nlo (evt, keep_failed_events) class(evt_t), intent(out), pointer :: evt logical, intent(in) :: keep_failed_events call msg_message ("Simulate: activating fixed-order NLO events") allocate (evt_nlo_t :: evt) evt%only_weighted_events = .true. select type (evt) type is (evt_nlo_t) evt%i_evaluation = 0 evt%keep_failed_events = keep_failed_events end select end subroutine dispatch_evt_nlo @ %def dispatch_evt_nlo @ <>= public :: dispatch_evt_resonance <>= subroutine dispatch_evt_resonance (evt, var_list, res_history_set, libname) class(evt_t), intent(out), pointer :: evt type(var_list_t), intent(in) :: var_list type(resonance_history_set_t), dimension(:), intent(in) :: res_history_set type(string_t), intent(in) :: libname logical :: resonance_history resonance_history = var_list%get_lval (var_str ("?resonance_history")) if (resonance_history) then allocate (evt_resonance_t :: evt) call msg_message ("Simulate: activating resonance insertion") select type (evt) type is (evt_resonance_t) call evt%set_resonance_data (res_history_set) call evt%set_library (libname) end select else evt => null () end if end subroutine dispatch_evt_resonance @ %def dispatch_evt_resonance @ Initialize the ISR/EPA handler, depending on active settings. The activation is independent for both handlers, since only one may be needed at a time. However, if both handlers are active, the current implementation requires the handler modes of ISR and EPA to coincide. <>= public :: dispatch_evt_isr_epa_handler <>= subroutine dispatch_evt_isr_epa_handler (evt, var_list) class(evt_t), intent(out), pointer :: evt type(var_list_t), intent(in) :: var_list logical :: isr_recoil logical :: epa_recoil logical :: isr_handler_active logical :: epa_handler_active type(string_t) :: isr_handler_mode type(string_t) :: epa_handler_mode logical :: isr_keep_mass real(default) :: sqrts real(default) :: isr_q_max real(default) :: epa_q_max real(default) :: isr_mass real(default) :: epa_mass isr_handler_active = var_list%get_lval (var_str ("?isr_handler")) if (isr_handler_active) then call msg_message ("Simulate: activating ISR handler") isr_recoil = & var_list%get_lval (var_str ("?isr_recoil")) isr_handler_mode = & var_list%get_sval (var_str ("$isr_handler_mode")) isr_keep_mass = & var_list%get_lval (var_str ("?isr_handler_keep_mass")) if (isr_recoil) then call msg_fatal ("Simulate: ISR handler is incompatible & &with ?isr_recoil=true") end if end if epa_handler_active = var_list%get_lval (var_str ("?epa_handler")) if (epa_handler_active) then call msg_message ("Simulate: activating EPA handler") epa_recoil = var_list%get_lval (var_str ("?epa_recoil")) epa_handler_mode = var_list%get_sval (var_str ("$epa_handler_mode")) if (epa_recoil) then call msg_fatal ("Simulate: EPA handler is incompatible & &with ?epa_recoil=true") end if end if if (isr_handler_active .and. epa_handler_active) then if (isr_handler_mode /= epa_handler_mode) then call msg_fatal ("Simulate: ISR/EPA handler: modes must coincide") end if end if if (isr_handler_active .or. epa_handler_active) then allocate (evt_isr_epa_t :: evt) select type (evt) type is (evt_isr_epa_t) if (isr_handler_active) then call evt%set_mode_string (isr_handler_mode) else call evt%set_mode_string (epa_handler_mode) end if sqrts = var_list%get_rval (var_str ("sqrts")) if (isr_handler_active) then isr_q_max = var_list%get_rval (var_str ("isr_q_max")) isr_mass = var_list%get_rval (var_str ("isr_mass")) call evt%set_data_isr (sqrts, isr_q_max, isr_mass, isr_keep_mass) end if if (epa_handler_active) then epa_q_max = var_list%get_rval (var_str ("epa_q_max")) epa_mass = var_list%get_rval (var_str ("epa_mass")) call evt%set_data_epa (sqrts, epa_q_max, epa_mass) end if call msg_message ("Simulate: ISR/EPA handler mode: " & // char (evt%get_mode_string ())) end select else evt => null () end if end subroutine dispatch_evt_isr_epa_handler @ %def dispatch_evt_isr_epa_handler @ <>= public :: dispatch_evt_decay <>= subroutine dispatch_evt_decay (evt, var_list) class(evt_t), intent(out), pointer :: evt type(var_list_t), intent(in), target :: var_list logical :: allow_decays allow_decays = var_list%get_lval (var_str ("?allow_decays")) if (allow_decays) then allocate (evt_decay_t :: evt) call msg_message ("Simulate: activating decays") select type (evt) type is (evt_decay_t) call evt%set_var_list (var_list) end select else evt => null () end if end subroutine dispatch_evt_decay @ %def dispatch_evt_decay @ <>= public :: dispatch_evt_shower <>= subroutine dispatch_evt_shower (evt, var_list, model, fallback_model, & os_data, beam_structure, process) class(evt_t), intent(out), pointer :: evt type(var_list_t), intent(in) :: var_list type(model_t), pointer, intent(in) :: model, fallback_model type(os_data_t), intent(in) :: os_data type(beam_structure_t), intent(in) :: beam_structure type(process_t), intent(in), optional :: process type(string_t) :: lhapdf_file, lhapdf_dir, process_name integer :: lhapdf_member type(shower_settings_t) :: settings type(taudec_settings_t) :: taudec_settings call msg_message ("Simulate: activating parton shower") allocate (evt_shower_t :: evt) call settings%init (var_list) if (associated (model)) then call taudec_settings%init (var_list, model) else call taudec_settings%init (var_list, fallback_model) end if if (present (process)) then process_name = process%get_id () else process_name = 'dispatch_testing' end if select type (evt) type is (evt_shower_t) call evt%init (fallback_model, os_data) lhapdf_member = & var_list%get_ival (var_str ("lhapdf_member")) if (LHAPDF6_AVAILABLE) then lhapdf_dir = & var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = & var_list%get_sval (var_str ("$lhapdf_file")) call lhapdf_initialize & (1, lhapdf_dir, lhapdf_file, lhapdf_member, evt%pdf_data%pdf) end if if (present (process)) call evt%pdf_data%setup ("Shower", & beam_structure, lhapdf_member, process%get_pdf_set ()) select case (settings%method) case (PS_WHIZARD) allocate (shower_t :: evt%shower) case (PS_PYTHIA6) allocate (shower_pythia6_t :: evt%shower) case (PS_PYTHIA8) allocate (shower_pythia8_t :: evt%shower) case default call msg_fatal ('Shower: Method ' // & char (var_list%get_sval (var_str ("$shower_method"))) // & 'not implemented!') end select call evt%shower%init (settings, taudec_settings, evt%pdf_data, os_data) end select call dispatch_matching (evt, settings, var_list, process_name) end subroutine dispatch_evt_shower @ %def dispatch_evt_shower @ <>= public :: dispatch_evt_shower_hook <>= subroutine dispatch_evt_shower_hook (hook, var_list, process_instance) class(process_instance_hook_t), pointer, intent(out) :: hook type(var_list_t), intent(in) :: var_list class(process_instance_t), intent(in), target :: process_instance if (var_list%get_lval (var_str ('?powheg_matching'))) then call msg_message ("Integration hook: add POWHEG hook") allocate (powheg_matching_hook_t :: hook) call hook%init (var_list, process_instance) else hook => null () end if end subroutine dispatch_evt_shower_hook @ %def dispatch_evt_shower_hook @ <>= public :: dispatch_matching <>= subroutine dispatch_matching (evt, settings, var_list, process_name) class(evt_t), intent(inout) :: evt type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: process_name type(shower_settings_t), intent(in) :: settings select type (evt) type is (evt_shower_t) if (settings%mlm_matching .and. settings%ckkw_matching) then call msg_fatal ("Both MLM and CKKW matching activated," // & LF // " aborting simulation") end if if (settings%powheg_matching) then call msg_message ("Simulate: applying POWHEG matching") allocate (powheg_matching_t :: evt%matching) end if if (settings%mlm_matching) then call msg_message ("Simulate: applying MLM matching") allocate (mlm_matching_t :: evt%matching) end if if (settings%ckkw_matching) then call msg_warning ("Simulate: CKKW(-L) matching not yet supported") allocate (ckkw_matching_t :: evt%matching) end if if (allocated (evt%matching)) & call evt%matching%init (var_list, process_name) end select end subroutine dispatch_matching @ %def dispatch_matching @ <>= public :: dispatch_evt_hadrons <>= subroutine dispatch_evt_hadrons (evt, var_list, fallback_model) class(evt_t), intent(out), pointer :: evt type(var_list_t), intent(in) :: var_list type(model_t), pointer, intent(in) :: fallback_model type(shower_settings_t) :: shower_settings type(hadron_settings_t) :: hadron_settings allocate (evt_hadrons_t :: evt) call msg_message ("Simulate: activating hadronization") call shower_settings%init (var_list) call hadron_settings%init (var_list) select type (evt) type is (evt_hadrons_t) call evt%init (fallback_model) select case (hadron_settings%method) case (HADRONS_WHIZARD) allocate (hadrons_hadrons_t :: evt%hadrons) case (HADRONS_PYTHIA6) allocate (hadrons_pythia6_t :: evt%hadrons) case (HADRONS_PYTHIA8) allocate (hadrons_pythia8_t :: evt%hadrons) case default call msg_fatal ('Hadronization: Method ' // & char (var_list%get_sval (var_str ("hadronization_method"))) // & 'not implemented!') end select call evt%hadrons%init & (shower_settings, hadron_settings, fallback_model) end select end subroutine dispatch_evt_hadrons @ %def dispatch_evt_hadrons @ We cannot put this in the [[events]] subdir due to [[eio_raw_t]], which is defined here. <>= public :: dispatch_eio <>= subroutine dispatch_eio (eio, method, var_list, fallback_model, & event_callback) class(eio_t), allocatable, intent(inout) :: eio type(string_t), intent(in) :: method type(var_list_t), intent(in) :: var_list type(model_t), target, intent(in) :: fallback_model class(event_callback_t), allocatable, intent(in) :: event_callback logical :: check, keep_beams, keep_remnants, recover_beams logical :: use_alphas_from_file, use_scale_from_file logical :: fixed_order_nlo_events logical :: write_sqme_prc, write_sqme_ref, write_sqme_alt logical :: output_cross_section, ensure_order type(string_t) :: lhef_version, lhef_extension, raw_version type(string_t) :: extension_default, debug_extension, dump_extension, & extension_hepmc, & extension_lha, extension_hepevt, extension_ascii_short, & extension_ascii_long, extension_athena, extension_mokka, & extension_stdhep, extension_stdhep_up, extension_stdhep_ev4, & extension_raw, extension_hepevt_verb, extension_lha_verb, & extension_lcio integer :: checkpoint integer :: lcio_run_id, hepmc3_mode logical :: show_process, show_transforms, show_decay, verbose, pacified logical :: dump_weights, dump_compressed, dump_summary, dump_screen logical :: proc_as_run_id, hepmc3_write_flows keep_beams = & var_list%get_lval (var_str ("?keep_beams")) keep_remnants = & var_list%get_lval (var_str ("?keep_remnants")) ensure_order = & var_list%get_lval (var_str ("?hepevt_ensure_order")) recover_beams = & var_list%get_lval (var_str ("?recover_beams")) use_alphas_from_file = & var_list%get_lval (var_str ("?use_alphas_from_file")) use_scale_from_file = & var_list%get_lval (var_str ("?use_scale_from_file")) fixed_order_nlo_events = & var_list%get_lval (var_str ("?fixed_order_nlo_events")) select case (char (method)) case ("raw") allocate (eio_raw_t :: eio) select type (eio) type is (eio_raw_t) check = & var_list%get_lval (var_str ("?check_event_file")) raw_version = & var_list%get_sval (var_str ("$event_file_version")) extension_raw = & var_list%get_sval (var_str ("$extension_raw")) call eio%set_parameters (check, use_alphas_from_file, & use_scale_from_file, fixed_order_nlo_events, & raw_version, extension_raw) end select case ("checkpoint") allocate (eio_checkpoints_t :: eio) select type (eio) type is (eio_checkpoints_t) checkpoint = & var_list%get_ival (var_str ("checkpoint")) pacified = & var_list%get_lval (var_str ("?pacify")) call eio%set_parameters (checkpoint, blank = pacified) end select case ("callback") allocate (eio_callback_t :: eio) select type (eio) type is (eio_callback_t) checkpoint = & var_list%get_ival (var_str ("event_callback_interval")) if (allocated (event_callback)) then call eio%set_parameters (event_callback, checkpoint) else call eio%set_parameters (event_callback_nop_t (), 0) end if end select case ("lhef") allocate (eio_lhef_t :: eio) select type (eio) type is (eio_lhef_t) lhef_version = & var_list%get_sval (var_str ("$lhef_version")) lhef_extension = & var_list%get_sval (var_str ("$lhef_extension")) write_sqme_prc = & var_list%get_lval (var_str ("?lhef_write_sqme_prc")) write_sqme_ref = & var_list%get_lval (var_str ("?lhef_write_sqme_ref")) write_sqme_alt = & var_list%get_lval (var_str ("?lhef_write_sqme_alt")) call eio%set_parameters ( & keep_beams, keep_remnants, recover_beams, & use_alphas_from_file, use_scale_from_file, & char (lhef_version), lhef_extension, & write_sqme_ref, write_sqme_prc, write_sqme_alt) end select case ("hepmc") allocate (eio_hepmc_t :: eio) select type (eio) type is (eio_hepmc_t) output_cross_section = & var_list%get_lval (var_str ("?hepmc_output_cross_section")) extension_hepmc = & var_list%get_sval (var_str ("$extension_hepmc")) hepmc3_write_flows = & var_list%get_lval (var_str ("?hepmc3_write_flows")) select case (char (var_list%get_sval (var_str ("$hepmc3_mode")))) case ("HepMC2") hepmc3_mode = HEPMC3_MODE_HEPMC2 case ("HepMC3") hepmc3_mode = HEPMC3_MODE_HEPMC3 case ("Root") hepmc3_mode = HEPMC3_MODE_ROOT if (extension_hepmc /= "root") then call msg_message ("Events: HepMC3 Root mode, using " // & "event sample extension 'root'") extension_hepmc = "root" end if case ("RootTree") hepmc3_mode = HEPMC3_MODE_ROOTTREE if (extension_hepmc /= "root") then call msg_message ("Events: HepMC3 RootTree mode, using " // & "event sample extension 'root'") extension_hepmc = "root" end if case ("HepEVT") hepmc3_mode = HEPMC3_MODE_HEPEVT case default call msg_fatal ("Only supported HepMC3 modes are: 'HepMC2', " // & "'HepMC3', 'HepEVT', 'Root', and 'RootTree'.") end select call eio%set_parameters (recover_beams, & use_alphas_from_file, use_scale_from_file, & extension = extension_hepmc, & output_cross_section = output_cross_section, & hepmc3_mode = hepmc3_mode, & hepmc3_write_flows = hepmc3_write_flows) end select case ("lcio") allocate (eio_lcio_t :: eio) select type (eio) type is (eio_lcio_t) extension_lcio = & var_list%get_sval (var_str ("$extension_lcio")) proc_as_run_id = & var_list%get_lval (var_str ("?proc_as_run_id")) lcio_run_id = & var_list%get_ival (var_str ("lcio_run_id")) call eio%set_parameters (recover_beams, & use_alphas_from_file, use_scale_from_file, & extension_lcio, proc_as_run_id = proc_as_run_id, & lcio_run_id = lcio_run_id) end select case ("stdhep") allocate (eio_stdhep_hepevt_t :: eio) select type (eio) type is (eio_stdhep_hepevt_t) extension_stdhep = & var_list%get_sval (var_str ("$extension_stdhep")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, recover_beams, & use_alphas_from_file, use_scale_from_file, extension_stdhep) end select case ("stdhep_up") allocate (eio_stdhep_hepeup_t :: eio) select type (eio) type is (eio_stdhep_hepeup_t) extension_stdhep_up = & var_list%get_sval (var_str ("$extension_stdhep_up")) call eio%set_parameters (keep_beams, keep_remnants, ensure_order, & recover_beams, use_alphas_from_file, & use_scale_from_file, extension_stdhep_up) end select case ("stdhep_ev4") allocate (eio_stdhep_hepev4_t :: eio) select type (eio) type is (eio_stdhep_hepev4_t) extension_stdhep_ev4 = & var_list%get_sval (var_str ("$extension_stdhep_ev4")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, recover_beams, & use_alphas_from_file, use_scale_from_file, extension_stdhep_ev4) end select case ("ascii") allocate (eio_ascii_ascii_t :: eio) select type (eio) type is (eio_ascii_ascii_t) extension_default = & var_list%get_sval (var_str ("$extension_default")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_default) end select case ("athena") allocate (eio_ascii_athena_t :: eio) select type (eio) type is (eio_ascii_athena_t) extension_athena = & var_list%get_sval (var_str ("$extension_athena")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_athena) end select case ("debug") allocate (eio_ascii_debug_t :: eio) select type (eio) type is (eio_ascii_debug_t) debug_extension = & var_list%get_sval (var_str ("$debug_extension")) show_process = & var_list%get_lval (var_str ("?debug_process")) show_transforms = & var_list%get_lval (var_str ("?debug_transforms")) show_decay = & var_list%get_lval (var_str ("?debug_decay")) verbose = & var_list%get_lval (var_str ("?debug_verbose")) call eio%set_parameters ( & extension = debug_extension, & show_process = show_process, & show_transforms = show_transforms, & show_decay = show_decay, & verbose = verbose) end select case ("dump") allocate (eio_dump_t :: eio) select type (eio) type is (eio_dump_t) dump_extension = & var_list%get_sval (var_str ("$dump_extension")) pacified = & var_list%get_lval (var_str ("?pacify")) dump_weights = & var_list%get_lval (var_str ("?dump_weights")) dump_compressed = & var_list%get_lval (var_str ("?dump_compressed")) dump_summary = & var_list%get_lval (var_str ("?dump_summary")) dump_screen = & var_list%get_lval (var_str ("?dump_screen")) call eio%set_parameters ( & extension = dump_extension, & pacify = pacified, & weights = dump_weights, & compressed = dump_compressed, & summary = dump_summary, & screen = dump_screen) end select case ("hepevt") allocate (eio_ascii_hepevt_t :: eio) select type (eio) type is (eio_ascii_hepevt_t) extension_hepevt = & var_list%get_sval (var_str ("$extension_hepevt")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_hepevt) end select case ("hepevt_verb") allocate (eio_ascii_hepevt_verb_t :: eio) select type (eio) type is (eio_ascii_hepevt_verb_t) extension_hepevt_verb = & var_list%get_sval (var_str ("$extension_hepevt_verb")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_hepevt_verb) end select case ("lha") allocate (eio_ascii_lha_t :: eio) select type (eio) type is (eio_ascii_lha_t) extension_lha = & var_list%get_sval (var_str ("$extension_lha")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_lha) end select case ("lha_verb") allocate (eio_ascii_lha_verb_t :: eio) select type (eio) type is (eio_ascii_lha_verb_t) extension_lha_verb = var_list%get_sval ( & var_str ("$extension_lha_verb")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_lha_verb) end select case ("long") allocate (eio_ascii_long_t :: eio) select type (eio) type is (eio_ascii_long_t) extension_ascii_long = & var_list%get_sval (var_str ("$extension_ascii_long")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_ascii_long) end select case ("mokka") allocate (eio_ascii_mokka_t :: eio) select type (eio) type is (eio_ascii_mokka_t) extension_mokka = & var_list%get_sval (var_str ("$extension_mokka")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_mokka) end select case ("short") allocate (eio_ascii_short_t :: eio) select type (eio) type is (eio_ascii_short_t) extension_ascii_short = & var_list%get_sval (var_str ("$extension_ascii_short")) call eio%set_parameters & (keep_beams, keep_remnants, ensure_order, extension_ascii_short) end select case ("weight_stream") allocate (eio_weights_t :: eio) select type (eio) type is (eio_weights_t) pacified = & var_list%get_lval (var_str ("?pacify")) call eio%set_parameters (pacify = pacified) end select case default call msg_fatal ("Event I/O method '" // char (method) & // "' not implemented") end select call eio%set_fallback_model (fallback_model) end subroutine dispatch_eio @ %def dispatch_eio @ @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[dispatch_transforms_ut.f90]]>>= <> module dispatch_transforms_ut use unit_tests use dispatch_transforms_uti <> <> contains <> end module dispatch_transforms_ut @ %def dispatch_transforms_ut @ <<[[dispatch_transforms_uti.f90]]>>= <> module dispatch_transforms_uti <> <> use format_utils, only: write_separator use variables use event_base, only: event_callback_t use models, only: model_t, model_list_t use models, only: syntax_model_file_init, syntax_model_file_final use resonances, only: resonance_history_set_t use beam_structures, only: beam_structure_t use eio_base, only: eio_t use os_interface, only: os_data_t use event_transforms, only: evt_t use dispatch_transforms <> <> contains <> end module dispatch_transforms_uti @ %def dispatch_transforms_uti @ API: driver for the unit tests below. <>= public ::dispatch_transforms_test <>= subroutine dispatch_transforms_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine dispatch_transforms_test @ %def dispatch_transforms_test @ \subsubsection{Event I/O} <>= call test (dispatch_transforms_1, "dispatch_transforms_1", & "event I/O", & u, results) <>= public :: dispatch_transforms_1 <>= subroutine dispatch_transforms_1 (u) integer, intent(in) :: u type(var_list_t) :: var_list type(model_list_t) :: model_list type(model_t), pointer :: model type(os_data_t) :: os_data class(event_callback_t), allocatable :: event_callback class(eio_t), allocatable :: eio write (u, "(A)") "* Test output: dispatch_transforms_1" write (u, "(A)") "* Purpose: allocate an event I/O (eio) stream" write (u, "(A)") call var_list%init_defaults (0) call os_data%init () call syntax_model_file_init () call model_list%read_model (var_str ("SM_hadrons"), & var_str ("SM_hadrons.mdl"), os_data, model) write (u, "(A)") "* Allocate as raw" write (u, "(A)") call dispatch_eio (eio, var_str ("raw"), var_list, & model, event_callback) call eio%write (u) call eio%final () deallocate (eio) write (u, "(A)") write (u, "(A)") "* Allocate as checkpoints:" write (u, "(A)") call dispatch_eio (eio, var_str ("checkpoint"), var_list, & model, event_callback) call eio%write (u) call eio%final () deallocate (eio) write (u, "(A)") write (u, "(A)") "* Allocate as LHEF:" write (u, "(A)") call var_list%set_string (var_str ("$lhef_extension"), & var_str ("lhe_custom"), is_known = .true.) call dispatch_eio (eio, var_str ("lhef"), var_list, & model, event_callback) call eio%write (u) call eio%final () deallocate (eio) write (u, "(A)") write (u, "(A)") "* Allocate as HepMC:" write (u, "(A)") call dispatch_eio (eio, var_str ("hepmc"), var_list, & model, event_callback) call eio%write (u) call eio%final () deallocate (eio) write (u, "(A)") write (u, "(A)") "* Allocate as weight_stream" write (u, "(A)") call dispatch_eio (eio, var_str ("weight_stream"), var_list, & model, event_callback) call eio%write (u) call eio%final () deallocate (eio) write (u, "(A)") write (u, "(A)") "* Allocate as debug format" write (u, "(A)") call var_list%set_log (var_str ("?debug_verbose"), & .false., is_known = .true.) call dispatch_eio (eio, var_str ("debug"), var_list, & model, event_callback) call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () call var_list%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_transforms_1" end subroutine dispatch_transforms_1 @ %def dispatch_transforms_1 @ \subsubsection{Event transforms} This test dispatches [[evt]] (event transform) objects. <>= call test (dispatch_transforms_2, "dispatch_transforms_2", & "event transforms", & u, results) <>= public :: dispatch_transforms_2 <>= subroutine dispatch_transforms_2 (u) integer, intent(in) :: u type(var_list_t), target :: var_list type(model_list_t) :: model_list type(model_t), pointer :: model type(os_data_t) :: os_data type(resonance_history_set_t), dimension(1) :: res_history_set type(beam_structure_t) :: beam_structure class(evt_t), pointer :: evt write (u, "(A)") "* Test output: dispatch_transforms_2" write (u, "(A)") "* Purpose: configure event transform" write (u, "(A)") call syntax_model_file_init () call var_list%init_defaults (0) call os_data%init () call model_list%read_model (var_str ("SM_hadrons"), & var_str ("SM_hadrons.mdl"), os_data, model) write (u, "(A)") "* Resonance insertion" write (u, "(A)") call var_list%set_log (var_str ("?resonance_history"), .true., & is_known = .true.) call dispatch_evt_resonance (evt, var_list, & res_history_set, & var_str ("foo_R")) call evt%write (u, verbose = .true., more_verbose = .true.) call evt%final () deallocate (evt) write (u, "(A)") write (u, "(A)") "* ISR handler" write (u, "(A)") call var_list%set_log (var_str ("?isr_handler"), .true., & is_known = .true.) call var_list%set_log (var_str ("?epa_handler"), .false., & is_known = .true.) call var_list%set_string (var_str ("$isr_handler_mode"), & var_str ("recoil"), & is_known = .true.) call var_list%set_real (var_str ("sqrts"), 100._default, & is_known = .true.) call var_list%set_real (var_str ("isr_mass"), 511.e-6_default, & is_known = .true.) call dispatch_evt_isr_epa_handler (evt, var_list) call evt%write (u, verbose = .true., more_verbose = .true.) call evt%final () deallocate (evt) write (u, "(A)") write (u, "(A)") "* EPA handler" write (u, "(A)") call var_list%set_log (var_str ("?isr_handler"), .false., & is_known = .true.) call var_list%set_log (var_str ("?epa_handler"), .true., & is_known = .true.) call var_list%set_string (var_str ("$epa_handler_mode"), & var_str ("recoil"), & is_known = .true.) call var_list%set_real (var_str ("sqrts"), 100._default, & is_known = .true.) call var_list%set_real (var_str ("epa_mass"), 511.e-6_default, & is_known = .true.) call dispatch_evt_isr_epa_handler (evt, var_list) call evt%write (u, verbose = .true., more_verbose = .true.) call evt%final () deallocate (evt) write (u, "(A)") write (u, "(A)") "* Partonic decays" write (u, "(A)") call dispatch_evt_decay (evt, var_list) call evt%write (u, verbose = .true., more_verbose = .true.) call evt%final () deallocate (evt) write (u, "(A)") write (u, "(A)") "* Shower" write (u, "(A)") call var_list%set_log (var_str ("?allow_shower"), .true., & is_known = .true.) call var_list%set_string (var_str ("$shower_method"), & var_str ("WHIZARD"), is_known = .true.) call dispatch_evt_shower (evt, var_list, model, & model, os_data, beam_structure) call evt%write (u) call write_separator (u, 2) call evt%final () deallocate (evt) call var_list%final () call syntax_model_file_final () write (u, "(A)") write (u, "(A)") "* Test output end: dispatch_transforms_2" end subroutine dispatch_transforms_2 @ %def dispatch_transforms_2 Index: trunk/share/debug/Makefile_full =================================================================== --- trunk/share/debug/Makefile_full (revision 8778) +++ trunk/share/debug/Makefile_full (revision 8779) @@ -1,544 +1,574 @@ FC=pgfortran_2019 FCFLAGS=-Mbackslash CC=gcc CCFLAGS= MODELS = \ SM.mdl \ SM_hadrons.mdl \ Test.mdl CC_SRC = \ sprintf_interface.c \ signal_interface.c F77_SRC = \ pythia.F \ pythia_pdf.f \ pythia6_up.f \ toppik.f \ toppik_axial.f FC0_SRC = FC_SRC = \ format_defs.f90 \ io_units.f90 \ kinds.f90 \ constants.f90 \ iso_varying_string.f90 \ unit_tests.f90 \ + unit_tests_sub.f90 \ + numeric_utils.f90 \ + numeric_utils_sub.f90 \ system_dependencies.f90 \ string_utils.f90 \ + string_utils_sub.f90 \ system_defs.f90 \ + system_defs_sub.f90 \ debug_master.f90 \ diagnostics.f90 \ + diagnostics_sub.f90 \ sorting.f90 \ physics_defs.f90 \ + physics_defs_sub.f90 \ pdg_arrays.f90 \ bytes.f90 \ hashes.f90 \ md5.f90 \ model_data.f90 \ - numeric_utils.f90 \ + model_data_sub.f90 \ auto_components.f90 \ var_base.f90 \ model_testbed.f90 \ auto_components_uti.f90 \ auto_components_ut.f90 \ os_interface.f90 \ + os_interface_sub.f90 \ c_particles.f90 \ + c_particles_sub.f90 \ format_utils.f90 \ lorentz.f90 \ + lorentz_sub.f90 \ + phs_points.f90 \ + phs_points_sub.f90 \ colors.f90 \ + colors_sub.f90 \ flavors.f90 \ + flavors_sub.f90 \ helicities.f90 \ + helicities_sub.f90 \ quantum_numbers.f90 \ + quantum_numbers_sub.f90 \ state_matrices.f90 \ + state_matrices_sub.f90 \ interactions.f90 \ + interactions_sub.f90 \ CppStringsWrap_dummy.f90 \ FastjetWrap_dummy.f90 \ cpp_strings.f90 \ + cpp_strings_sub.f90 \ fastjet.f90 \ + fastjet_sub.f90 \ jets.f90 \ subevents.f90 \ su_algebra.f90 \ bloch_vectors.f90 \ polarizations.f90 \ particles.f90 \ event_base.f90 \ eio_data.f90 \ event_handles.f90 \ eio_base.f90 \ eio_base_uti.f90 \ eio_base_ut.f90 \ variables.f90 \ rng_base.f90 \ tao_random_numbers.f90 \ rng_tao.f90 \ rng_stream.f90 \ rng_base_uti.f90 \ rng_base_ut.f90 \ dispatch_rng.f90 \ dispatch_rng_uti.f90 \ dispatch_rng_ut.f90 \ beam_structures.f90 \ evaluators.f90 \ + evaluators_sub.f90 \ beams.f90 \ sm_physics.f90 \ + sm_physics_sub.f90 \ file_registries.f90 \ + file_registries_sub.f90 \ sf_aux.f90 \ sf_mappings.f90 \ sf_base.f90 \ electron_pdfs.f90 \ sf_isr.f90 \ sf_epa.f90 \ sf_ewa.f90 \ sf_escan.f90 \ sf_gaussian.f90 \ sf_beam_events.f90 \ circe1.f90 \ sf_circe1.f90 \ circe2.f90 \ selectors.f90 \ sf_circe2.f90 \ sm_qcd.f90 \ + sm_qcd_sub.f90 \ + sm_qed.f90 \ + sm_qed_sub.f90 \ mrst2004qed.f90 \ cteq6pdf.f90 \ mstwpdf.f90 \ ct10pdf.f90 \ CJpdf.f90 \ ct14pdf.f90 \ pdf_builtin.f90 \ + pdf_builtin_sub.f90 \ LHAPDFWrap_dummy.f90 \ lhapdf5_full_dummy.f90 \ lhapdf5_has_photon_dummy.f90 \ lhapdf.f90 \ hoppet_dummy.f90 \ hoppet_interface.f90 \ sf_pdf_builtin.f90 \ sf_lhapdf.f90 \ dispatch_beams.f90 \ process_constants.f90 \ prclib_interfaces.f90 \ prc_core_def.f90 \ particle_specifiers.f90 \ process_libraries.f90 \ prc_test.f90 \ prc_core.f90 \ prc_test_core.f90 \ sm_qed.f90 \ prc_omega.f90 \ phs_base.f90 \ ifiles.f90 \ lexers.f90 \ syntax_rules.f90 \ parser.f90 \ expr_base.f90 \ formats.f90 \ + formats_sub.f90 \ analysis.f90 \ user_code_interface.f90 \ observables.f90 \ eval_trees.f90 \ interpolation.f90 \ nr_tools.f90 \ ttv_formfactors.f90 \ ttv_formfactors_uti.f90 \ ttv_formfactors_ut.f90 \ models.f90 \ prclib_stacks.f90 \ user_files.f90 \ cputime.f90 \ + cputime_sub.f90 \ mci_base.f90 \ integration_results.f90 \ integration_results_uti.f90 \ integration_results_ut.f90 \ mappings.f90 \ permutations.f90 \ resonances.f90 \ phs_trees.f90 \ phs_forests.f90 \ prc_external.f90 \ blha_config.f90 \ blha_olp_interfaces.f90 \ prc_openloops.f90 \ prc_threshold.f90 \ process_config.f90 \ process_counter.f90 \ process_mci.f90 \ pcm_base.f90 \ nlo_data.f90 \ cascades.f90 \ cascades2_lexer.f90 \ cascades2_lexer_uti.f90 \ cascades2_lexer_ut.f90 \ cascades2.f90 \ cascades2_uti.f90 \ cascades2_ut.f90 \ phs_none.f90 \ phs_rambo.f90 \ phs_wood.f90 \ phs_fks.f90 \ phs_single.f90 \ fks_regions.f90 \ virtual.f90 \ pdf.f90 \ real_subtraction.f90 \ dglap_remnant.f90 \ dispatch_fks.f90 \ dispatch_phase_space.f90 \ pcm.f90 \ recola_wrapper_dummy.f90 \ prc_recola.f90 \ subevt_expr.f90 \ parton_states.f90 \ prc_template_me.f90 \ process.f90 \ process_stacks.f90 \ iterations.f90 \ rt_data.f90 \ file_utils.f90 \ + file_utils_sub.f90 \ prc_gosam.f90 \ dispatch_me_methods.f90 \ sf_base_uti.f90 \ sf_base_ut.f90 \ dispatch_uti.f90 \ dispatch_ut.f90 \ formats_uti.f90 \ formats_ut.f90 \ md5_uti.f90 \ md5_ut.f90 \ os_interface_uti.f90 \ os_interface_ut.f90 \ sorting_uti.f90 \ sorting_ut.f90 \ grids.f90 \ grids_uti.f90 \ grids_ut.f90 \ solver.f90 \ solver_uti.f90 \ solver_ut.f90 \ cputime_uti.f90 \ cputime_ut.f90 \ sm_qcd_uti.f90 \ sm_qcd_ut.f90 \ sm_physics_uti.f90 \ sm_physics_ut.f90 \ lexers_uti.f90 \ lexers_ut.f90 \ parser_uti.f90 \ parser_ut.f90 \ xml.f90 \ xml_uti.f90 \ xml_ut.f90 \ colors_uti.f90 \ colors_ut.f90 \ state_matrices_uti.f90 \ state_matrices_ut.f90 \ analysis_uti.f90 \ analysis_ut.f90 \ particles_uti.f90 \ particles_ut.f90 \ radiation_generator.f90 \ radiation_generator_uti.f90 \ radiation_generator_ut.f90 \ blha_uti.f90 \ blha_ut.f90 \ evaluators_uti.f90 \ evaluators_ut.f90 \ models_uti.f90 \ models_ut.f90 \ eval_trees_uti.f90 \ eval_trees_ut.f90 \ resonances_uti.f90 \ resonances_ut.f90 \ phs_trees_uti.f90 \ phs_trees_ut.f90 \ phs_forests_uti.f90 \ phs_forests_ut.f90 \ beams_uti.f90 \ beams_ut.f90 \ su_algebra_uti.f90 \ su_algebra_ut.f90 \ bloch_vectors_uti.f90 \ bloch_vectors_ut.f90 \ polarizations_uti.f90 \ polarizations_ut.f90 \ sf_aux_uti.f90 \ sf_aux_ut.f90 \ sf_mappings_uti.f90 \ sf_mappings_ut.f90 \ sf_pdf_builtin_uti.f90 \ sf_pdf_builtin_ut.f90 \ sf_lhapdf_uti.f90 \ sf_lhapdf_ut.f90 \ sf_isr_uti.f90 \ sf_isr_ut.f90 \ sf_epa_uti.f90 \ sf_epa_ut.f90 \ sf_ewa_uti.f90 \ sf_ewa_ut.f90 \ sf_circe1_uti.f90 \ sf_circe1_ut.f90 \ sf_circe2_uti.f90 \ sf_circe2_ut.f90 \ sf_gaussian_uti.f90 \ sf_gaussian_ut.f90 \ sf_beam_events_uti.f90 \ sf_beam_events_ut.f90 \ sf_escan_uti.f90 \ sf_escan_ut.f90 \ phs_base_uti.f90 \ phs_base_ut.f90 \ phs_none_uti.f90 \ phs_none_ut.f90 \ phs_single_uti.f90 \ phs_single_ut.f90 \ phs_rambo_uti.f90 \ phs_rambo_ut.f90 \ phs_wood_uti.f90 \ phs_wood_ut.f90 \ phs_fks_uti.f90 \ phs_fks_ut.f90 \ fks_regions_uti.f90 \ fks_regions_ut.f90 \ mci_midpoint.f90 \ mci_base_uti.f90 \ mci_base_ut.f90 \ mci_midpoint_uti.f90 \ mci_midpoint_ut.f90 \ kinematics.f90 \ instances.f90 \ mci_none.f90 \ mci_none_uti.f90 \ mci_none_ut.f90 \ processes_uti.f90 \ processes_ut.f90 \ process_stacks_uti.f90 \ process_stacks_ut.f90 \ prc_recola_uti.f90 \ prc_recola_ut.f90 \ rng_tao_uti.f90 \ rng_tao_ut.f90 \ rng_stream_uti.f90 \ rng_stream_ut.f90 \ selectors_uti.f90 \ selectors_ut.f90 \ vegas.f90 \ vegas_uti.f90 \ vegas_ut.f90 \ vamp2.f90 \ vamp2_uti.f90 \ vamp2_ut.f90 \ exceptions.f90 \ vamp_stat.f90 \ utils.f90 \ divisions.f90 \ linalg.f90 \ vamp.f90 \ mci_vamp.f90 \ mci_vamp_uti.f90 \ mci_vamp_ut.f90 \ mci_vamp2.f90 \ mci_vamp2_uti.f90 \ mci_vamp2_ut.f90 \ prclib_interfaces_uti.f90 \ prclib_interfaces_ut.f90 \ particle_specifiers_uti.f90 \ particle_specifiers_ut.f90 \ process_libraries_uti.f90 \ process_libraries_ut.f90 \ prclib_stacks_uti.f90 \ prclib_stacks_ut.f90 \ slha_interface.f90 \ slha_interface_uti.f90 \ slha_interface_ut.f90 \ cascades_uti.f90 \ cascades_ut.f90 \ prc_test_uti.f90 \ prc_test_ut.f90 \ prc_template_me_uti.f90 \ prc_template_me_ut.f90 \ prc_omega_uti.f90 \ prc_omega_ut.f90 \ event_transforms.f90 \ event_transforms_uti.f90 \ event_transforms_ut.f90 \ hep_common.f90 \ hepev4_aux.f90 \ tauola_dummy.f90 \ tauola_interface.f90 \ shower_base.f90 \ shower_partons.f90 \ muli.f90 \ matching_base.f90 \ powheg_matching.f90 \ shower_core.f90 \ shower_base_uti.f90 \ shower_base_ut.f90 \ shower.f90 \ shower_uti.f90 \ shower_ut.f90 \ shower_pythia6.f90 \ whizard_lha.f90 \ whizard_lha_uti.f90 \ whizard_lha_ut.f90 \ LHAWhizard_dummy.f90 \ Pythia8Wrap_dummy.f90 \ pythia8.f90 \ pythia8_uti.f90 \ pythia8_ut.f90 \ shower_pythia8.f90 \ hadrons.f90 \ ktclus.f90 \ mlm_matching.f90 \ ckkw_matching.f90 \ jets_uti.f90 \ jets_ut.f90 \ pdg_arrays_uti.f90 \ pdg_arrays_ut.f90 \ interactions_uti.f90 \ interactions_ut.f90 \ decays.f90 \ decays_uti.f90 \ decays_ut.f90 \ evt_nlo.f90 \ events.f90 \ events_uti.f90 \ events_ut.f90 \ HepMCWrap_dummy.f90 \ hepmc_interface.f90 \ hepmc_interface_uti.f90 \ hepmc_interface_ut.f90 \ LCIOWrap_dummy.f90 \ lcio_interface.f90 \ lcio_interface_uti.f90 \ lcio_interface_ut.f90 \ hep_events.f90 \ hep_events_uti.f90 \ hep_events_ut.f90 \ expr_tests_uti.f90 \ expr_tests_ut.f90 \ parton_states_uti.f90 \ parton_states_ut.f90 \ eio_data_uti.f90 \ eio_data_ut.f90 \ eio_raw.f90 \ eio_raw_uti.f90 \ eio_raw_ut.f90 \ eio_checkpoints.f90 \ eio_checkpoints_uti.f90 \ eio_checkpoints_ut.f90 \ eio_lhef.f90 \ eio_lhef_uti.f90 \ eio_lhef_ut.f90 \ eio_hepmc.f90 \ eio_hepmc_uti.f90 \ eio_hepmc_ut.f90 \ eio_lcio.f90 \ eio_lcio_uti.f90 \ eio_lcio_ut.f90 \ stdhep_dummy.f90 \ xdr_wo_stdhep.f90 \ eio_stdhep.f90 \ eio_stdhep_uti.f90 \ eio_stdhep_ut.f90 \ eio_ascii.f90 \ eio_ascii_uti.f90 \ eio_ascii_ut.f90 \ eio_weights.f90 \ eio_weights_uti.f90 \ eio_weights_ut.f90 \ eio_dump.f90 \ eio_dump_uti.f90 \ eio_dump_ut.f90 \ eio_callback.f90 \ real_subtraction_uti.f90 \ real_subtraction_ut.f90 \ iterations_uti.f90 \ iterations_ut.f90 \ rt_data_uti.f90 \ rt_data_ut.f90 \ dispatch_mci.f90 \ dispatch_mci_uti.f90 \ dispatch_mci_ut.f90 \ dispatch_phs_uti.f90 \ dispatch_phs_ut.f90 \ resonance_insertion.f90 \ resonance_insertion_uti.f90 \ resonance_insertion_ut.f90 \ recoil_kinematics.f90 \ recoil_kinematics_uti.f90 \ recoil_kinematics_ut.f90 \ isr_epa_handler.f90 \ isr_epa_handler_uti.f90 \ isr_epa_handler_ut.f90 \ dispatch_transforms.f90 \ dispatch_transforms_uti.f90 \ dispatch_transforms_ut.f90 \ beam_structures_uti.f90 \ beam_structures_ut.f90 \ process_configurations.f90 \ process_configurations_uti.f90 \ process_configurations_ut.f90 \ compilations.f90 \ compilations_uti.f90 \ compilations_ut.f90 \ integrations.f90 \ integrations_uti.f90 \ integrations_ut.f90 \ event_streams.f90 \ event_streams_uti.f90 \ event_streams_ut.f90 \ restricted_subprocesses.f90 \ eio_direct.f90 \ eio_direct_uti.f90 \ eio_direct_ut.f90 \ simulations.f90 \ restricted_subprocesses_uti.f90 \ restricted_subprocesses_ut.f90 \ simulations_uti.f90 \ simulations_ut.f90 \ commands.f90 \ commands_uti.f90 \ commands_ut.f90 \ cmdline_options.f90 \ libmanager.f90 \ features.f90 \ whizard.f90 \ api.f90 \ api_hepmc_uti.f90 \ api_hepmc_ut.f90 \ api_lcio_uti.f90 \ api_lcio_ut.f90 \ api_uti.f90 \ api_ut.f90 FC_OBJ = $(FC0_SRC:.f90=.o) $(F77_SRC:.f=.o) $(FC_SRC:.f90=.o) CC_OBJ = $(CC_SRC:.c=.o) all: whizard_test check: whizard_test ./whizard_test --check resonances whizard_test: $(FC_OBJ) $(CC_OBJ) main_ut.f90 $(FC) $(FC_OBJ) $(CC_OBJ) -ldl -o $@ main_ut.f90 whizard: $(FC_OBJ) $(CC_OBJ) main.f90 $(FC) $(FC_OBJ) $(CC_OBJ) -ldl -o $@ main.f90 %.o: %.f90 $(FC) $(FCFLAGS) -c $< %.o: %.f $(FC) $(FCFLAGS) -c $< %.o: %.c $(CC) $(CCFLAGS) -c $< tar: $(FC_SRC) $(F77_SRC) $(FC0_SRC) $(CC_SRC) $(MODELS) tar cvvzf whizard-`date +%y%m%d`-`date +%H%M`.tar.gz $(FC_SRC) $(FC0_SRC) \ $(F77_SRC) $(CC_SRC) main_ut.f90 Makefile $(MODELS) clean: rm -f *.mod *.o whizard_test