Index: trunk/src/beams/beams.nw =================================================================== --- trunk/src/beams/beams.nw (revision 8334) +++ trunk/src/beams/beams.nw (revision 8335) @@ -1,25260 +1,25272 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: beams and beam structure %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Beams} \includemodulegraph{beams} These modules implement beam configuration and beam structure, the latter in abstract terms. \begin{description} \item[beam\_structures] The [[beam_structure_t]] type is a messenger type that communicates the user settings to the \whizard\ core. \item[beams] Beam configuration. \item[sf\_aux] Tools for handling structure functions and splitting \item[sf\_mappings] Mapping functions, useful for structure function implementation \item[sf\_base] The abstract structure-function interaction and structure-function chain types. \end{description} These are the implementation modules, the concrete counterparts of [[sf_base]]: \begin{description} \item[sf\_isr] ISR structure function (photon radiation inclusive and resummed in collinear and IR regions). \item[sf\_epa] Effective Photon Approximation. \item[sf\_ewa] Effective $W$ (and $Z$) approximation. \item[sf\_escan] Energy spectrum that emulates a uniform energy scan. \item[sf\_gaussian] Gaussian beam spread \item[sf\_beam\_events] Beam-event generator that reads its input from an external file. \item[sf\_circe1] CIRCE1 beam spectra for electrons and photons. \item[sf\_circe2] CIRCE2 beam spectra for electrons and photons. \item[hoppet\_interface] Support for $b$-quark matching, addon to PDF modules. \item[sf\_pdf\_builtin] Direct support for selected hadron PDFs. \item[sf\_lhapdf] LHAPDF library support. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Beam structure} This module stores the beam structure definition as it is declared in the SINDARIN script. The structure definition is not analyzed, just recorded for later use. We do not capture any numerical parameters, just names of particles and structure functions. <<[[beam_structures.f90]]>>= <> module beam_structures <> <> use io_units use format_defs, only: FMT_19 use diagnostics use lorentz use polarizations <> <> <> <> contains <> end module beam_structures @ %def beam_structures @ \subsection{Beam structure elements} An entry in a beam-structure record consists of a string that denotes a type of structure function. <>= type :: beam_structure_entry_t logical :: is_valid = .false. type(string_t) :: name contains <> end type beam_structure_entry_t @ %def beam_structure_entry_t @ Output. <>= procedure :: to_string => beam_structure_entry_to_string <>= function beam_structure_entry_to_string (object) result (string) class(beam_structure_entry_t), intent(in) :: object type(string_t) :: string if (object%is_valid) then string = object%name else string = "none" end if end function beam_structure_entry_to_string @ %def beam_structure_entry_to_string @ A record in the beam-structure sequence denotes either a structure-function entry, a pair of such entries, or a pair spectrum. <>= type :: beam_structure_record_t type(beam_structure_entry_t), dimension(:), allocatable :: entry end type beam_structure_record_t @ %def beam_structure_record_t @ \subsection{Beam structure type} The beam-structure object contains the beam particle(s) as simple strings. The sequence of records indicates the structure functions by name. No numerical parameters are stored. <>= public :: beam_structure_t <>= type :: beam_structure_t private integer :: n_beam = 0 type(string_t), dimension(:), allocatable :: prt type(beam_structure_record_t), dimension(:), allocatable :: record type(smatrix_t), dimension(:), allocatable :: smatrix real(default), dimension(:), allocatable :: pol_f real(default), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: theta real(default), dimension(:), allocatable :: phi contains <> end type beam_structure_t @ %def beam_structure_t @ The finalizer deletes all contents explicitly, so we can continue with an empty beam record. (It is not needed for deallocation.) We have distinct finalizers for the independent parts of the beam structure. <>= procedure :: final_sf => beam_structure_final_sf <>= subroutine beam_structure_final_sf (object) class(beam_structure_t), intent(inout) :: object if (allocated (object%prt)) deallocate (object%prt) if (allocated (object%record)) deallocate (object%record) object%n_beam = 0 end subroutine beam_structure_final_sf @ %def beam_structure_final_sf @ Output. The actual information fits in a single line, therefore we can provide a [[to_string]] method. The [[show]] method also lists the current values of relevant global variables. <>= procedure :: write => beam_structure_write procedure :: to_string => beam_structure_to_string <>= subroutine beam_structure_write (object, unit) class(beam_structure_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A,A)") "Beam structure: ", char (object%to_string ()) if (allocated (object%smatrix)) then do i = 1, size (object%smatrix) write (u, "(3x,A,I0,A)") "polarization (beam ", i, "):" call object%smatrix(i)%write (u, indent=2) end do end if if (allocated (object%pol_f)) then write (u, "(3x,A,F10.7,:,',',F10.7)") "polarization degree =", & object%pol_f end if if (allocated (object%p)) then write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // & ")") "momentum =", object%p end if if (allocated (object%theta)) then write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // & ")") "angle th =", object%theta end if if (allocated (object%phi)) then write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // & ")") "angle ph =", object%phi end if end subroutine beam_structure_write function beam_structure_to_string (object, sf_only) result (string) class(beam_structure_t), intent(in) :: object logical, intent(in), optional :: sf_only type(string_t) :: string integer :: i, j logical :: with_beams with_beams = .true.; if (present (sf_only)) with_beams = .not. sf_only select case (object%n_beam) case (1) if (with_beams) then string = object%prt(1) else string = "" end if case (2) if (with_beams) then string = object%prt(1) // ", " // object%prt(2) else string = "" end if if (allocated (object%record)) then if (size (object%record) > 0) then if (with_beams) string = string // " => " do i = 1, size (object%record) if (i > 1) string = string // " => " do j = 1, size (object%record(i)%entry) if (j > 1) string = string // ", " string = string // object%record(i)%entry(j)%to_string () end do end do end if end if case default string = "[any particles]" end select end function beam_structure_to_string @ %def beam_structure_write beam_structure_to_string @ Initializer: dimension the beam structure record. Each array element denotes the number of entries for a record within the beam-structure sequence. The number of entries is either one or two, while the number of records is unlimited. <>= procedure :: init_sf => beam_structure_init_sf <>= subroutine beam_structure_init_sf (beam_structure, prt, dim_array) class(beam_structure_t), intent(inout) :: beam_structure type(string_t), dimension(:), intent(in) :: prt integer, dimension(:), intent(in), optional :: dim_array integer :: i call beam_structure%final_sf () beam_structure%n_beam = size (prt) allocate (beam_structure%prt (size (prt))) beam_structure%prt = prt if (present (dim_array)) then allocate (beam_structure%record (size (dim_array))) do i = 1, size (dim_array) allocate (beam_structure%record(i)%entry (dim_array(i))) end do else allocate (beam_structure%record (0)) end if end subroutine beam_structure_init_sf @ %def beam_structure_init_sf @ Set an entry, specified by record number and entry number. <>= procedure :: set_sf => beam_structure_set_sf <>= subroutine beam_structure_set_sf (beam_structure, i, j, name) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i, j type(string_t), intent(in) :: name associate (entry => beam_structure%record(i)%entry(j)) entry%name = name entry%is_valid = .true. end associate end subroutine beam_structure_set_sf @ %def beam_structure_set_sf @ Expand the beam-structure object. (i) For a pair spectrum, keep the entry. (ii) For a single-particle structure function written as a single entry, replace this by a record with two entries. (ii) For a record with two nontrivial entries, separate this into two records with one trivial entry each. To achieve this, we need a function that tells us whether an entry is a spectrum or a structure function. It returns 0 for a trivial entry, 1 for a single-particle structure function, and 2 for a two-particle spectrum. <>= abstract interface function strfun_mode_fun (name) result (n) import type(string_t), intent(in) :: name integer :: n end function strfun_mode_fun end interface @ %def is_spectrum_t @ Algorithm: (1) Mark entries as invalid where necessary. (2) Count the number of entries that we will need. (3) Expand and copy entries to a new record array. (4) Replace the old array by the new one. <>= procedure :: expand => beam_structure_expand <>= subroutine beam_structure_expand (beam_structure, strfun_mode) class(beam_structure_t), intent(inout) :: beam_structure procedure(strfun_mode_fun) :: strfun_mode type(beam_structure_record_t), dimension(:), allocatable :: new integer :: n_record, i, j if (.not. allocated (beam_structure%record)) return do i = 1, size (beam_structure%record) associate (entry => beam_structure%record(i)%entry) do j = 1, size (entry) select case (strfun_mode (entry(j)%name)) case (0); entry(j)%is_valid = .false. end select end do end associate end do n_record = 0 do i = 1, size (beam_structure%record) associate (entry => beam_structure%record(i)%entry) select case (size (entry)) case (1) if (entry(1)%is_valid) then select case (strfun_mode (entry(1)%name)) case (1); n_record = n_record + 2 case (2); n_record = n_record + 1 end select end if case (2) do j = 1, 2 if (entry(j)%is_valid) then select case (strfun_mode (entry(j)%name)) case (1); n_record = n_record + 1 case (2) call beam_structure%write () call msg_fatal ("Pair spectrum used as & &single-particle structure function") end select end if end do end select end associate end do allocate (new (n_record)) n_record = 0 do i = 1, size (beam_structure%record) associate (entry => beam_structure%record(i)%entry) select case (size (entry)) case (1) if (entry(1)%is_valid) then select case (strfun_mode (entry(1)%name)) case (1) n_record = n_record + 1 allocate (new(n_record)%entry (2)) new(n_record)%entry(1) = entry(1) n_record = n_record + 1 allocate (new(n_record)%entry (2)) new(n_record)%entry(2) = entry(1) case (2) n_record = n_record + 1 allocate (new(n_record)%entry (1)) new(n_record)%entry(1) = entry(1) end select end if case (2) do j = 1, 2 if (entry(j)%is_valid) then n_record = n_record + 1 allocate (new(n_record)%entry (2)) new(n_record)%entry(j) = entry(j) end if end do end select end associate end do call move_alloc (from = new, to = beam_structure%record) end subroutine beam_structure_expand @ %def beam_structure_expand @ \subsection{Polarization} To record polarization, we provide an allocatable array of [[smatrix]] objects, sparse matrices. The polarization structure is independent of the structure-function setup, they are combined only when an actual beam object is constructed. <>= procedure :: final_pol => beam_structure_final_pol procedure :: init_pol => beam_structure_init_pol <>= subroutine beam_structure_final_pol (beam_structure) class(beam_structure_t), intent(inout) :: beam_structure if (allocated (beam_structure%smatrix)) deallocate (beam_structure%smatrix) if (allocated (beam_structure%pol_f)) deallocate (beam_structure%pol_f) end subroutine beam_structure_final_pol subroutine beam_structure_init_pol (beam_structure, n) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: n if (allocated (beam_structure%smatrix)) deallocate (beam_structure%smatrix) allocate (beam_structure%smatrix (n)) if (.not. allocated (beam_structure%pol_f)) & allocate (beam_structure%pol_f (n), source = 1._default) end subroutine beam_structure_init_pol @ %def beam_structure_final_pol @ %def beam_structure_init_pol @ Check if polarized beams are used. <>= procedure :: has_polarized_beams => beam_structure_has_polarized_beams <>= elemental function beam_structure_has_polarized_beams (beam_structure) result (pol) logical :: pol class(beam_structure_t), intent(in) :: beam_structure if (allocated (beam_structure%pol_f)) then pol = any (beam_structure%pol_f /= 0) else pol = .false. end if end function beam_structure_has_polarized_beams @ %def beam_structure_has_polarized_beams @ Directly copy the spin density matrices. <>= procedure :: set_smatrix => beam_structure_set_smatrix <>= subroutine beam_structure_set_smatrix (beam_structure, i, smatrix) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i type(smatrix_t), intent(in) :: smatrix beam_structure%smatrix(i) = smatrix end subroutine beam_structure_set_smatrix @ %def beam_structure_set_smatrix @ Initialize one of the spin density matrices manually. <>= procedure :: init_smatrix => beam_structure_init_smatrix <>= subroutine beam_structure_init_smatrix (beam_structure, i, n_entry) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i integer, intent(in) :: n_entry call beam_structure%smatrix(i)%init (2, n_entry) end subroutine beam_structure_init_smatrix @ %def beam_structure_init_smatrix @ Set a polarization entry. <>= procedure :: set_sentry => beam_structure_set_sentry <>= subroutine beam_structure_set_sentry & (beam_structure, i, i_entry, index, value) class(beam_structure_t), intent(inout) :: beam_structure integer, intent(in) :: i integer, intent(in) :: i_entry integer, dimension(:), intent(in) :: index complex(default), intent(in) :: value call beam_structure%smatrix(i)%set_entry (i_entry, index, value) end subroutine beam_structure_set_sentry @ %def beam_structure_set_sentry @ Set the array of polarization fractions. <>= procedure :: set_pol_f => beam_structure_set_pol_f <>= subroutine beam_structure_set_pol_f (beam_structure, f) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: f if (allocated (beam_structure%pol_f)) deallocate (beam_structure%pol_f) allocate (beam_structure%pol_f (size (f)), source = f) end subroutine beam_structure_set_pol_f @ %def beam_structure_set_pol_f @ \subsection{Beam momenta} By default, beam momenta are deduced from the [[sqrts]] value or from the mass of the decaying particle, assuming a c.m.\ setup. Here we set them explicitly. <>= procedure :: final_mom => beam_structure_final_mom <>= subroutine beam_structure_final_mom (beam_structure) class(beam_structure_t), intent(inout) :: beam_structure if (allocated (beam_structure%p)) deallocate (beam_structure%p) if (allocated (beam_structure%theta)) deallocate (beam_structure%theta) if (allocated (beam_structure%phi)) deallocate (beam_structure%phi) end subroutine beam_structure_final_mom @ %def beam_structure_final_mom <>= procedure :: set_momentum => beam_structure_set_momentum procedure :: set_theta => beam_structure_set_theta procedure :: set_phi => beam_structure_set_phi <>= subroutine beam_structure_set_momentum (beam_structure, p) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: p if (allocated (beam_structure%p)) deallocate (beam_structure%p) allocate (beam_structure%p (size (p)), source = p) end subroutine beam_structure_set_momentum subroutine beam_structure_set_theta (beam_structure, theta) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: theta if (allocated (beam_structure%theta)) deallocate (beam_structure%theta) allocate (beam_structure%theta (size (theta)), source = theta) end subroutine beam_structure_set_theta subroutine beam_structure_set_phi (beam_structure, phi) class(beam_structure_t), intent(inout) :: beam_structure real(default), dimension(:), intent(in) :: phi if (allocated (beam_structure%phi)) deallocate (beam_structure%phi) allocate (beam_structure%phi (size (phi)), source = phi) end subroutine beam_structure_set_phi @ %def beam_structure_set_momentum @ %def beam_structure_set_theta @ %def beam_structure_set_phi @ \subsection{Get contents} Look at the incoming particles. We may also have the case that beam particles are not specified, but polarization. <>= procedure :: is_set => beam_structure_is_set procedure :: get_n_beam => beam_structure_get_n_beam procedure :: get_prt => beam_structure_get_prt <>= function beam_structure_is_set (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag flag = beam_structure%n_beam > 0 .or. beam_structure%asymmetric () end function beam_structure_is_set function beam_structure_get_n_beam (beam_structure) result (n) class(beam_structure_t), intent(in) :: beam_structure integer :: n n = beam_structure%n_beam end function beam_structure_get_n_beam function beam_structure_get_prt (beam_structure) result (prt) class(beam_structure_t), intent(in) :: beam_structure type(string_t), dimension(:), allocatable :: prt allocate (prt (size (beam_structure%prt))) prt = beam_structure%prt end function beam_structure_get_prt @ %def beam_structure_is_set @ %def beam_structure_get_n_beam @ %def beam_structure_get_prt @ Return the number of records. <>= procedure :: get_n_record => beam_structure_get_n_record <>= function beam_structure_get_n_record (beam_structure) result (n) class(beam_structure_t), intent(in) :: beam_structure integer :: n if (allocated (beam_structure%record)) then n = size (beam_structure%record) else n = 0 end if end function beam_structure_get_n_record @ %def beam_structure_get_n_record @ Return an array consisting of the beam indices affected by the valid entries within a record. After expansion, there should be exactly one valid entry per record. <>= procedure :: get_i_entry => beam_structure_get_i_entry <>= function beam_structure_get_i_entry (beam_structure, i) result (i_entry) class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: i integer, dimension(:), allocatable :: i_entry associate (record => beam_structure%record(i)) select case (size (record%entry)) case (1) if (record%entry(1)%is_valid) then allocate (i_entry (2), source = [1, 2]) else allocate (i_entry (0)) end if case (2) if (all (record%entry%is_valid)) then allocate (i_entry (2), source = [1, 2]) else if (record%entry(1)%is_valid) then allocate (i_entry (1), source = [1]) else if (record%entry(2)%is_valid) then allocate (i_entry (1), source = [2]) else allocate (i_entry (0)) end if end select end associate end function beam_structure_get_i_entry @ %def beam_structure_get_i_entry @ Return the name of the first valid entry within a record. After expansion, there should be exactly one valid entry per record. <>= procedure :: get_name => beam_structure_get_name <>= function beam_structure_get_name (beam_structure, i) result (name) type(string_t) :: name class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: i associate (record => beam_structure%record(i)) if (record%entry(1)%is_valid) then name = record%entry(1)%name else if (size (record%entry) == 2) then name = record%entry(2)%name end if end associate end function beam_structure_get_name @ %def beam_structure_get_name @ <>= procedure :: has_pdf => beam_structure_has_pdf <>= function beam_structure_has_pdf (beam_structure) result (has_pdf) logical :: has_pdf class(beam_structure_t), intent(in) :: beam_structure integer :: i type(string_t) :: name has_pdf = .false. do i = 1, beam_structure%get_n_record () name = beam_structure%get_name (i) has_pdf = has_pdf .or. name == var_str ("pdf_builtin") .or. name == var_str ("lhapdf") end do end function beam_structure_has_pdf @ %def beam_structure_has_pdf @ Return true if the beam structure contains a particular structure function identifier (such as [[lhapdf]], [[isr]], etc.) <>= procedure :: contains => beam_structure_contains <>= function beam_structure_contains (beam_structure, name) result (flag) class(beam_structure_t), intent(in) :: beam_structure character(*), intent(in) :: name logical :: flag integer :: i, j flag = .false. if (allocated (beam_structure%record)) then do i = 1, size (beam_structure%record) do j = 1, size (beam_structure%record(i)%entry) flag = beam_structure%record(i)%entry(j)%name == name if (flag) return end do end do end if end function beam_structure_contains @ %def beam_structure_contains @ Return polarization data. <>= procedure :: polarized => beam_structure_polarized procedure :: get_smatrix => beam_structure_get_smatrix procedure :: get_pol_f => beam_structure_get_pol_f procedure :: asymmetric => beam_structure_asymmetric <>= function beam_structure_polarized (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag flag = allocated (beam_structure%smatrix) end function beam_structure_polarized function beam_structure_get_smatrix (beam_structure) result (smatrix) class(beam_structure_t), intent(in) :: beam_structure type(smatrix_t), dimension(:), allocatable :: smatrix allocate (smatrix (size (beam_structure%smatrix)), & source = beam_structure%smatrix) end function beam_structure_get_smatrix function beam_structure_get_pol_f (beam_structure) result (pol_f) class(beam_structure_t), intent(in) :: beam_structure real(default), dimension(:), allocatable :: pol_f allocate (pol_f (size (beam_structure%pol_f)), & source = beam_structure%pol_f) end function beam_structure_get_pol_f function beam_structure_asymmetric (beam_structure) result (flag) class(beam_structure_t), intent(in) :: beam_structure logical :: flag flag = allocated (beam_structure%p) & .or. allocated (beam_structure%theta) & .or. allocated (beam_structure%phi) end function beam_structure_asymmetric @ %def beam_structure_polarized @ %def beam_structure_get_smatrix @ %def beam_structure_get_pol_f @ %def beam_structure_asymmetric @ Return the beam momenta (the space part, i.e., three-momenta). This is meaningful only if momenta and, optionally, angles have been set. <>= procedure :: get_momenta => beam_structure_get_momenta <>= function beam_structure_get_momenta (beam_structure) result (p) class(beam_structure_t), intent(in) :: beam_structure type(vector3_t), dimension(:), allocatable :: p real(default), dimension(:), allocatable :: theta, phi integer :: n, i if (allocated (beam_structure%p)) then n = size (beam_structure%p) if (allocated (beam_structure%theta)) then if (size (beam_structure%theta) == n) then allocate (theta (n), source = beam_structure%theta) else call msg_fatal ("Beam structure: mismatch in momentum vs. & &angle theta specification") end if else allocate (theta (n), source = 0._default) end if if (allocated (beam_structure%phi)) then if (size (beam_structure%phi) == n) then allocate (phi (n), source = beam_structure%phi) else call msg_fatal ("Beam structure: mismatch in momentum vs. & &angle phi specification") end if else allocate (phi (n), source = 0._default) end if allocate (p (n)) do i = 1, n p(i) = beam_structure%p(i) * vector3_moving ([ & sin (theta(i)) * cos (phi(i)), & sin (theta(i)) * sin (phi(i)), & cos (theta(i))]) end do if (n == 2) p(2) = - p(2) else call msg_fatal ("Beam structure: angle theta/phi specified but & &momentum/a p undefined") end if end function beam_structure_get_momenta @ %def beam_structure_get_momenta @ Check for a complete beam structure. The [[applies]] flag tells if the beam structure should actually be used for a process with the given [[n_in]] number of incoming particles. It set if the beam structure matches the process as either decay or scattering. It is unset if beam structure references a scattering setup but the process is a decay. It is also unset if the beam structure itself is empty. If the beam structure cannot be used, terminate with fatal error. <>= procedure :: check_against_n_in => beam_structure_check_against_n_in <>= subroutine beam_structure_check_against_n_in (beam_structure, n_in, applies) class(beam_structure_t), intent(in) :: beam_structure integer, intent(in) :: n_in logical, intent(out) :: applies if (beam_structure%is_set ()) then if (n_in == beam_structure%get_n_beam ()) then applies = .true. else if (beam_structure%get_n_beam () == 0) then call msg_fatal & ("Asymmetric beams: missing beam particle specification") applies = .false. else call msg_fatal & ("Mismatch of process and beam setup (scattering/decay)") applies = .false. end if else applies = .false. end if end subroutine beam_structure_check_against_n_in @ %def beam_structure_check_against_n_in @ \subsection{Unit Tests} Test module, followed by the corresponding implementation module. <<[[beam_structures_ut.f90]]>>= <> module beam_structures_ut use unit_tests use beam_structures_uti <> <> contains <> end module beam_structures_ut @ %def beam_structures_ut @ <<[[beam_structures_uti.f90]]>>= <> module beam_structures_uti <> <> use beam_structures <> <> contains <> <> end module beam_structures_uti @ %def beam_structures_ut @ API: driver for the unit tests below. <>= public :: beam_structures_test <>= subroutine beam_structures_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine beam_structures_test @ %def beam_structures_tests @ \subsubsection{Empty structure} <>= call test (beam_structures_1, "beam_structures_1", & "empty beam structure record", & u, results) <>= public :: beam_structures_1 <>= subroutine beam_structures_1 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure write (u, "(A)") "* Test output: beam_structures_1" write (u, "(A)") "* Purpose: display empty beam structure record" write (u, "(A)") call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_1" end subroutine beam_structures_1 @ %def beam_structures_1 @ \subsubsection{Nontrivial configurations} <>= call test (beam_structures_2, "beam_structures_2", & "beam structure records", & u, results) <>= public :: beam_structures_2 <>= subroutine beam_structures_2 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure integer, dimension(0) :: empty_array type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_2" write (u, "(A)") "* Purpose: setup beam structure records" write (u, "(A)") s = "s" call beam_structure%init_sf ([s], empty_array) call beam_structure%write (u) write (u, "(A)") call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%write (u) write (u, "(A)") call beam_structure%init_sf ([s, s], [2]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (1, 2, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%init_sf ([s, s], [2, 1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (1, 2, var_str ("b")) call beam_structure%set_sf (2, 1, var_str ("c")) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_2" end subroutine beam_structures_2 @ %def beam_structures_2 @ \subsubsection{Expansion} Provide a function that tells, for the dummy structure function names used here, whether they are considered a two-particle spectrum or a single-particle structure function: <>= function test_strfun_mode (name) result (n) type(string_t), intent(in) :: name integer :: n select case (char (name)) case ("a"); n = 2 case ("b"); n = 1 case default; n = 0 end select end function test_strfun_mode @ %def test_ist_pair_spectrum @ <>= call test (beam_structures_3, "beam_structures_3", & "beam structure expansion", & u, results) <>= public :: beam_structures_3 <>= subroutine beam_structures_3 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_3" write (u, "(A)") "* Purpose: expand beam structure records" write (u, "(A)") s = "s" write (u, "(A)") "* Pair spectrum (keep as-is)" write (u, "(A)") call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Structure function pair (expand)" write (u, "(A)") call beam_structure%init_sf ([s, s], [2]) call beam_structure%set_sf (1, 1, var_str ("b")) call beam_structure%set_sf (1, 2, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Structure function (separate and expand)" write (u, "(A)") call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Combination" write (u, "(A)") call beam_structure%init_sf ([s, s], [1, 1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (2, 1, var_str ("b")) call beam_structure%write (u) write (u, "(A)") call beam_structure%expand (test_strfun_mode) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_3" end subroutine beam_structures_3 @ %def beam_structures_3 @ \subsubsection{Public methods} Check the methods that can be called to get the beam-structure contents. <>= call test (beam_structures_4, "beam_structures_4", & "beam structure contents", & u, results) <>= public :: beam_structures_4 <>= subroutine beam_structures_4 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure type(string_t) :: s type(string_t), dimension(2) :: prt integer :: i write (u, "(A)") "* Test output: beam_structures_4" write (u, "(A)") "* Purpose: check the API" write (u, "(A)") s = "s" write (u, "(A)") "* Structure-function combination" write (u, "(A)") call beam_structure%init_sf ([s, s], [1, 2, 2]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%set_sf (2, 1, var_str ("b")) call beam_structure%set_sf (3, 2, var_str ("c")) call beam_structure%write (u) write (u, *) write (u, "(1x,A,I0)") "n_beam = ", beam_structure%get_n_beam () prt = beam_structure%get_prt () write (u, "(1x,A,2(1x,A))") "prt =", char (prt(1)), char (prt(2)) write (u, *) write (u, "(1x,A,I0)") "n_record = ", beam_structure%get_n_record () do i = 1, 3 write (u, "(A)") write (u, "(1x,A,I0,A,A)") "name(", i, ") = ", & char (beam_structure%get_name (i)) write (u, "(1x,A,I0,A,2(1x,I0))") "i_entry(", i, ") =", & beam_structure%get_i_entry (i) end do write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_4" end subroutine beam_structures_4 @ %def beam_structures_4 @ \subsubsection{Polarization} The polarization properties are independent from the structure-function setup. <>= call test (beam_structures_5, "beam_structures_5", & "polarization", & u, results) <>= public :: beam_structures_5 <>= subroutine beam_structures_5 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure integer, dimension(0) :: empty_array type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_5" write (u, "(A)") "* Purpose: setup polarization in beam structure records" write (u, "(A)") s = "s" call beam_structure%init_sf ([s], empty_array) call beam_structure%init_pol (1) call beam_structure%init_smatrix (1, 1) call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default)) call beam_structure%set_pol_f ([0.5_default]) call beam_structure%write (u) write (u, "(A)") call beam_structure%final_sf () call beam_structure%final_pol () call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_sf (1, 1, var_str ("a")) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 2) call beam_structure%set_sentry (1, 1, [-1,1], (0.5_default,-0.5_default)) call beam_structure%set_sentry (1, 2, [ 1,1], (1._default, 0._default)) call beam_structure%init_smatrix (2, 0) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_5" end subroutine beam_structures_5 @ %def beam_structures_5 @ \subsubsection{Momenta} The momenta are independent from the structure-function setup. <>= call test (beam_structures_6, "beam_structures_6", & "momenta", & u, results) <>= public :: beam_structures_6 <>= subroutine beam_structures_6 (u) integer, intent(in) :: u type(beam_structure_t) :: beam_structure integer, dimension(0) :: empty_array type(string_t) :: s write (u, "(A)") "* Test output: beam_structures_6" write (u, "(A)") "* Purpose: setup momenta in beam structure records" write (u, "(A)") s = "s" call beam_structure%init_sf ([s], empty_array) call beam_structure%set_momentum ([500._default]) call beam_structure%write (u) write (u, "(A)") call beam_structure%final_sf () call beam_structure%final_mom () call beam_structure%init_sf ([s, s], [1]) call beam_structure%set_momentum ([500._default, 700._default]) call beam_structure%set_theta ([0._default, 0.1_default]) call beam_structure%set_phi ([0._default, 1.51_default]) call beam_structure%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: beam_structures_6" end subroutine beam_structures_6 @ %def beam_structures_6 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Beams for collisions and decays} <<[[beams.f90]]>>= <> module beams <> <> use io_units use format_defs, only: FMT_19 use numeric_utils use diagnostics use md5 use lorentz use model_data use flavors use quantum_numbers use state_matrices use interactions use polarizations use beam_structures <> <> <> <> contains <> end module beams @ %def beams @ \subsection{Beam data} The beam data type contains beam data for one or two beams, depending on whether we are dealing with beam collisions or particle decay. In addition, it holds the c.m.\ energy [[sqrts]], the Lorentz transformation [[L]] that transforms the c.m.\ system into the lab system, and the pair of c.m.\ momenta. <>= public :: beam_data_t <>= type :: beam_data_t logical :: initialized = .false. integer :: n = 0 type(flavor_t), dimension(:), allocatable :: flv real(default), dimension(:), allocatable :: mass type(pmatrix_t), dimension(:), allocatable :: pmatrix logical :: lab_is_cm_frame = .true. type(vector4_t), dimension(:), allocatable :: p_cm type(vector4_t), dimension(:), allocatable :: p type(lorentz_transformation_t), allocatable :: L_cm_to_lab real(default) :: sqrts = 0 character(32) :: md5sum = "" contains <> end type beam_data_t @ %def beam_data_t @ Generic initializer. This is called by the specific initializers below. Initialize either for decay or for collision. <>= subroutine beam_data_init (beam_data, n) type(beam_data_t), intent(out) :: beam_data integer, intent(in) :: n beam_data%n = n allocate (beam_data%flv (n)) allocate (beam_data%mass (n)) allocate (beam_data%pmatrix (n)) allocate (beam_data%p_cm (n)) allocate (beam_data%p (n)) beam_data%initialized = .true. end subroutine beam_data_init @ %def beam_data_init @ Finalizer: needed for the polarization components of the beams. <>= procedure :: final => beam_data_final <>= subroutine beam_data_final (beam_data) class(beam_data_t), intent(inout) :: beam_data beam_data%initialized = .false. end subroutine beam_data_final @ %def beam_data_final @ The verbose (default) version is for debugging. The short version is for screen output in the UI. <>= procedure :: write => beam_data_write <>= subroutine beam_data_write (beam_data, unit, verbose, write_md5sum) class(beam_data_t), intent(in) :: beam_data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, write_md5sum integer :: prt_name_len logical :: verb, write_md5 integer :: u u = given_output_unit (unit); if (u < 0) return verb = .false.; if (present (verbose)) verb = verbose write_md5 = verb; if (present (write_md5sum)) write_md5 = write_md5sum if (.not. beam_data%initialized) then write (u, "(1x,A)") "Beam data: [undefined]" return end if prt_name_len = maxval (len (beam_data%flv%get_name ())) select case (beam_data%n) case (1) write (u, "(1x,A)") "Beam data (decay):" if (verb) then call write_prt (1) call beam_data%pmatrix(1)%write (u) write (u, *) "R.f. momentum:" call vector4_write (beam_data%p_cm(1), u) write (u, *) "Lab momentum:" call vector4_write (beam_data%p(1), u) else call write_prt (1) end if case (2) write (u, "(1x,A)") "Beam data (collision):" if (verb) then call write_prt (1) call beam_data%pmatrix(1)%write (u) call write_prt (2) call beam_data%pmatrix(2)%write (u) call write_sqrts write (u, *) "C.m. momenta:" call vector4_write (beam_data%p_cm(1), u) call vector4_write (beam_data%p_cm(2), u) write (u, *) "Lab momenta:" call vector4_write (beam_data%p(1), u) call vector4_write (beam_data%p(2), u) else call write_prt (1) call write_prt (2) call write_sqrts end if end select if (allocated (beam_data%L_cm_to_lab)) then if (verb) then call lorentz_transformation_write (beam_data%L_cm_to_lab, u) else write (u, "(1x,A)") "Beam structure: lab and c.m. frame differ" end if end if if (write_md5) then write (u, *) "MD5 sum: ", beam_data%md5sum end if contains subroutine write_sqrts character(80) :: sqrts_str write (sqrts_str, "(" // FMT_19 // ")") beam_data%sqrts write (u, "(3x,A)") "sqrts = " // trim (adjustl (sqrts_str)) // " GeV" end subroutine write_sqrts subroutine write_prt (i) integer, intent(in) :: i character(80) :: name_str, mass_str write (name_str, "(A)") char (beam_data%flv(i)%get_name ()) write (mass_str, "(ES13.7)") beam_data%mass(i) write (u, "(3x,A)", advance="no") & name_str(:prt_name_len) // " (mass = " & // trim (adjustl (mass_str)) // " GeV)" if (beam_data%pmatrix(i)%is_polarized ()) then write (u, "(2x,A)") "polarized" else write (u, *) end if end subroutine write_prt end subroutine beam_data_write @ %def beam_data_write @ Return initialization status: <>= procedure :: are_valid => beam_data_are_valid <>= function beam_data_are_valid (beam_data) result (flag) class(beam_data_t), intent(in) :: beam_data logical :: flag flag = beam_data%initialized end function beam_data_are_valid @ %def beam_data_are_valid @ Check whether beam data agree with the current values of relevant parameters. <>= procedure :: check_scattering => beam_data_check_scattering <>= subroutine beam_data_check_scattering (beam_data, sqrts) class(beam_data_t), intent(in) :: beam_data real(default), intent(in), optional :: sqrts if (beam_data_are_valid (beam_data)) then if (present (sqrts)) then if (.not. nearly_equal (sqrts, beam_data%sqrts)) then call msg_error ("Current setting of sqrts is inconsistent " & // "with beam setup (ignored).") end if end if else call msg_bug ("Beam setup: invalid beam data") end if end subroutine beam_data_check_scattering @ %def beam_data_check_scattering @ Return the number of beams (1 for decays, 2 for collisions). <>= procedure :: get_n_in => beam_data_get_n_in <>= function beam_data_get_n_in (beam_data) result (n_in) class(beam_data_t), intent(in) :: beam_data integer :: n_in n_in = beam_data%n end function beam_data_get_n_in @ %def beam_data_get_n_in @ Return the beam flavor <>= procedure :: get_flavor => beam_data_get_flavor <>= function beam_data_get_flavor (beam_data) result (flv) class(beam_data_t), intent(in) :: beam_data type(flavor_t), dimension(:), allocatable :: flv allocate (flv (beam_data%n)) flv = beam_data%flv end function beam_data_get_flavor @ %def beam_data_get_flavor @ Return the beam energies <>= procedure :: get_energy => beam_data_get_energy <>= function beam_data_get_energy (beam_data) result (e) class(beam_data_t), intent(in) :: beam_data real(default), dimension(:), allocatable :: e integer :: i allocate (e (beam_data%n)) if (beam_data%initialized) then do i = 1, beam_data%n e(i) = energy (beam_data%p(i)) end do else e = 0 end if end function beam_data_get_energy @ %def beam_data_get_energy @ Return the c.m.\ energy. <>= procedure :: get_sqrts => beam_data_get_sqrts <>= function beam_data_get_sqrts (beam_data) result (sqrts) class(beam_data_t), intent(in) :: beam_data real(default) :: sqrts sqrts = beam_data%sqrts end function beam_data_get_sqrts @ %def beam_data_get_sqrts @ Return true if the lab and c.m.\ frame are specified as identical. <>= procedure :: cm_frame => beam_data_cm_frame <>= function beam_data_cm_frame (beam_data) result (flag) class(beam_data_t), intent(in) :: beam_data logical :: flag flag = beam_data%lab_is_cm_frame end function beam_data_cm_frame @ %def beam_data_cm_frame @ Return the polarization in case it is just two degrees <>= procedure :: get_polarization => beam_data_get_polarization <>= function beam_data_get_polarization (beam_data) result (pol) class(beam_data_t), intent(in) :: beam_data real(default), dimension(2) :: pol if (beam_data%n /= 2) & call msg_fatal ("Beam data: can only treat scattering processes.") pol = beam_data%pmatrix%get_simple_pol () end function beam_data_get_polarization @ %def beam_data_get_polarization @ <>= procedure :: get_helicity_state_matrix => beam_data_get_helicity_state_matrix <>= function beam_data_get_helicity_state_matrix (beam_data) result (state_hel) type(state_matrix_t) :: state_hel class(beam_data_t), intent(in) :: beam_data type(polarization_t), dimension(:), allocatable :: pol integer :: i allocate (pol (beam_data%n)) do i = 1, beam_data%n call pol(i)%init_pmatrix (beam_data%pmatrix(i)) end do call combine_polarization_states (pol, state_hel) end function beam_data_get_helicity_state_matrix @ %def beam_data_get_helicity_state_matrix @ <>= procedure :: is_initialized => beam_data_is_initialized <>= function beam_data_is_initialized (beam_data) result (initialized) logical :: initialized class(beam_data_t), intent(in) :: beam_data initialized = any (beam_data%pmatrix%exists ()) end function beam_data_is_initialized @ %def beam_data_is_initialized @ Return a MD5 checksum for beam data. If no checksum is present (because beams have not been initialized), compute the checksum of the sqrts value. <>= procedure :: get_md5sum => beam_data_get_md5sum <>= function beam_data_get_md5sum (beam_data, sqrts) result (md5sum_beams) class(beam_data_t), intent(in) :: beam_data real(default), intent(in) :: sqrts character(32) :: md5sum_beams character(80) :: buffer if (beam_data%md5sum /= "") then md5sum_beams = beam_data%md5sum else write (buffer, *) sqrts md5sum_beams = md5sum (buffer) end if end function beam_data_get_md5sum @ %def beam_data_get_md5sum @ \subsection{Initializers: beam structure} Initialize the beam data object from a beam structure object, given energy and model. <>= procedure :: init_structure => beam_data_init_structure <>= subroutine beam_data_init_structure & (beam_data, structure, sqrts, model, decay_rest_frame) class(beam_data_t), intent(out) :: beam_data type(beam_structure_t), intent(in) :: structure integer :: n_beam real(default), intent(in) :: sqrts class(model_data_t), intent(in), target :: model logical, intent(in), optional :: decay_rest_frame type(flavor_t), dimension(:), allocatable :: flv n_beam = structure%get_n_beam () allocate (flv (n_beam)) call flv%init (structure%get_prt (), model) if (structure%asymmetric ()) then if (structure%polarized ()) then call beam_data%init_momenta (structure%get_momenta (), flv, & structure%get_smatrix (), structure%get_pol_f ()) else call beam_data%init_momenta (structure%get_momenta (), flv) end if else select case (n_beam) case (1) if (structure%polarized ()) then call beam_data%init_decay (flv, & structure%get_smatrix (), structure%get_pol_f (), & rest_frame = decay_rest_frame) else call beam_data%init_decay (flv, & rest_frame = decay_rest_frame) end if case (2) if (structure%polarized ()) then call beam_data%init_sqrts (sqrts, flv, & structure%get_smatrix (), structure%get_pol_f ()) else call beam_data%init_sqrts (sqrts, flv) end if case default call msg_bug ("Beam data: invalid beam structure object") end select end if end subroutine beam_data_init_structure @ %def beam_data_init_structure @ \subsection{Initializers: collisions} This is the simplest one: just the two flavors, c.m.\ energy, polarization. Color is inferred from flavor. Beam momenta and c.m.\ momenta coincide. <>= procedure :: init_sqrts => beam_data_init_sqrts <>= subroutine beam_data_init_sqrts (beam_data, sqrts, flv, smatrix, pol_f) class(beam_data_t), intent(out) :: beam_data real(default), intent(in) :: sqrts type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f real(default), dimension(size(flv)) :: E, p call beam_data_init (beam_data, size (flv)) beam_data%sqrts = sqrts beam_data%lab_is_cm_frame = .true. select case (beam_data%n) case (1) E = sqrts; p = 0 beam_data%p_cm = vector4_moving (E, p, 3) beam_data%p = beam_data%p_cm case (2) beam_data%p_cm = colliding_momenta (sqrts, flv%get_mass ()) beam_data%p = colliding_momenta (sqrts, flv%get_mass ()) end select call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f) end subroutine beam_data_init_sqrts @ %def beam_data_init_sqrts @ This version sets beam momenta directly, assuming that they are asymmetric, i.e., lab frame and c.m.\ frame do not coincide. Polarization info is deferred to a common initializer. The Lorentz transformation that we compute here is not actually used in the calculation; instead, it will be recomputed for each event in the subroutine [[phs_set_incoming_momenta]]. We compute it here for the nominal beam setup nevertheless, so we can print it and, in particular, include it in the MD5 sum. <>= procedure :: init_momenta => beam_data_init_momenta <>= subroutine beam_data_init_momenta (beam_data, p3, flv, smatrix, pol_f) class(beam_data_t), intent(out) :: beam_data type(vector3_t), dimension(:), intent(in) :: p3 type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f type(vector4_t) :: p0 type(vector4_t), dimension(:), allocatable :: p, p_cm_rot real(default), dimension(size(p3)) :: e real(default), dimension(size(flv)) :: m type(lorentz_transformation_t) :: L_boost, L_rot call beam_data_init (beam_data, size (flv)) m = flv%get_mass () e = sqrt (p3 ** 2 + m ** 2) allocate (p (beam_data%n)) p = vector4_moving (e, p3) p0 = sum (p) beam_data%p = p beam_data%lab_is_cm_frame = .false. beam_data%sqrts = p0 ** 1 L_boost = boost (p0, beam_data%sqrts) allocate (p_cm_rot (beam_data%n)) p_cm_rot = inverse (L_boost) * p allocate (beam_data%L_cm_to_lab) select case (beam_data%n) case (1) beam_data%L_cm_to_lab = L_boost beam_data%p_cm = vector4_at_rest (beam_data%sqrts) case (2) L_rot = rotation_to_2nd (3, space_part (p_cm_rot(1))) beam_data%L_cm_to_lab = L_boost * L_rot beam_data%p_cm = & colliding_momenta (beam_data%sqrts, flv%get_mass ()) end select call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f) end subroutine beam_data_init_momenta @ %def beam_data_init_momenta @ Final steps: If requested, rotate the beams in the lab frame, and set the beam-data components. <>= subroutine beam_data_finish_initialization (beam_data, flv, smatrix, pol_f) type(beam_data_t), intent(inout) :: beam_data type(flavor_t), dimension(:), intent(in) :: flv type(smatrix_t), dimension(:), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f integer :: i do i = 1, beam_data%n beam_data%flv(i) = flv(i) beam_data%mass(i) = flv(i)%get_mass () if (present (smatrix)) then if (size (smatrix) /= beam_data%n) & call msg_fatal ("Beam data: & &polarization density array has wrong dimension") beam_data%pmatrix(i) = smatrix(i) if (present (pol_f)) then if (size (pol_f) /= size (smatrix)) & call msg_fatal ("Beam data: & &polarization fraction array has wrong dimension") call beam_data%pmatrix(i)%normalize (flv(i), pol_f(i)) else call beam_data%pmatrix(i)%normalize (flv(i), 1._default) end if else call beam_data%pmatrix(i)%init (2, 0) call beam_data%pmatrix(i)%normalize (flv(i), 0._default) end if end do call beam_data%compute_md5sum () end subroutine beam_data_finish_initialization @ %def beam_data_finish_initialization @ The MD5 sum is stored within the beam-data record, so it can be checked for integrity in subsequent runs. <>= procedure :: compute_md5sum => beam_data_compute_md5sum <>= subroutine beam_data_compute_md5sum (beam_data) class(beam_data_t), intent(inout) :: beam_data integer :: unit unit = free_unit () open (unit = unit, status = "scratch", action = "readwrite") call beam_data%write (unit, write_md5sum = .false., & verbose = .true.) rewind (unit) beam_data%md5sum = md5sum (unit) close (unit) end subroutine beam_data_compute_md5sum @ %def beam_data_compute_md5sum @ \subsection{Initializers: decays} This is the simplest one: decay in rest frame. We need just flavor and polarization. Color is inferred from flavor. Beam momentum and c.m.\ momentum coincide. <>= procedure :: init_decay => beam_data_init_decay <>= subroutine beam_data_init_decay (beam_data, flv, smatrix, pol_f, rest_frame) class(beam_data_t), intent(out) :: beam_data type(flavor_t), dimension(1), intent(in) :: flv type(smatrix_t), dimension(1), intent(in), optional :: smatrix real(default), dimension(:), intent(in), optional :: pol_f logical, intent(in), optional :: rest_frame real(default), dimension(1) :: m m = flv%get_mass () if (present (smatrix)) then call beam_data%init_sqrts (m(1), flv, smatrix, pol_f) else call beam_data%init_sqrts (m(1), flv, smatrix, pol_f) end if if (present (rest_frame)) beam_data%lab_is_cm_frame = rest_frame end subroutine beam_data_init_decay @ %def beam_data_init_decay @ \subsection{The beams type} Beam objects are interaction objects that contain the actual beam data including polarization and density matrix. For collisions, the beam object actually contains two beams. <>= public :: beam_t <>= type :: beam_t private type(interaction_t) :: int end type beam_t @ %def beam_t @ The constructor contains code that converts beam data into the (entangled) particle-pair quantum state. First, we set the number of particles and polarization mask. (The polarization mask is handed over to all later interactions, so if helicity is diagonal or absent, this fact is used when constructing the hard-interaction events.) Then, we construct the entangled state that combines helicity, flavor and color of the two particles (where flavor and color are unique, while several helicity states are possible). Then, we transfer this state together with the associated values from the spin density matrix into the [[interaction_t]] object. Calling the [[add_state]] method of the interaction object, we keep the entries of the helicity density matrix without adding them up. This ensures that for unpolarized states, we do not normalize but end up with an $1/N$ entry, where $N$ is the initial-state multiplicity. <>= public :: beam_init <>= subroutine beam_init (beam, beam_data) type(beam_t), intent(out) :: beam type(beam_data_t), intent(in), target :: beam_data logical, dimension(beam_data%n) :: polarized, diagonal type(quantum_numbers_mask_t), dimension(beam_data%n) :: mask, mask_d type(state_matrix_t), target :: state_hel, state_fc, state_tmp type(state_iterator_t) :: it_hel, it_tmp type(quantum_numbers_t), dimension(:), allocatable :: qn complex(default) :: value real(default), parameter :: tolerance = 100 * epsilon (1._default) polarized = beam_data%pmatrix%is_polarized () diagonal = beam_data%pmatrix%is_diagonal () mask = quantum_numbers_mask (.false., .false., & mask_h = .not. polarized, & mask_hd = diagonal) mask_d = quantum_numbers_mask (.false., .false., .false., & mask_hd = polarized .and. diagonal) call beam%int%basic_init & (0, 0, beam_data%n, mask = mask, store_values = .true.) state_hel = beam_data%get_helicity_state_matrix () allocate (qn (beam_data%n)) call qn%init (beam_data%flv, color_from_flavor (beam_data%flv, 1)) call state_fc%init () call state_fc%add_state (qn) call merge_state_matrices (state_hel, state_fc, state_tmp) call it_hel%init (state_hel) call it_tmp%init (state_tmp) do while (it_hel%is_valid ()) qn = it_tmp%get_quantum_numbers () value = it_hel%get_matrix_element () if (any (qn%are_redundant (mask_d))) then ! skip off-diagonal elements for diagonal polarization else if (abs (value) <= tolerance) then ! skip zero entries else call beam%int%add_state (qn, value = value) end if call it_hel%advance () call it_tmp%advance () end do call beam%int%freeze () call beam%int%set_momenta (beam_data%p, outgoing = .true.) call state_hel%final () call state_fc%final () call state_tmp%final () end subroutine beam_init @ %def beam_init @ Finalizer: <>= public :: beam_final <>= subroutine beam_final (beam) type(beam_t), intent(inout) :: beam call beam%int%final () end subroutine beam_final @ %def beam_final @ I/O: <>= public :: beam_write <>= subroutine beam_write (beam, unit, verbose, show_momentum_sum, show_mass, col_verbose) type(beam_t), intent(in) :: beam integer, intent(in), optional :: unit logical, intent(in), optional :: verbose, show_momentum_sum, show_mass logical, intent(in), optional :: col_verbose integer :: u u = given_output_unit (unit); if (u < 0) return select case (beam%int%get_n_out ()) case (1); write (u, *) "Decaying particle:" case (2); write (u, *) "Colliding beams:" end select call beam%int%basic_write & (unit, verbose = verbose, show_momentum_sum = & show_momentum_sum, show_mass = show_mass, & col_verbose = col_verbose) end subroutine beam_write @ %def beam_write @ Defined assignment: deep copy <>= public :: assignment(=) <>= interface assignment(=) module procedure beam_assign end interface <>= subroutine beam_assign (beam_out, beam_in) type(beam_t), intent(out) :: beam_out type(beam_t), intent(in) :: beam_in beam_out%int = beam_in%int end subroutine beam_assign @ %def beam_assign @ \subsection{Inherited procedures} <>= public :: interaction_set_source_link <>= interface interaction_set_source_link module procedure interaction_set_source_link_beam end interface <>= subroutine interaction_set_source_link_beam (int, i, beam1, i1) type(interaction_t), intent(inout) :: int type(beam_t), intent(in), target :: beam1 integer, intent(in) :: i, i1 call int%set_source_link (i, beam1%int, i1) end subroutine interaction_set_source_link_beam @ %def interaction_set_source_link_beam @ \subsection{Accessing contents} Return the interaction component -- as a pointer, to avoid any copying. <>= public :: beam_get_int_ptr <>= function beam_get_int_ptr (beam) result (int) type(interaction_t), pointer :: int type(beam_t), intent(in), target :: beam int => beam%int end function beam_get_int_ptr @ %def beam_get_int_ptr @ Set beam momenta directly. (Used for cascade decays.) <>= public :: beam_set_momenta <>= subroutine beam_set_momenta (beam, p) type(beam_t), intent(inout) :: beam type(vector4_t), dimension(:), intent(in) :: p call beam%int%set_momenta (p) end subroutine beam_set_momenta @ %def beam_set_momenta @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[beams_ut.f90]]>>= <> module beams_ut use unit_tests use beams_uti <> <> contains <> end module beams_ut @ %def beams_ut @ <<[[beams_uti.f90]]>>= <> module beams_uti <> use lorentz use flavors use interactions, only: reset_interaction_counter use polarizations, only: smatrix_t use model_data use beam_structures use beams <> <> contains <> end module beams_uti @ %def beams_ut @ API: driver for the unit tests below. <>= public :: beams_test <>= subroutine beams_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine beams_test @ %def beams_test @ Test the basic beam setup. <>= call test (beam_1, "beam_1", & "check basic beam setup", & u, results) <>= public :: beam_1 <>= subroutine beam_1 (u) integer, intent(in) :: u type(beam_data_t), target :: beam_data type(beam_t) :: beam real(default) :: sqrts type(flavor_t), dimension(2) :: flv type(smatrix_t), dimension(2) :: smatrix real(default), dimension(2) :: pol_f type(model_data_t), target :: model write (u, "(A)") "* Test output: beam_1" write (u, "(A)") "* Purpose: test basic beam setup" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call reset_interaction_counter () call model%init_sm_test () write (u, "(A)") "* Unpolarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call beam_data%init_sqrts (sqrts, flv) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call beam_data%init_sqrts (sqrts, flv) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call beam_data%init_sqrts (sqrts, flv) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Polarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call smatrix(1)%init (2, 1) call smatrix(1)%set_entry (1, [1,1], (1._default, 0._default)) pol_f(1) = 0.5_default call smatrix(2)%init (2, 3) call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default)) call smatrix(2)%set_entry (2, [-1,-1], (1._default, 0._default)) call smatrix(2)%set_entry (3, [-1,1], (1._default, 0._default)) pol_f(2) = 1._default call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call smatrix(1)%init (2, 0) pol_f(1) = 0._default call smatrix(2)%init (2, 1) call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default)) pol_f(2) = 1._default call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call smatrix(1)%init (2, 0) pol_f(1) = 0._default call smatrix(2)%init (2, 1) call smatrix(2)%set_entry (1, [0,0], (1._default, 0._default)) pol_f(2) = 1._default call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call beam_data%init_decay (flv(1:1)) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Polarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call smatrix(1)%init (2, 1) call smatrix(1)%set_entry (1, [0,0], (1._default, 0._default)) pol_f(1) = 0.4_default call beam_data%init_decay (flv(1:1), smatrix(1:1), pol_f(1:1)) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call beam_final (beam) call beam_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: beam_1" end subroutine beam_1 @ %def beam_1 @ Test advanced beam setup. <>= call test (beam_2, "beam_2", & "beam initialization", & u, results) <>= public :: beam_2 <>= subroutine beam_2 (u) integer, intent(in) :: u type(beam_data_t), target :: beam_data type(beam_t) :: beam real(default) :: sqrts type(flavor_t), dimension(2) :: flv integer, dimension(0) :: no_records type(beam_structure_t) :: beam_structure type(model_data_t), target :: model write (u, "(A)") "* Test output: beam_2" write (u, "(A)") "* Purpose: transfer beam polarization using & &beam structure" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call model%init_sm_test () write (u, "(A)") "* Unpolarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Polarized scattering, massless fermions" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([1,-1], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 1) call beam_structure%set_sentry (1, 1, [1,1], (1._default, 0._default)) call beam_structure%init_smatrix (2, 3) call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default)) call beam_structure%set_sentry (2, 2, [-1,-1], (1._default, 0._default)) call beam_structure%set_sentry (2, 3, [-1,1], (1._default, 0._default)) call beam_structure%set_pol_f ([0.5_default, 1._default]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, *) call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () call beam_structure%final_pol () call beam_structure%final_sf () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massless bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([22,22], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 0) call beam_structure%init_smatrix (2, 1) call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default)) call beam_structure%set_pol_f ([0._default, 1._default]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Semi-polarized scattering, massive bosons" write (u, "(A)") call reset_interaction_counter () sqrts = 500 call flv%init ([24,-24], model) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%init_pol (2) call beam_structure%init_smatrix (1, 0) call beam_structure%init_smatrix (2, 1) call beam_structure%set_sentry (2, 1, [0,0], (1._default, 0._default)) call beam_structure%write (u) write (u, "(A)") call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () write (u, "(A)") write (u, "(A)") "* Unpolarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call beam_structure%init_sf ([flv(1)%get_name ()], no_records) call beam_structure%final_pol () call beam_structure%write (u) write (u, "(A)") call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Polarized decay, massive boson" write (u, "(A)") call reset_interaction_counter () call flv(1)%init (23, model) call beam_structure%init_sf ([flv(1)%get_name ()], no_records) call beam_structure%init_pol (1) call beam_structure%init_smatrix (1, 1) call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default)) call beam_structure%set_pol_f ([0.4_default]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, sqrts, model) call beam_data%write (u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call beam_final (beam) call beam_data%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: beam_2" end subroutine beam_2 @ %def beam_2 @ Test advanced beam setup, completely arbitrary momenta. <>= call test (beam_3, "beam_3", & "generic beam momenta", & u, results) <>= public :: beam_3 <>= subroutine beam_3 (u) integer, intent(in) :: u type(beam_data_t), target :: beam_data type(beam_t) :: beam type(flavor_t), dimension(2) :: flv integer, dimension(0) :: no_records type(model_data_t), target :: model type(beam_structure_t) :: beam_structure type(vector3_t), dimension(2) :: p3 type(vector4_t), dimension(2) :: p write (u, "(A)") "* Test output: beam_3" write (u, "(A)") "* Purpose: set up beams with generic momenta" write (u, "(A)") write (u, "(A)") "* Reading model file" write (u, "(A)") call reset_interaction_counter () call model%init_sm_test () write (u, "(A)") "* 1: Scattering process" write (u, "(A)") call flv%init ([2212,2212], model) p3(1) = vector3_moving ([5._default, 0._default, 10._default]) p3(2) = -vector3_moving ([1._default, 1._default, -10._default]) call beam_structure%init_sf (flv%get_name (), no_records) call beam_structure%set_momentum (p3 ** 1) call beam_structure%set_theta (polar_angle (p3)) call beam_structure%set_phi (azimuthal_angle (p3)) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, 0._default, model) call pacify (beam_data%l_cm_to_lab, 1e-20_default) call beam_data%compute_md5sum () call beam_data%write (u, verbose = .true.) write (u, *) write (u, "(1x,A)") "Beam momenta reconstructed from LT:" p = beam_data%L_cm_to_lab * beam_data%p_cm call pacify (p, 1e-12_default) call vector4_write (p(1), u) call vector4_write (p(2), u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) call beam_final (beam) call beam_data%final () call beam_structure%final_sf () call beam_structure%final_mom () write (u, "(A)") write (u, "(A)") "* 2: Decay" write (u, "(A)") call flv(1)%init (23, model) p3(1) = vector3_moving ([10._default, 5._default, 50._default]) call beam_structure%init_sf ([flv(1)%get_name ()], no_records) call beam_structure%set_momentum ([p3(1) ** 1]) call beam_structure%set_theta ([polar_angle (p3(1))]) call beam_structure%set_phi ([azimuthal_angle (p3(1))]) call beam_structure%write (u) write (u, *) call beam_data%init_structure (beam_structure, 0._default, model) call beam_data%write (u, verbose = .true.) write (u, "(A)") write (u, "(1x,A)") "Beam momentum reconstructed from LT:" p(1) = beam_data%L_cm_to_lab * beam_data%p_cm(1) call pacify (p(1), 1e-12_default) call vector4_write (p(1), u) write (u, "(A)") call beam_init (beam, beam_data) call beam_write (beam, u) write (u, "(A)") write (u, "(A)") "* Cleanup" call beam_final (beam) call beam_data%final () call beam_structure%final_sf () call beam_structure%final_mom () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: beam_3" end subroutine beam_3 @ %def beam_3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Tools} This module contains auxiliary procedures that can be accessed by the structure function code. <<[[sf_aux.f90]]>>= <> module sf_aux <> use io_units use constants, only: twopi use numeric_utils use lorentz <> <> <> <> contains <> end module sf_aux @ %def sf_aux @ \subsection{Momentum splitting} Let us consider first an incoming parton with momentum $k$ and invariant mass squared $s=k^2$ that splits into two partons with momenta $q,p$ and invariant masses $t=q^2$ and $u=p^2$. (This is an abuse of the Mandelstam notation. $t$ is actually the momentum transfer, assuming that $p$ is radiated and $q$ initiates the hard process.) The energy is split among the partons such that if $E=k^0$, we have $q^0 = xE$ and $p^0=\bar x E$, where $\bar x\equiv 1-x$. We define the angle $\theta$ as the polar angle of $p$ w.r.t.\ the momentum axis of the incoming momentum $k$. Ignoring azimuthal angle, we can write the four-momenta in the basis $(E,p_T,p_L)$ as \begin{equation} k = \begin{pmatrix} E \\ 0 \\ p \end{pmatrix}, \qquad p = \begin{pmatrix} \bar x E \\ \bar x\bar p\sin\theta \\ \bar x\bar p\cos\theta \end{pmatrix}, \qquad q = \begin{pmatrix} x E \\ -\bar x\bar p\sin\theta \\ p - \bar x\bar p\cos\theta \end{pmatrix}, \end{equation} where the first two mass-shell conditions are \begin{equation} p^2 = E^2 - s, \qquad \bar p^2 = E^2 - \frac{u}{\bar x^2}. \end{equation} The second condition implies that, for positive $u$, $\bar x^2 > u/E^2$, or equivalently \begin{equation} x < 1 - \sqrt{u} / E. \end{equation} We are interested in the third mass-shell conditions: $s$ and $u$ are fixed, so we need $t$ as a function of $\cos\theta$: \begin{equation} t = -2\bar x \left(E^2 - p\bar p\cos\theta\right) + s + u. \end{equation} Solving for $\cos\theta$, we get \begin{equation} \cos\theta = \frac{2\bar x E^2 + t - s - u}{2\bar x p\bar p}. \end{equation} We can compute $\sin\theta$ numerically as $\sin^2\theta=1-\cos^2\theta$, but it is important to reexpress this in view of numerical stability. To this end, we first determine the bounds for $t$. The cosine must be between $-1$ and $1$, so the bounds are \begin{align} t_0 &= -2\bar x\left(E^2 + p\bar p\right) + s + u, \\ t_1 &= -2\bar x\left(E^2 - p\bar p\right) + s + u. \end{align} Computing $\sin^2\theta$ from $\cos\theta$ above, we observe that the numerator is a quadratic polynomial in $t$ which has the zeros $t_0$ and $t_1$, while the common denominator is given by $(2\bar x p\bar p)^2$. Hence, we can write \begin{equation} \sin^2\theta = -\frac{(t - t_0)(t - t_1)}{(2\bar x p\bar p)^2} \qquad\text{and}\qquad \cos\theta = \frac{(t-t_0) + (t-t_1)}{4\bar x p\bar p}, \end{equation} which is free of large cancellations near $t=t_0$ or $t=t_1$. If all is massless, i.e., $s=u=0$, this simplifies to \begin{align} t_0 &= -4\bar x E^2, & t_1 &= 0, \\ \sin^2\theta &= -\frac{t}{\bar x E^2} \left(1 + \frac{t}{4\bar x E^2}\right), & \cos\theta &= 1 + \frac{t}{2\bar x E^2}. \end{align} Here is the implementation. First, we define a container for the kinematical integration limits and some further data. Note: contents are public only for easy access in unit test. <>= public :: splitting_data_t <>= type :: splitting_data_t ! private logical :: collinear = .false. real(default) :: x0 = 0 real(default) :: x1 real(default) :: t0 real(default) :: t1 real(default) :: phi0 = 0 real(default) :: phi1 = twopi real(default) :: E, p, s, u, m2 real(default) :: x, xb, pb real(default) :: t = 0 real(default) :: phi = 0 contains <> end type splitting_data_t @ %def splitting_data_t @ I/O for debugging: <>= procedure :: write => splitting_data_write <>= subroutine splitting_data_write (d, unit) class(splitting_data_t), intent(in) :: d integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(A)") "Splitting data:" write (u, "(2x,A,L1)") "collinear = ", d%collinear 1 format (2x,A,1x,ES15.8) write (u, 1) "x0 =", d%x0 write (u, 1) "x =", d%x write (u, 1) "xb =", d%xb write (u, 1) "x1 =", d%x1 write (u, 1) "t0 =", d%t0 write (u, 1) "t =", d%t write (u, 1) "t1 =", d%t1 write (u, 1) "phi0 =", d%phi0 write (u, 1) "phi =", d%phi write (u, 1) "phi1 =", d%phi1 write (u, 1) "E =", d%E write (u, 1) "p =", d%p write (u, 1) "pb =", d%pb write (u, 1) "s =", d%s write (u, 1) "u =", d%u write (u, 1) "m2 =", d%m2 end subroutine splitting_data_write @ %def splitting_data_write @ \subsection{Constant data} This is the initializer for the data. The input consists of the incoming momentum, its invariant mass squared, and the invariant mass squared of the radiated particle. $m2$ is the \emph{physical} mass squared of the outgoing particle. The $t$ bounds depend on the chosen $x$ value and cannot be determined yet. <>= procedure :: init => splitting_data_init <>= subroutine splitting_data_init (d, k, mk2, mr2, mo2, collinear) class(splitting_data_t), intent(out) :: d type(vector4_t), intent(in) :: k real(default), intent(in) :: mk2, mr2, mo2 logical, intent(in), optional :: collinear if (present (collinear)) d%collinear = collinear d%E = energy (k) d%x1 = 1 - sqrt (max (mr2, 0._default)) / d%E d%p = sqrt (d%E**2 - mk2) d%s = mk2 d%u = mr2 d%m2 = mo2 end subroutine splitting_data_init @ %def splitting_data_init @ Retrieve the $x$ bounds, if needed for $x$ sampling. Generating an $x$ value is done by the caller, since this is the part that depends on the nature of the structure function. <>= procedure :: get_x_bounds => splitting_get_x_bounds <>= function splitting_get_x_bounds (d) result (x) class(splitting_data_t), intent(in) :: d real(default), dimension(2) :: x x = [ d%x0, d%x1 ] end function splitting_get_x_bounds @ %def splitting_get_x_bounds @ Now set the momentum fraction and compute $t_0$ and $t_1$. [The calculation of $t_1$ is subject to numerical problems. The exact formula is ($s=m_i^2$, $u=m_r^2$) \begin{equation} t_1 = -2\bar x E^2 + m_i^2 + m_r^2 + 2\bar x \sqrt{E^2-m_i^2}\,\sqrt{E^2 - m_r^2/\bar x^2}. \end{equation} The structure-function paradigm is useful only if $E\gg m_i,m_r$. In a Taylor expansion for large $E$, the leading term cancels. The expansion of the square roots (to subleading order) yields \begin{equation} t_1 = xm_i^2 - \frac{x}{\bar x}m_r^2. \end{equation} There are two cases of interest: $m_i=m_o$ and $m_r=0$, \begin{equation} t_1 = xm_o^2 \end{equation} and $m_i=m_r$ and $m_o=0$, \begin{equation} t_1 = -\frac{x^2}{\bar x}m_i^2. \end{equation} In both cases, $t_1\leq m_o^2$.] That said, it turns out that taking the $t_1$ evaluation at face value leads to less problems than the approximation. We express the angles in terms of $t-t_0$ and $t-t_1$. Numerical noise in $t_1$ can then be tolerated. <>= procedure :: set_t_bounds => splitting_set_t_bounds <>= elemental subroutine splitting_set_t_bounds (d, x, xb) class(splitting_data_t), intent(inout) :: d real(default), intent(in), optional :: x, xb real(default) :: tp, tm if (present (x)) d%x = x if (present (xb)) d%xb = xb if (vanishes (d%u)) then d%pb = d%E else if (.not. vanishes (d%xb)) then d%pb = sqrt (max (d%E**2 - d%u / d%xb**2, 0._default)) else d%pb = 0 end if end if tp = -2 * d%xb * d%E**2 + d%s + d%u tm = -2 * d%xb * d%p * d%pb d%t0 = tp + tm d%t1 = tp - tm d%t = d%t1 end subroutine splitting_set_t_bounds @ %def splitting_set_t_bounds @ \subsection{Sampling recoil} Compute a value for the momentum transfer $t$, using a random number $r$. We assume a logarithmic distribution for $t-m^2$, corresponding to the propagator $1/(t-m^2)$ with the physical mass $m$ for the outgoing particle. Optionally, we can narrow the kinematical bounds. If all three masses in the splitting vanish, the upper limit for $t$ is zero. In that case, the $t$ value is set to zero and the splitting will be collinear. <>= procedure :: sample_t => splitting_sample_t <>= subroutine splitting_sample_t (d, r, t0, t1) class(splitting_data_t), intent(inout) :: d real(default), intent(in) :: r real(default), intent(in), optional :: t0, t1 real(default) :: tt0, tt1, tt0m, tt1m if (d%collinear) then d%t = d%t1 else tt0 = d%t0; if (present (t0)) tt0 = max (t0, tt0) tt1 = d%t1; if (present (t1)) tt1 = min (t1, tt1) tt0m = tt0 - d%m2 tt1m = tt1 - d%m2 if (tt0m < 0 .and. tt1m < 0 .and. abs(tt0m) > & epsilon(tt0m) .and. abs(tt1m) > epsilon(tt0m)) then d%t = d%m2 + tt0m * exp (r * log (tt1m / tt0m)) else d%t = tt1 end if end if end subroutine splitting_sample_t @ %def splitting_sample_t @ The inverse operation: Given $t$, we recover the value of $r$ that would have produced this value. <>= procedure :: inverse_t => splitting_inverse_t <>= subroutine splitting_inverse_t (d, r, t0, t1) class(splitting_data_t), intent(in) :: d real(default), intent(out) :: r real(default), intent(in), optional :: t0, t1 real(default) :: tt0, tt1, tt0m, tt1m if (d%collinear) then r = 0 else tt0 = d%t0; if (present (t0)) tt0 = max (t0, tt0) tt1 = d%t1; if (present (t1)) tt1 = min (t1, tt1) tt0m = tt0 - d%m2 tt1m = tt1 - d%m2 if (tt0m < 0 .and. tt1m < 0) then r = log ((d%t - d%m2) / tt0m) / log (tt1m / tt0m) else r = 0 end if end if end subroutine splitting_inverse_t @ %def splitting_inverse_t @ This is trivial, but provided for convenience: <>= procedure :: sample_phi => splitting_sample_phi <>= subroutine splitting_sample_phi (d, r) class(splitting_data_t), intent(inout) :: d real(default), intent(in) :: r if (d%collinear) then d%phi = 0 else d%phi = (1-r) * d%phi0 + r * d%phi1 end if end subroutine splitting_sample_phi @ %def splitting_sample_phi @ Inverse: <>= procedure :: inverse_phi => splitting_inverse_phi <>= subroutine splitting_inverse_phi (d, r) class(splitting_data_t), intent(in) :: d real(default), intent(out) :: r if (d%collinear) then r = 0 else r = (d%phi - d%phi0) / (d%phi1 - d%phi0) end if end subroutine splitting_inverse_phi @ %def splitting_inverse_phi @ \subsection{Splitting} In this function, we actually perform the splitting. The incoming momentum $k$ is split into (if no recoil) $q_1=(1-x)k$ and $q_2=xk$. Apart from the splitting data, we need the incoming momentum $k$, the momentum transfer $t$, and the azimuthal angle $\phi$. The momentum fraction $x$ is already known here. Alternatively, we can split without recoil. The azimuthal angle is irrelevant, and the momentum transfer is always equal to the upper limit $t_1$, so the polar angle is zero. Obviously, if there are nonzero masses it is not possible to keep both energy-momentum conservation and at the same time all particles on shell. We choose for dropping the on-shell condition here. <>= procedure :: split_momentum => splitting_split_momentum <>= function splitting_split_momentum (d, k) result (q) class(splitting_data_t), intent(in) :: d type(vector4_t), dimension(2) :: q type(vector4_t), intent(in) :: k real(default) :: st2, ct2, st, ct, cp, sp type(lorentz_transformation_t) :: rot real(default) :: tt0, tt1, den type(vector3_t) :: kk, q1, q2 if (d%collinear) then if (vanishes (d%s) .and. vanishes(d%u)) then q(1) = d%xb * k q(2) = d%x * k else kk = space_part (k) q1 = d%xb * (d%pb / d%p) * kk q2 = kk - q1 q(1) = vector4_moving (d%xb * d%E, q1) q(2) = vector4_moving (d%x * d%E, q2) end if else den = 2 * d%xb * d%p * d%pb tt0 = max (d%t - d%t0, 0._default) tt1 = min (d%t - d%t1, 0._default) if (den**2 <= epsilon(den)) then st2 = 0 else st2 = - (tt0 * tt1) / den ** 2 end if if (st2 > 1) then st2 = 1 end if ct2 = 1 - st2 st = sqrt (max (st2, 0._default)) ct = sqrt (max (ct2, 0._default)) if ((d%t - d%t0 + d%t - d%t1) < 0) then ct = - ct end if sp = sin (d%phi) cp = cos (d%phi) rot = rotation_to_2nd (3, space_part (k)) q1 = vector3_moving (d%xb * d%pb * [st * cp, st * sp, ct]) q2 = vector3_moving (d%p, 3) - q1 q(1) = rot * vector4_moving (d%xb * d%E, q1) q(2) = rot * vector4_moving (d%x * d%E, q2) end if end function splitting_split_momentum @ %def splitting_split_momentum @ Momenta generated by splitting will in general be off-shell. They are on-shell only if they are collinear and massless. This subroutine puts them on shell by brute force, violating either momentum or energy conservation. The direction of three-momentum is always retained. If the energy is below mass shell, we return a zero momentum. <>= integer, parameter, public :: KEEP_ENERGY = 0, KEEP_MOMENTUM = 1 @ %def KEEP_ENERGY KEEP_MOMENTUM <>= public :: on_shell <>= elemental subroutine on_shell (p, m2, keep) type(vector4_t), intent(inout) :: p real(default), intent(in) :: m2 integer, intent(in) :: keep real(default) :: E, E2, pn select case (keep) case (KEEP_ENERGY) E = energy (p) E2 = E ** 2 if (E2 >= m2) then pn = sqrt (E2 - m2) p = vector4_moving (E, pn * direction (space_part (p))) else p = vector4_null end if case (KEEP_MOMENTUM) E = sqrt (space_part (p) ** 2 + m2) p = vector4_moving (E, space_part (p)) end select end subroutine on_shell @ %def on_shell @ \subsection{Recovering the splitting} This is the inverse problem. We have on-shell momenta and want to deduce the splitting parameters $x$, $t$, and $\phi$. Update 2018-08-22: As a true inverse to [[splitting_split_momentum]], we now use not just a single momentum [[q2]] as before, but the momentum pair [[q1]], [[q2]] for recovering $x$ and $\bar x$ separately. If $x$ happens to be close to $1$, we would completely lose the tiny $\bar x$ value, otherwise, and thus get a meaningless result. <>= procedure :: recover => splitting_recover <>= subroutine splitting_recover (d, k, q, keep) class(splitting_data_t), intent(inout) :: d type(vector4_t), intent(in) :: k type(vector4_t), dimension(2), intent(in) :: q integer, intent(in) :: keep type(lorentz_transformation_t) :: rot type(vector4_t) :: k0 type(vector4_t), dimension(2) :: q0 real(default) :: p1, p2, p3, pt2, pp2, pl real(default) :: aux, den, norm real(default) :: st2, ct2, ct rot = inverse (rotation_to_2nd (3, space_part (k))) q0 = rot * q p1 = vector4_get_component (q0(2), 1) p2 = vector4_get_component (q0(2), 2) p3 = vector4_get_component (q0(2), 3) pt2 = p1 ** 2 + p2 ** 2 pp2 = p1 ** 2 + p2 ** 2 + p3 ** 2 pl = abs (p3) k0 = vector4_moving (d%E, d%p, 3) select case (keep) case (KEEP_ENERGY) d%x = energy (q0(2)) / d%E d%xb = energy (q0(1)) / d%E call d%set_t_bounds () if (.not. d%collinear) then aux = (d%xb * d%pb) ** 2 * pp2 - d%p ** 2 * pt2 den = d%p ** 2 - (d%xb * d%pb) ** 2 if (aux >= 0 .and. den > 0) then norm = (d%p * pl + sqrt (aux)) / den else norm = 1 end if end if case (KEEP_MOMENTUM) d%xb = sqrt (space_part (q0(1)) ** 2 + d%u) / d%E d%x = 1 - d%xb call d%set_t_bounds () norm = 1 end select if (d%collinear) then d%t = d%t1 d%phi = 0 else if ((d%xb * d%pb * norm)**2 < epsilon(d%xb)) then st2 = 1 else st2 = pt2 / (d%xb * d%pb * norm ) ** 2 end if if (st2 > 1) then st2 = 1 end if ct2 = 1 - st2 ct = sqrt (max (ct2, 0._default)) if (.not. vanishes (1 + ct)) then d%t = d%t1 - 2 * d%xb * d%p * d%pb * st2 / (1 + ct) else d%t = d%t0 end if if (.not. vanishes (p1) .or. .not. vanishes (p2)) then d%phi = atan2 (-p2, -p1) else d%phi = 0 end if end if end subroutine splitting_recover @ %def splitting_recover @ \subsection{Extract data} <>= procedure :: get_x => splitting_get_x procedure :: get_xb => splitting_get_xb <>= function splitting_get_x (sd) result (x) class(splitting_data_t), intent(in) :: sd real(default) :: x x = sd%x end function splitting_get_x function splitting_get_xb (sd) result (xb) class(splitting_data_t), intent(in) :: sd real(default) :: xb xb = sd%xb end function splitting_get_xb @ %def splitting_get_x @ %def splitting_get_xb @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_aux_ut.f90]]>>= <> module sf_aux_ut use unit_tests use sf_aux_uti <> <> contains <> end module sf_aux_ut @ %def sf_aux_ut @ <<[[sf_aux_uti.f90]]>>= <> module sf_aux_uti <> use lorentz use sf_aux <> <> contains <> end module sf_aux_uti @ %def sf_aux_ut @ API: driver for the unit tests below. <>= public :: sf_aux_test <>= subroutine sf_aux_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_aux_test @ %def sf_aux_test @ \subsubsection{Momentum splitting: massless radiation} Compute momentum splitting for generic kinematics. It turns out that for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and lower bounds (this can be directly seen from the logarithmic distribution in the function [[sample_t]] for $r \equiv x = 1 - x = 0.5$), we arrive at an exact number $t=-0.15$ for the given input values. <>= call test (sf_aux_1, "sf_aux_1", & "massless radiation", & u, results) <>= public :: sf_aux_1 <>= subroutine sf_aux_1 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q, q0 real(default) :: E, mk, mp, mq real(default) :: x, r1, r2, r1o, r2o real(default) :: k2, q0_2, q1_2, q2_2 write (u, "(A)") "* Test output: sf_aux_1" write (u, "(A)") "* Purpose: compute momentum splitting" write (u, "(A)") " (massless radiated particle)" write (u, "(A)") E = 1 mk = 0.3_default mp = 0 mq = mk k = vector4_moving (E, sqrt (E**2 - mk**2), 3) k2 = k ** 2; call pacify (k2, 1e-10_default) x = 0.6_default r1 = 0.5_default r2 = 0.125_default write (u, "(A)") "* (1) Non-collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%sample_t (r1) call sd%sample_phi (r2) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "Extract: x, 1-x" write (u, "(2(1x,F11.8))") sd%get_x (), sd%get_xb () write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, 1 - x) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q0_2 = q0(2) ** 2; call pacify (q0_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q0_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_1" end subroutine sf_aux_1 @ %def sf_aux_1 @ \subsubsection{Momentum splitting: massless parton} Compute momentum splitting for generic kinematics. It turns out that for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and lower bounds, we arrive at an exact number $t=-0.36$ for the given input values. <>= call test (sf_aux_2, "sf_aux_2", & "massless parton", & u, results) <>= public :: sf_aux_2 <>= subroutine sf_aux_2 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q, q0 real(default) :: E, mk, mp, mq real(default) :: x, r1, r2, r1o, r2o real(default) :: k2, q02_2, q1_2, q2_2 write (u, "(A)") "* Test output: sf_aux_2" write (u, "(A)") "* Purpose: compute momentum splitting" write (u, "(A)") " (massless outgoing particle)" write (u, "(A)") E = 1 mk = 0.3_default mp = mk mq = 0 k = vector4_moving (E, sqrt (E**2 - mk**2), 3) k2 = k ** 2; call pacify (k2, 1e-10_default) x = 0.6_default r1 = 0.5_default r2 = 0.125_default write (u, "(A)") "* (1) Non-collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%sample_t (r1) call sd%sample_phi (r2) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, 1 - x) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_2" end subroutine sf_aux_2 @ %def sf_aux_2 @ \subsubsection{Momentum splitting: all massless} Compute momentum splitting for massless kinematics. In the non-collinear case, we need a lower cutoff for $|t|$, otherwise a logarithmic distribution is not possible. <>= call test (sf_aux_3, "sf_aux_3", & "massless parton", & u, results) <>= public :: sf_aux_3 <>= subroutine sf_aux_3 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q, q0 real(default) :: E, mk, mp, mq, qmin, qmax real(default) :: x, r1, r2, r1o, r2o real(default) :: k2, q02_2, q1_2, q2_2 write (u, "(A)") "* Test output: sf_aux_3" write (u, "(A)") "* Purpose: compute momentum splitting" write (u, "(A)") " (all massless, q cuts)" write (u, "(A)") E = 1 mk = 0 mp = 0 mq = 0 qmin = 1e-2_default qmax = 1e0_default k = vector4_moving (E, sqrt (E**2 - mk**2), 3) k2 = k ** 2; call pacify (k2, 1e-10_default) x = 0.6_default r1 = 0.5_default r2 = 0.125_default write (u, "(A)") "* (1) Non-collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%sample_t (r1, t1 = - qmin ** 2, t0 = - qmax **2) call sd%sample_phi (r2) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o, t1 = - qmin ** 2, t0 = - qmax **2) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t call sd%inverse_t (r1o, t1 = - qmin ** 2, t0 = - qmax **2) write (u, "(A)") "Compare: r1" write (u, "(2(1x,F11.8))") r1, r1o call sd%inverse_phi (r2o) write (u, "(A)") "Compare: r2" write (u, "(2(1x,F11.8))") r2, r2o write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Collinear setup" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, 1 - x) call sd%write (u) q = sd%split_momentum (k) q1_2 = q(1) ** 2; call pacify (q1_2, 1e-10_default) q2_2 = q(2) ** 2; call pacify (q2_2, 1e-10_default) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "Compare: s" write (u, "(2(1x,F11.8))") sd%s, k2 write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") sd%t, q2_2 write (u, "(A)") "Compare: u" write (u, "(2(1x,F11.8))") sd%u, q1_2 write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") sd%x, energy (q(2)) / energy (k) write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") sd%xb, energy (q(1)) / energy (k) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep energy)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Project on-shell (keep momentum)" q0 = q call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q0), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q0(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q0(2), u) write (u, "(A)") write (u, "(A)") "Compare: mo^2" q02_2 = q0(2) ** 2; call pacify (q02_2, 1e-10_default) write (u, "(2(1x,F11.8))") sd%m2, q02_2 write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momentum" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2) call sd%set_t_bounds (x, 1 - x) call sd%recover (k, q0, KEEP_MOMENTUM) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: t" write (u, "(2(1x,F11.8))") q2_2, sd%t write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_3" end subroutine sf_aux_3 @ %def sf_aux_3 @ \subsubsection{Endpoint stability} Compute momentum splitting for collinear kinematics close to both endpoints. In particular, check both directions $x\to$ momenta and momenta $\to x$. For purely massless collinear splitting, the [[KEEP_XXX]] flag is irrelevant. We choose [[KEEP_ENERGY]] here. <>= call test (sf_aux_4, "sf_aux_4", & "endpoint numerics", & u, results) <>= public :: sf_aux_4 <>= subroutine sf_aux_4 (u) integer, intent(in) :: u type(splitting_data_t) :: sd type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E, mk, mp, mq, qmin, qmax real(default) :: x, xb write (u, "(A)") "* Test output: sf_aux_4" write (u, "(A)") "* Purpose: compute massless collinear splitting near endpoint" E = 1 mk = 0 mp = 0 mq = 0 qmin = 1e-2_default qmax = 1e0_default k = vector4_moving (E, sqrt (E**2 - mk**2), 3) x = 0.1_default xb = 1 - x write (u, "(A)") write (u, "(A)") "* (1) Collinear setup, moderate kinematics" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%write (u) q = sd%split_momentum (k) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momenta" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%recover (k, q, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") xb, sd%xb write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (2) Close to x=0" write (u, "(A)") x = 1e-9_default xb = 1 - x call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%write (u) q = sd%split_momentum (k) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momenta" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%recover (k, q, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") xb, sd%xb write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* (3) Close to x=1" write (u, "(A)") xb = 1e-9_default x = 1 - xb call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%write (u) q = sd%split_momentum (k) write (u, "(A)") write (u, "(A)") "Incoming momentum k =" call vector4_write (k, u) write (u, "(A)") write (u, "(A)") "Outgoing momentum sum p + q =" call vector4_write (sum (q), u) write (u, "(A)") write (u, "(A)") "Radiated momentum p =" call vector4_write (q(1), u) write (u, "(A)") write (u, "(A)") "Outgoing momentum q =" call vector4_write (q(2), u) write (u, "(A)") write (u, "(A)") "* Recover parameters from outgoing momenta" write (u, "(A)") call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.) call sd%set_t_bounds (x, xb) call sd%recover (k, q, KEEP_ENERGY) write (u, "(A)") "Compare: x" write (u, "(2(1x,F11.8))") x, sd%x write (u, "(A)") "Compare: 1-x" write (u, "(2(1x,F11.8))") xb, sd%xb write (u, "(A)") call sd%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: sf_aux_4" end subroutine sf_aux_4 @ %def sf_aux_4 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Mappings for structure functions} In this module, we provide a wrapper for useful mappings of the unit (hyper-)square that we can apply to a set of structure functions. In some cases it is useful, or even mandatory, to map the MC input parameters nontrivially onto a set of structure functions for the two beams. In all cases considered here, instead of $x_1,x_2,\ldots$ as parameters for the beams, we generate one parameter that is equal, or related to, the product $x_1x_2\cdots$ (so it directly corresponds to $\sqrt{s}$). The other parameters describe the distribution of energy (loss) between beams and radiations. <<[[sf_mappings.f90]]>>= <> module sf_mappings <> use kinds, only: double use io_units use constants, only: pi, zero, one use numeric_utils use diagnostics <> <> <> <> <> contains <> end module sf_mappings @ %def sf_mappings @ \subsection{Base type} First, we define an abstract base type for the mapping. In all cases we need to store the indices of the parameters on which the mapping applies. Additional parameters can be stored in the extensions of this type. <>= public :: sf_mapping_t <>= type, abstract :: sf_mapping_t integer, dimension(:), allocatable :: i contains <> end type sf_mapping_t @ %def sf_mapping_t @ The output routine is deferred: <>= procedure (sf_mapping_write), deferred :: write <>= abstract interface subroutine sf_mapping_write (object, unit) import class(sf_mapping_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine sf_mapping_write end interface @ %def sf_mapping_write @ Initializer for the base type. The array of parameter indices is allocated but initialized to zero. <>= procedure :: base_init => sf_mapping_base_init <>= subroutine sf_mapping_base_init (mapping, n_par) class(sf_mapping_t), intent(out) :: mapping integer, intent(in) :: n_par allocate (mapping%i (n_par)) mapping%i = 0 end subroutine sf_mapping_base_init @ %def sf_mapping_base_init @ Set an index value. <>= procedure :: set_index => sf_mapping_set_index <>= subroutine sf_mapping_set_index (mapping, j, i) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i end subroutine sf_mapping_set_index @ %def sf_mapping_set_index @ Retrieve an index value. <>= procedure :: get_index => sf_mapping_get_index <>= function sf_mapping_get_index (mapping, j) result (i) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: j integer :: i i = mapping%i(j) end function sf_mapping_get_index @ %def sf_mapping_get_index @ Return the dimensionality, i.e., the number of parameters. <>= procedure :: get_n_dim => sf_mapping_get_n_dim <>= function sf_mapping_get_n_dim (mapping) result (n) class(sf_mapping_t), intent(in) :: mapping integer :: n n = size (mapping%i) end function sf_mapping_get_n_dim @ %def sf_mapping_get_n_dim @ Computation: the values [[p]] are the input parameters, the values [[r]] are the output parameters. The values [[rb]] are defined as $\bar r = 1 - r$, but provided explicitly. They allow us to avoid numerical problems near $r=1$. The extra parameter [[x_free]] indicates that the total energy has already been renormalized by this factor. We have to take such a factor into account in a resonance or on-shell mapping. The Jacobian is [[f]]. We modify only the two parameters indicated by the indices [[i]]. <>= procedure (sf_mapping_compute), deferred :: compute <>= abstract interface subroutine sf_mapping_compute (mapping, r, rb, f, p, pb, x_free) import class(sf_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_mapping_compute end interface @ %def sf_mapping_compute @ The inverse mapping. Use [[r]] and/or [[rb]] to reconstruct [[p]] and also compute [[f]]. <>= procedure (sf_mapping_inverse), deferred :: inverse <>= abstract interface subroutine sf_mapping_inverse (mapping, r, rb, f, p, pb, x_free) import class(sf_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free end subroutine sf_mapping_inverse end interface @ %def sf_mapping_inverse @ \subsection{Methods for self-tests} This is a shorthand for: inject parameters, compute the mapping, display results, compute the inverse, display again. We provide an output format for the parameters and, optionally, a different output format for the Jacobians. <>= procedure :: check => sf_mapping_check <>= subroutine sf_mapping_check (mapping, u, p_in, pb_in, fmt_p, fmt_f) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: u real(default), dimension(:), intent(in) :: p_in, pb_in character(*), intent(in) :: fmt_p character(*), intent(in), optional :: fmt_f real(default), dimension(size(p_in)) :: p, pb, r, rb real(default) :: f, tolerance tolerance = 1.5E-17 p = p_in pb= pb_in call mapping%compute (r, rb, f, p, pb) call pacify (p, tolerance) call pacify (pb, tolerance) call pacify (r, tolerance) call pacify (rb, tolerance) write (u, "(3x,A,9(1x," // fmt_p // "))") "p =", p write (u, "(3x,A,9(1x," // fmt_p // "))") "pb=", pb write (u, "(3x,A,9(1x," // fmt_p // "))") "r =", r write (u, "(3x,A,9(1x," // fmt_p // "))") "rb=", rb if (present (fmt_f)) then write (u, "(3x,A,9(1x," // fmt_f // "))") "f =", f else write (u, "(3x,A,9(1x," // fmt_p // "))") "f =", f end if write (u, *) call mapping%inverse (r, rb, f, p, pb) call pacify (p, tolerance) call pacify (pb, tolerance) call pacify (r, tolerance) call pacify (rb, tolerance) write (u, "(3x,A,9(1x," // fmt_p // "))") "p =", p write (u, "(3x,A,9(1x," // fmt_p // "))") "pb=", pb write (u, "(3x,A,9(1x," // fmt_p // "))") "r =", r write (u, "(3x,A,9(1x," // fmt_p // "))") "rb=", rb if (present (fmt_f)) then write (u, "(3x,A,9(1x," // fmt_f // "))") "f =", f else write (u, "(3x,A,9(1x," // fmt_p // "))") "f =", f end if write (u, *) write (u, "(3x,A,9(1x," // fmt_p // "))") "*r=", product (r) end subroutine sf_mapping_check @ %def sf_mapping_check @ This is a consistency check for the self-tests: the integral over the unit square should be unity. We estimate this by a simple binning and adding up the values; this should be sufficient for a self-test. The argument is the requested number of sampling points. We take the square root for binning in both dimensions, so the precise number might be different. <>= procedure :: integral => sf_mapping_integral <>= function sf_mapping_integral (mapping, n_calls) result (integral) class(sf_mapping_t), intent(inout) :: mapping integer, intent(in) :: n_calls real(default) :: integral integer :: n_dim, n_bin, k real(default), dimension(:), allocatable :: p, pb, r, rb integer, dimension(:), allocatable :: ii real(default) :: dx, f, s n_dim = mapping%get_n_dim () allocate (p (n_dim)) allocate (pb(n_dim)) allocate (r (n_dim)) allocate (rb(n_dim)) allocate (ii(n_dim)) n_bin = nint (real (n_calls, default) ** (1._default / n_dim)) dx = 1._default / n_bin s = 0 ii = 1 SAMPLE: do do k = 1, n_dim p(k) = ii(k) * dx - dx/2 pb(k) = (n_bin - ii(k)) * dx + dx/2 end do call mapping%compute (r, rb, f, p, pb) s = s + f INCR: do k = 1, n_dim ii(k) = ii(k) + 1 if (ii(k) <= n_bin) then exit INCR else if (k < n_dim) then ii(k) = 1 else exit SAMPLE end if end do INCR end do SAMPLE integral = s / real (n_bin, default) ** n_dim end function sf_mapping_integral @ %def sf_mapping_integral @ \subsection{Implementation: standard mapping} This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. <>= public :: sf_s_mapping_t <>= type, extends (sf_mapping_t) :: sf_s_mapping_t logical :: power_set = .false. real(default) :: power = 1 contains <> end type sf_s_mapping_t @ %def sf_s_mapping_t @ Output. <>= procedure :: write => sf_s_mapping_write <>= subroutine sf_s_mapping_write (object, unit) class(sf_s_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A)") ": standard (", object%power, ")" end subroutine sf_s_mapping_write @ %def sf_s_mapping_write @ Initialize: index pair and power parameter. <>= procedure :: init => sf_s_mapping_init <>= subroutine sf_s_mapping_init (mapping, power) class(sf_s_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: power call mapping%base_init (2) if (present (power)) then mapping%power_set = .true. mapping%power = power end if end subroutine sf_s_mapping_init @ %def sf_s_mapping_init @ Apply mapping. <>= procedure :: compute => sf_s_mapping_compute <>= subroutine sf_s_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_s_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2 integer :: j if (mapping%power_set) then call map_unit_square (r2, f, p(mapping%i), mapping%power) else call map_unit_square (r2, f, p(mapping%i)) end if r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_s_mapping_compute @ %def sf_s_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_s_mapping_inverse <>= subroutine sf_s_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_s_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: p2 integer :: j if (mapping%power_set) then call map_unit_square_inverse (r(mapping%i), f, p2, mapping%power) else call map_unit_square_inverse (r(mapping%i), f, p2) end if p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_s_mapping_inverse @ %def sf_s_mapping_inverse @ \subsection{Implementation: resonance pair mapping} This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio, then it maps $p_1$ to itself according to a Breit-Wigner shape, i.e., a flat prior distribution in $p_1$ results in a Breit-Wigner distribution. Mass and width of the BW are rescaled by the energy, thus dimensionless fractions. <>= public :: sf_res_mapping_t <>= type, extends (sf_mapping_t) :: sf_res_mapping_t real(default) :: m = 0 real(default) :: w = 0 contains <> end type sf_res_mapping_t @ %def sf_res_mapping_t @ Output. <>= procedure :: write => sf_res_mapping_write <>= subroutine sf_res_mapping_write (object, unit) class(sf_res_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,', ',F7.5,A)") ": resonance (", object%m, object%w, ")" end subroutine sf_res_mapping_write @ %def sf_res_mapping_write @ Initialize: index pair and dimensionless mass and width parameters. <>= procedure :: init => sf_res_mapping_init <>= subroutine sf_res_mapping_init (mapping, m, w) class(sf_res_mapping_t), intent(out) :: mapping real(default), intent(in) :: m, w call mapping%base_init (2) mapping%m = m mapping%w = w end subroutine sf_res_mapping_init @ %def sf_res_mapping_init @ Apply mapping. <>= procedure :: compute => sf_res_mapping_compute <>= subroutine sf_res_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, p2 real(default) :: fbw, f2, p1m integer :: j p2 = p(mapping%i) call map_breit_wigner & (p1m, fbw, p2(1), mapping%m, mapping%w, x_free) call map_unit_square (r2, f2, [p1m, p2(2)]) f = fbw * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_res_mapping_compute @ %def sf_res_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_res_mapping_inverse <>= subroutine sf_res_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: p2 real(default) :: fbw, f2, p1m call map_unit_square_inverse (r(mapping%i), f2, p2) call map_breit_wigner_inverse & (p2(1), fbw, p1m, mapping%m, mapping%w, x_free) p = r pb= rb p (mapping%i(1)) = p1m pb(mapping%i(1)) = 1 - p1m p (mapping%i(2)) = p2(2) pb(mapping%i(2)) = 1 - p2(2) f = fbw * f2 end subroutine sf_res_mapping_inverse @ %def sf_res_mapping_inverse @ \subsection{Implementation: resonance single mapping} While simpler, this is needed for structure-function setups only in exceptional cases. This maps the unit interval ($r_1$) to itself according to a Breit-Wigner shape, i.e., a flat prior distribution in $r_1$ results in a Breit-Wigner distribution. Mass and width of the BW are rescaled by the energy, thus dimensionless fractions. <>= public :: sf_res_mapping_single_t <>= type, extends (sf_mapping_t) :: sf_res_mapping_single_t real(default) :: m = 0 real(default) :: w = 0 contains <> end type sf_res_mapping_single_t @ %def sf_res_mapping_single_t @ Output. <>= procedure :: write => sf_res_mapping_single_write <>= subroutine sf_res_mapping_single_write (object, unit) class(sf_res_mapping_single_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,', ',F7.5,A)") ": resonance (", object%m, object%w, ")" end subroutine sf_res_mapping_single_write @ %def sf_res_mapping_single_write @ Initialize: single index (!) and dimensionless mass and width parameters. <>= procedure :: init => sf_res_mapping_single_init <>= subroutine sf_res_mapping_single_init (mapping, m, w) class(sf_res_mapping_single_t), intent(out) :: mapping real(default), intent(in) :: m, w call mapping%base_init (1) mapping%m = m mapping%w = w end subroutine sf_res_mapping_single_init @ %def sf_res_mapping_single_init @ Apply mapping. <>= procedure :: compute => sf_res_mapping_single_compute <>= subroutine sf_res_mapping_single_compute (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: r2, p2 real(default) :: fbw integer :: j p2 = p(mapping%i) call map_breit_wigner & (r2(1), fbw, p2(1), mapping%m, mapping%w, x_free) f = fbw r = p rb= pb r (mapping%i(1)) = r2(1) rb(mapping%i(1)) = 1 - r2(1) end subroutine sf_res_mapping_single_compute @ %def sf_res_mapping_single_compute @ Apply inverse. <>= procedure :: inverse => sf_res_mapping_single_inverse <>= subroutine sf_res_mapping_single_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_res_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: p2 real(default) :: fbw call map_breit_wigner_inverse & (r(mapping%i(1)), fbw, p2(1), mapping%m, mapping%w, x_free) p = r pb= rb p (mapping%i(1)) = p2(1) pb(mapping%i(1)) = 1 - p2(1) f = fbw end subroutine sf_res_mapping_single_inverse @ %def sf_res_mapping_single_inverse @ \subsection{Implementation: on-shell mapping} This is a degenerate version of the unit-square mapping where the product $r_1r_2$ is constant. This product is given by the rescaled squared mass. We introduce an artificial first parameter $p_1$ to keep the counting, but nothing depends on it. The second parameter is the same $p_2$ as for the standard unit-square mapping for $\alpha=1$, it parameterizes the ratio of $r_1$ and $r_2$. <>= public :: sf_os_mapping_t <>= type, extends (sf_mapping_t) :: sf_os_mapping_t real(default) :: m = 0 real(default) :: lm2 = 0 contains <> end type sf_os_mapping_t @ %def sf_os_mapping_t @ Output. <>= procedure :: write => sf_os_mapping_write <>= subroutine sf_os_mapping_write (object, unit) class(sf_os_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A)") ": on-shell (", object%m, ")" end subroutine sf_os_mapping_write @ %def sf_os_mapping_write @ Initialize: index pair and dimensionless mass parameter. <>= procedure :: init => sf_os_mapping_init <>= subroutine sf_os_mapping_init (mapping, m) class(sf_os_mapping_t), intent(out) :: mapping real(default), intent(in) :: m call mapping%base_init (2) mapping%m = m mapping%lm2 = abs (2 * log (mapping%m)) end subroutine sf_os_mapping_init @ %def sf_os_mapping_init @ Apply mapping. The [[x_free]] parameter rescales the total energy, which must be accounted for in the enclosed mapping. <>= procedure :: compute => sf_os_mapping_compute <>= subroutine sf_os_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, p2 integer :: j p2 = p(mapping%i) call map_on_shell (r2, f, p2, mapping%lm2, x_free) r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_os_mapping_compute @ %def sf_os_mapping_compute @ Apply inverse. The irrelevant parameter $p_1$ is always set zero. <>= procedure :: inverse => sf_os_mapping_inverse <>= subroutine sf_os_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: p2, r2 r2 = r(mapping%i) call map_on_shell_inverse (r2, f, p2, mapping%lm2, x_free) p = r pb= rb p (mapping%i(1)) = p2(1) pb(mapping%i(1)) = 1 - p2(1) p (mapping%i(2)) = p2(2) pb(mapping%i(2)) = 1 - p2(2) end subroutine sf_os_mapping_inverse @ %def sf_os_mapping_inverse @ \subsection{Implementation: on-shell single mapping} This is a degenerate version of the unit-interval mapping where the result $r$ is constant. The value is given by the rescaled squared mass. The input parameter $p_1$ is actually ignored, nothing depends on it. <>= public :: sf_os_mapping_single_t <>= type, extends (sf_mapping_t) :: sf_os_mapping_single_t real(default) :: m = 0 real(default) :: lm2 = 0 contains <> end type sf_os_mapping_single_t @ %def sf_os_mapping_single_t @ Output. <>= procedure :: write => sf_os_mapping_single_write <>= subroutine sf_os_mapping_single_write (object, unit) class(sf_os_mapping_single_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A)") ": on-shell (", object%m, ")" end subroutine sf_os_mapping_single_write @ %def sf_os_mapping_single_write @ Initialize: index pair and dimensionless mass parameter. <>= procedure :: init => sf_os_mapping_single_init <>= subroutine sf_os_mapping_single_init (mapping, m) class(sf_os_mapping_single_t), intent(out) :: mapping real(default), intent(in) :: m call mapping%base_init (1) mapping%m = m mapping%lm2 = abs (2 * log (mapping%m)) end subroutine sf_os_mapping_single_init @ %def sf_os_mapping_single_init @ Apply mapping. The [[x_free]] parameter rescales the total energy, which must be accounted for in the enclosed mapping. <>= procedure :: compute => sf_os_mapping_single_compute <>= subroutine sf_os_mapping_single_compute (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: r2, p2 integer :: j p2 = p(mapping%i) call map_on_shell_single (r2, f, p2, mapping%lm2, x_free) r = p rb= pb r (mapping%i(1)) = r2(1) rb(mapping%i(1)) = 1 - r2(1) end subroutine sf_os_mapping_single_compute @ %def sf_os_mapping_single_compute @ Apply inverse. The irrelevant parameter $p_1$ is always set zero. <>= procedure :: inverse => sf_os_mapping_single_inverse <>= subroutine sf_os_mapping_single_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_os_mapping_single_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(1) :: p2, r2 r2 = r(mapping%i) call map_on_shell_single_inverse (r2, f, p2, mapping%lm2, x_free) p = r pb= rb p (mapping%i(1)) = p2(1) pb(mapping%i(1)) = 1 - p2(1) end subroutine sf_os_mapping_single_inverse @ %def sf_os_mapping_single_inverse @ \subsection{Implementation: endpoint mapping} This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that any power-like singularity is caught. This is useful for beamstrahlung spectra. In addition, we allow for a delta-function singularity in $r_1$ and/or $r_2$. The singularity is smeared to an interval of width $\epsilon$. If nonzero, we distinguish the kinematical momentum fractions $r_i$ from effective values $x_i$, which should go into the structure-function evaluation. A bin of width $\epsilon$ in $r$ is mapped to $x=1$ exactly, while the interval $(0,1-\epsilon)$ is mapped to $(0,1)$ in $x$. The Jacobian reflects this distinction, and the logical [[in_peak]] allows for an unambiguous distinction. The delta-peak fraction is used only for the integration self-test. <>= public :: sf_ep_mapping_t <>= type, extends (sf_mapping_t) :: sf_ep_mapping_t real(default) :: a = 1 contains <> end type sf_ep_mapping_t @ %def sf_ep_mapping_t @ Output. <>= procedure :: write => sf_ep_mapping_write <>= subroutine sf_ep_mapping_write (object, unit) class(sf_ep_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,ES12.5,A)") ": endpoint (a =", object%a, ")" end subroutine sf_ep_mapping_write @ %def sf_ep_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ep_mapping_init <>= subroutine sf_ep_mapping_init (mapping, a) class(sf_ep_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a call mapping%base_init (2) if (present (a)) mapping%a = a end subroutine sf_ep_mapping_init @ %def sf_ep_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ep_mapping_compute <>= subroutine sf_ep_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ep_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, r2 real(default) :: f1, f2 integer :: j call map_endpoint_1 (px(1), f1, p(mapping%i(1)), mapping%a) call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a) call map_unit_square (r2, f, px) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_ep_mapping_compute @ %def sf_ep_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ep_mapping_inverse <>= subroutine sf_ep_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ep_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, px, p2 real(default) :: f1, f2 integer :: j do j = 1, 2 r2(j) = r(mapping%i(j)) end do call map_unit_square_inverse (r2, f, px) call map_endpoint_inverse_1 (px(1), f1, p2(1), mapping%a) call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a) f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_ep_mapping_inverse @ %def sf_ep_mapping_inverse @ \subsection{Implementation: endpoint mapping with resonance} Like the endpoint mapping for $p_2$, but replace the endpoint mapping by a Breit-Wigner mapping for $p_1$. This covers resonance production in the presence of beamstrahlung. If the flag [[resonance]] is unset, we skip the resonance mapping, so the parameter $p_1$ remains equal to $r_1r_2$, as in the standard s-channel mapping. <>= public :: sf_epr_mapping_t <>= type, extends (sf_mapping_t) :: sf_epr_mapping_t real(default) :: a = 1 real(default) :: m = 0 real(default) :: w = 0 logical :: resonance = .true. contains <> end type sf_epr_mapping_t @ %def sf_epr_mapping_t @ Output. <>= procedure :: write => sf_epr_mapping_write <>= subroutine sf_epr_mapping_write (object, unit) class(sf_epr_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if if (object%resonance) then write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)") ": ep/res (a = ", object%a, & " | ", object%m, object%w, ")" else write (u, "(A,F7.5,A)") ": ep/nores (a = ", object%a, ")" end if end subroutine sf_epr_mapping_write @ %def sf_epr_mapping_write @ Initialize: if mass and width are not given, we initialize a non-resonant version of the mapping. <>= procedure :: init => sf_epr_mapping_init <>= subroutine sf_epr_mapping_init (mapping, a, m, w) class(sf_epr_mapping_t), intent(out) :: mapping real(default), intent(in) :: a real(default), intent(in), optional :: m, w call mapping%base_init (2) mapping%a = a if (present (m) .and. present (w)) then mapping%m = m mapping%w = w else mapping%resonance = .false. end if end subroutine sf_epr_mapping_init @ %def sf_epr_mapping_init @ Apply mapping. <>= procedure :: compute => sf_epr_mapping_compute <>= subroutine sf_epr_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_epr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, r2 real(default) :: f1, f2 integer :: j if (mapping%resonance) then call map_breit_wigner & (px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free) else px(1) = p(mapping%i(1)) f1 = 1 end if call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a) call map_unit_square (r2, f, px) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_epr_mapping_compute @ %def sf_epr_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_epr_mapping_inverse <>= subroutine sf_epr_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_epr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, p2 real(default) :: f1, f2 integer :: j call map_unit_square_inverse (r(mapping%i), f, px) if (mapping%resonance) then call map_breit_wigner_inverse & (px(1), f1, p2(1), mapping%m, mapping%w, x_free) else p2(1) = px(1) f1 = 1 end if call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a) f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_epr_mapping_inverse @ %def sf_epr_mapping_inverse @ \subsection{Implementation: endpoint mapping for on-shell particle} Analogous to the resonance mapping, but the $p_1$ input is ignored altogether. This covers on-shell particle production in the presence of beamstrahlung. <>= public :: sf_epo_mapping_t <>= type, extends (sf_mapping_t) :: sf_epo_mapping_t real(default) :: a = 1 real(default) :: m = 0 real(default) :: lm2 = 0 contains <> end type sf_epo_mapping_t @ %def sf_epo_mapping_t @ Output. <>= procedure :: write => sf_epo_mapping_write <>= subroutine sf_epo_mapping_write (object, unit) class(sf_epo_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A)") ": ep/on-shell (a = ", object%a, & " | ", object%m, ")" end subroutine sf_epo_mapping_write @ %def sf_epo_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_epo_mapping_init <>= subroutine sf_epo_mapping_init (mapping, a, m) class(sf_epo_mapping_t), intent(out) :: mapping real(default), intent(in) :: a, m call mapping%base_init (2) mapping%a = a mapping%m = m mapping%lm2 = abs (2 * log (mapping%m)) end subroutine sf_epo_mapping_init @ %def sf_epo_mapping_init @ Apply mapping. <>= procedure :: compute => sf_epo_mapping_compute <>= subroutine sf_epo_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_epo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, r2 real(default) :: f2 integer :: j px(1) = 0 call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a) call map_on_shell (r2, f, px, mapping%lm2) f = f * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2(j) rb(mapping%i(j)) = 1 - r2(j) end do end subroutine sf_epo_mapping_compute @ %def sf_epo_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_epo_mapping_inverse <>= subroutine sf_epo_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_epo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, p2 real(default) :: f2 integer :: j call map_on_shell_inverse (r(mapping%i), f, px, mapping%lm2) p2(1) = 0 call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a) f = f * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = 1 - p2(j) end do end subroutine sf_epo_mapping_inverse @ %def sf_epo_mapping_inverse @ \subsection{Implementation: ISR endpoint mapping} Similar to the endpoint mapping above: This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is flattened. This would be easy in one dimension, but becomes nontrivial in two dimensions. <>= public :: sf_ip_mapping_t <>= type, extends (sf_mapping_t) :: sf_ip_mapping_t real(default) :: eps = 0 contains <> end type sf_ip_mapping_t @ %def sf_ip_mapping_t @ Output. <>= procedure :: write => sf_ip_mapping_write <>= subroutine sf_ip_mapping_write (object, unit) class(sf_ip_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,ES12.5,A)") ": isr (eps =", object%eps, ")" end subroutine sf_ip_mapping_write @ %def sf_ip_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ip_mapping_init <>= subroutine sf_ip_mapping_init (mapping, eps) class(sf_ip_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps call mapping%base_init (2) if (present (eps)) mapping%eps = eps if (mapping%eps <= 0) & call msg_fatal ("ISR mapping: regulator epsilon must not be zero") end subroutine sf_ip_mapping_init @ %def sf_ip_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ip_mapping_compute <>= subroutine sf_ip_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ip_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, pxb, r2, r2b real(default) :: f1, f2, xb, y, yb integer :: j call map_power_1 (xb, f1, pb(mapping%i(1)), 2 * mapping%eps) call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps) px(1) = 1 - xb pxb(1) = xb px(2) = y pxb(2) = yb call map_unit_square_prec (r2, r2b, f, px, pxb) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2 (j) rb(mapping%i(j)) = r2b(j) end do end subroutine sf_ip_mapping_compute @ %def sf_ip_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ip_mapping_inverse <>= subroutine sf_ip_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ip_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b real(default) :: f1, f2, xb, y, yb integer :: j do j = 1, 2 r2 (j) = r (mapping%i(j)) r2b(j) = rb(mapping%i(j)) end do call map_unit_square_inverse_prec (r2, r2b, f, px, pxb) xb = pxb(1) if (px(1) > 0) then y = px(2) yb = pxb(2) else y = 0.5_default yb = 0.5_default end if call map_power_inverse_1 (xb, f1, p2b(1), 2 * mapping%eps) call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps) p2 = 1 - p2b f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = p2b(j) end do end subroutine sf_ip_mapping_inverse @ %def sf_ip_mapping_inverse @ \subsection{Implementation: ISR endpoint mapping, resonant} Similar to the endpoint mapping above: This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is flattened. This would be easy in one dimension, but becomes nontrivial in two dimensions. The resonance can be turned off by the flag [[resonance]]. <>= public :: sf_ipr_mapping_t <>= type, extends (sf_mapping_t) :: sf_ipr_mapping_t real(default) :: eps = 0 real(default) :: m = 0 real(default) :: w = 0 logical :: resonance = .true. contains <> end type sf_ipr_mapping_t @ %def sf_ipr_mapping_t @ Output. <>= procedure :: write => sf_ipr_mapping_write <>= subroutine sf_ipr_mapping_write (object, unit) class(sf_ipr_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if if (object%resonance) then write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)") ": isr/res (eps = ", & object%eps, " | ", object%m, object%w, ")" else write (u, "(A,F7.5,A)") ": isr/res (eps = ", object%eps, ")" end if end subroutine sf_ipr_mapping_write @ %def sf_ipr_mapping_write @ Initialize: <>= procedure :: init => sf_ipr_mapping_init <>= subroutine sf_ipr_mapping_init (mapping, eps, m, w) class(sf_ipr_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps, m, w call mapping%base_init (2) if (present (eps)) mapping%eps = eps if (mapping%eps <= 0) & call msg_fatal ("ISR mapping: regulator epsilon must not be zero") if (present (m) .and. present (w)) then mapping%m = m mapping%w = w else mapping%resonance = .false. end if end subroutine sf_ipr_mapping_init @ %def sf_ipr_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ipr_mapping_compute <>= subroutine sf_ipr_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ipr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, pxb, r2, r2b real(default) :: f1, f2, y, yb integer :: j if (mapping%resonance) then call map_breit_wigner & (px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free) else px(1) = p(mapping%i(1)) f1 = 1 end if call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps) pxb(1) = 1 - px(1) px(2) = y pxb(2) = yb call map_unit_square_prec (r2, r2b, f, px, pxb) f = f * f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2 (j) rb(mapping%i(j)) = r2b(j) end do end subroutine sf_ipr_mapping_compute @ %def sf_ipr_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ipr_mapping_inverse <>= subroutine sf_ipr_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ipr_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b real(default) :: f1, f2, y, yb integer :: j do j = 1, 2 r2 (j) = r (mapping%i(j)) r2b(j) = rb(mapping%i(j)) end do call map_unit_square_inverse_prec (r2, r2b, f, px, pxb) if (px(1) > 0) then y = px(2) yb = pxb(2) else y = 0.5_default yb = 0.5_default end if if (mapping%resonance) then call map_breit_wigner_inverse & (px(1), f1, p2(1), mapping%m, mapping%w, x_free) else p2(1) = px(1) f1 = 1 end if call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps) p2b(1) = 1 - p2(1) p2 (2) = 1 - p2b(2) f = f * f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = p2b(j) end do end subroutine sf_ipr_mapping_inverse @ %def sf_ipr_mapping_inverse @ \subsection{Implementation: ISR on-shell mapping} Similar to the endpoint mapping above: This maps the unit square ($r_1,r_2$) such that $p_1$ is ignored while the product $r_1r_2$ is constant. $p_2$ is related to the ratio. Furthermore, we enhance the region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$. The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is flattened. This would be easy in one dimension, but becomes nontrivial in two dimensions. <>= public :: sf_ipo_mapping_t <>= type, extends (sf_mapping_t) :: sf_ipo_mapping_t real(default) :: eps = 0 real(default) :: m = 0 contains <> end type sf_ipo_mapping_t @ %def sf_ipo_mapping_t @ Output. <>= procedure :: write => sf_ipo_mapping_write <>= subroutine sf_ipo_mapping_write (object, unit) class(sf_ipo_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,',',I0,')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A)") ": isr/os (eps = ", object%eps, & " | ", object%m, ")" end subroutine sf_ipo_mapping_write @ %def sf_ipo_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ipo_mapping_init <>= subroutine sf_ipo_mapping_init (mapping, eps, m) class(sf_ipo_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: eps, m call mapping%base_init (2) if (present (eps)) mapping%eps = eps if (mapping%eps <= 0) & call msg_fatal ("ISR mapping: regulator epsilon must not be zero") mapping%m = m end subroutine sf_ipo_mapping_init @ %def sf_ipo_mapping_init @ Apply mapping. <>= procedure :: compute => sf_ipo_mapping_compute <>= subroutine sf_ipo_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ipo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: px, pxb, r2, r2b real(default) :: f1, f2, y, yb integer :: j call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps) px(1) = mapping%m ** 2 if (present (x_free)) px(1) = px(1) / x_free pxb(1) = 1 - px(1) px(2) = y pxb(2) = yb call map_unit_square_prec (r2, r2b, f1, px, pxb) f = f1 * f2 r = p rb= pb do j = 1, 2 r (mapping%i(j)) = r2 (j) rb(mapping%i(j)) = r2b(j) end do end subroutine sf_ipo_mapping_compute @ %def sf_ipo_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ipo_mapping_inverse <>= subroutine sf_ipo_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ipo_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b real(default) :: f1, f2, y, yb integer :: j do j = 1, 2 r2 (j) = r (mapping%i(j)) r2b(j) = rb(mapping%i(j)) end do call map_unit_square_inverse_prec (r2, r2b, f1, px, pxb) y = px(2) yb = pxb(2) call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps) p2(1) = 0 p2b(1)= 1 p2(2) = 1 - p2b(2) f = f1 * f2 p = r pb= rb do j = 1, 2 p (mapping%i(j)) = p2(j) pb(mapping%i(j)) = p2b(j) end do end subroutine sf_ipo_mapping_inverse @ %def sf_ipo_mapping_inverse @ \subsection{Implementation: Endpoint + ISR power mapping} This is a combination of endpoint (i.e., beamstrahlung) and ISR power mapping. The first two parameters apply to the beamstrahlung spectrum, the last two to the ISR function for the first and second beam, respectively. <>= public :: sf_ei_mapping_t <>= type, extends (sf_mapping_t) :: sf_ei_mapping_t type(sf_ep_mapping_t) :: ep type(sf_ip_mapping_t) :: ip contains <> end type sf_ei_mapping_t @ %def sf_ei_mapping_t @ Output. <>= procedure :: write => sf_ei_mapping_write <>= subroutine sf_ei_mapping_write (object, unit) class(sf_ei_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,3(',',I0),')')", advance="no") object%i end if write (u, "(A,ES12.5,A,ES12.5,A)") ": ep/isr (a =", object%ep%a, & ", eps =", object%ip%eps, ")" end subroutine sf_ei_mapping_write @ %def sf_ei_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_ei_mapping_init <>= subroutine sf_ei_mapping_init (mapping, a, eps) class(sf_ei_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a, eps call mapping%base_init (4) call mapping%ep%init (a) call mapping%ip%init (eps) end subroutine sf_ei_mapping_init @ %def sf_ei_mapping_init @ Set an index value. We should communicate the appropriate indices to the enclosed sub-mappings, therefore override the method. <>= procedure :: set_index => sf_ei_mapping_set_index <>= subroutine sf_ei_mapping_set_index (mapping, j, i) class(sf_ei_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i select case (j) case (1:2); call mapping%ep%set_index (j, i) case (3:4); call mapping%ip%set_index (j-2, i) end select end subroutine sf_ei_mapping_set_index @ %def sf_mapping_set_index @ Apply mapping. Now, the beamstrahlung and ISR mappings are independent of each other. The parameter subsets that are actually used should not overlap. The Jacobians are multiplied. <>= procedure :: compute => sf_ei_mapping_compute <>= subroutine sf_ei_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_ei_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: q, qb real(default) :: f1, f2 call mapping%ep%compute (q, qb, f1, p, pb, x_free) call mapping%ip%compute (r, rb, f2, q, qb, x_free) f = f1 * f2 end subroutine sf_ei_mapping_compute @ %def sf_ei_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_ei_mapping_inverse <>= subroutine sf_ei_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_ei_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: q, qb real(default) :: f1, f2 call mapping%ip%inverse (r, rb, f2, q, qb, x_free) call mapping%ep%inverse (q, qb, f1, p, pb, x_free) f = f1 * f2 end subroutine sf_ei_mapping_inverse @ %def sf_ei_mapping_inverse @ \subsection{Implementation: Endpoint + ISR + resonance} This is a combination of endpoint (i.e., beamstrahlung) and ISR power mapping, adapted for an s-channel resonance. The first two internal parameters apply to the beamstrahlung spectrum, the last two to the ISR function for the first and second beam, respectively. The first and third parameters are the result of an overall resonance mapping, so on the outside, the first parameter is the total momentum fraction, the third one describes the distribution between beamstrahlung and ISR. <>= public :: sf_eir_mapping_t <>= type, extends (sf_mapping_t) :: sf_eir_mapping_t type(sf_res_mapping_t) :: res type(sf_epr_mapping_t) :: ep type(sf_ipr_mapping_t) :: ip contains <> end type sf_eir_mapping_t @ %def sf_eir_mapping_t @ Output. <>= procedure :: write => sf_eir_mapping_write <>= subroutine sf_eir_mapping_write (object, unit) class(sf_eir_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,3(',',I0),')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A,F7.5,', ',F7.5,A)") & ": ep/isr/res (a =", object%ep%a, & ", eps =", object%ip%eps, " | ", object%res%m, object%res%w, ")" end subroutine sf_eir_mapping_write @ %def sf_eir_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_eir_mapping_init <>= subroutine sf_eir_mapping_init (mapping, a, eps, m, w) class(sf_eir_mapping_t), intent(out) :: mapping real(default), intent(in) :: a, eps, m, w call mapping%base_init (4) call mapping%res%init (m, w) call mapping%ep%init (a) call mapping%ip%init (eps) end subroutine sf_eir_mapping_init @ %def sf_eir_mapping_init @ Set an index value. We should communicate the appropriate indices to the enclosed sub-mappings, therefore override the method. <>= procedure :: set_index => sf_eir_mapping_set_index <>= subroutine sf_eir_mapping_set_index (mapping, j, i) class(sf_eir_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i select case (j) case (1); call mapping%res%set_index (1, i) case (3); call mapping%res%set_index (2, i) end select select case (j) case (1:2); call mapping%ep%set_index (j, i) case (3:4); call mapping%ip%set_index (j-2, i) end select end subroutine sf_eir_mapping_set_index @ %def sf_mapping_set_index @ Apply mapping. Now, the beamstrahlung and ISR mappings are independent of each other. The parameter subsets that are actually used should not overlap. The Jacobians are multiplied. <>= procedure :: compute => sf_eir_mapping_compute <>= subroutine sf_eir_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_eir_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%res%compute (px, pxb, f0, p, pb, x_free) call mapping%ep%compute (q, qb, f1, px, pxb, x_free) call mapping%ip%compute (r, rb, f2, q, qb, x_free) f = f0 * f1 * f2 end subroutine sf_eir_mapping_compute @ %def sf_eir_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_eir_mapping_inverse <>= subroutine sf_eir_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_eir_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%ip%inverse (r, rb, f2, q, qb, x_free) call mapping%ep%inverse (q, qb, f1, px, pxb, x_free) call mapping%res%inverse (px, pxb, f0, p, pb, x_free) f = f0 * f1 * f2 end subroutine sf_eir_mapping_inverse @ %def sf_eir_mapping_inverse @ \subsection{Implementation: Endpoint + ISR power mapping, on-shell} This is a combination of endpoint (i.e., beamstrahlung) and ISR power mapping. The first two parameters apply to the beamstrahlung spectrum, the last two to the ISR function for the first and second beam, respectively. On top of that, we map the first and third parameter such that the product is constant. From the outside, the first parameter is irrelevant while the third parameter describes the distribution of energy (loss) among beamstrahlung and ISR. <>= public :: sf_eio_mapping_t <>= type, extends (sf_mapping_t) :: sf_eio_mapping_t type(sf_os_mapping_t) :: os type(sf_epr_mapping_t) :: ep type(sf_ipr_mapping_t) :: ip contains <> end type sf_eio_mapping_t @ %def sf_eio_mapping_t @ Output. <>= procedure :: write => sf_eio_mapping_write <>= subroutine sf_eio_mapping_write (object, unit) class(sf_eio_mapping_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "map" if (any (object%i /= 0)) then write (u, "('(',I0,3(',',I0),')')", advance="no") object%i end if write (u, "(A,F7.5,A,F7.5,A,F7.5,A)") ": ep/isr/os (a =", object%ep%a, & ", eps =", object%ip%eps, " | ", object%os%m, ")" end subroutine sf_eio_mapping_write @ %def sf_eio_mapping_write @ Initialize: no extra parameters. <>= procedure :: init => sf_eio_mapping_init <>= subroutine sf_eio_mapping_init (mapping, a, eps, m) class(sf_eio_mapping_t), intent(out) :: mapping real(default), intent(in), optional :: a, eps, m call mapping%base_init (4) call mapping%os%init (m) call mapping%ep%init (a) call mapping%ip%init (eps) end subroutine sf_eio_mapping_init @ %def sf_eio_mapping_init @ Set an index value. We should communicate the appropriate indices to the enclosed sub-mappings, therefore override the method. <>= procedure :: set_index => sf_eio_mapping_set_index <>= subroutine sf_eio_mapping_set_index (mapping, j, i) class(sf_eio_mapping_t), intent(inout) :: mapping integer, intent(in) :: j, i mapping%i(j) = i select case (j) case (1); call mapping%os%set_index (1, i) case (3); call mapping%os%set_index (2, i) end select select case (j) case (1:2); call mapping%ep%set_index (j, i) case (3:4); call mapping%ip%set_index (j-2, i) end select end subroutine sf_eio_mapping_set_index @ %def sf_mapping_set_index @ Apply mapping. Now, the beamstrahlung and ISR mappings are independent of each other. The parameter subsets that are actually used should not overlap. The Jacobians are multiplied. <>= procedure :: compute => sf_eio_mapping_compute <>= subroutine sf_eio_mapping_compute (mapping, r, rb, f, p, pb, x_free) class(sf_eio_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(out) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%os%compute (px, pxb, f0, p, pb, x_free) call mapping%ep%compute (q, qb, f1, px, pxb, x_free) call mapping%ip%compute (r, rb, f2, q, qb, x_free) f = f0 * f1 * f2 end subroutine sf_eio_mapping_compute @ %def sf_eio_mapping_compute @ Apply inverse. <>= procedure :: inverse => sf_eio_mapping_inverse <>= subroutine sf_eio_mapping_inverse (mapping, r, rb, f, p, pb, x_free) class(sf_eio_mapping_t), intent(inout) :: mapping real(default), dimension(:), intent(in) :: r, rb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: p, pb real(default), intent(inout), optional :: x_free real(default), dimension(size(p)) :: px, pxb, q, qb real(default) :: f0, f1, f2 call mapping%ip%inverse (r, rb, f2, q, qb, x_free) call mapping%ep%inverse (q, qb, f1, px, pxb, x_free) call mapping%os%inverse (px, pxb, f0, p, pb, x_free) f = f0 * f1 * f2 end subroutine sf_eio_mapping_inverse @ %def sf_eio_mapping_inverse @ \subsection{Basic formulas} \subsubsection{Standard mapping of the unit square} This mapping of the unit square is appropriate in particular for structure functions which are concentrated at the lower end. Instead of a rectangular grid, one set of grid lines corresponds to constant parton c.m. energy. The other set is chosen such that the jacobian is only mildly singular ($\ln x$ which is zero at $x=1$), corresponding to an initial concentration of sampling points at the maximum energy. If [[power]] is greater than one (the default), points are also concentrated at the lower end. The formula is ([[power]]=$\alpha$): \begin{align} r_1 &= (p_1 ^ {p_2})^\alpha \\ r_2 &= (p_1 ^ {1 - p_2})^\alpha\\ f &= \alpha^2 p_1 ^ {\alpha - 1} |\log p_1| \end{align} and for the default case $\alpha=1$: \begin{align} r_1 &= p_1 ^ {p_2} \\ r_2 &= p_1 ^ {1 - p_2} \\ f &= |\log p_1| \end{align} <>= subroutine map_unit_square (r, factor, p, power) real(default), dimension(2), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), intent(in), optional :: power real(default) :: xx, yy factor = 1 xx = p(1) yy = p(2) if (present(power)) then if (p(1) > 0 .and. power > 1) then xx = p(1)**power factor = factor * power * xx / p(1) end if end if if (.not. vanishes (xx)) then r(1) = xx ** yy r(2) = xx / r(1) factor = factor * abs (log (xx)) else r = 0 end if end subroutine map_unit_square @ %def map_unit_square @ This is the inverse mapping. <>= subroutine map_unit_square_inverse (r, factor, p, power) real(kind=default), dimension(2), intent(in) :: r real(kind=default), intent(out) :: factor real(kind=default), dimension(2), intent(out) :: p real(kind=default), intent(in), optional :: power real(kind=default) :: lg, xx, yy factor = 1 xx = r(1) * r(2) if (.not. vanishes (xx)) then lg = log (xx) if (.not. vanishes (lg)) then yy = log (r(1)) / lg else yy = 0 end if p(2) = yy factor = factor * abs (lg) if (present(power)) then p(1) = xx**(1._default/power) factor = factor * power * xx / p(1) else p(1) = xx end if else p = 0 end if end subroutine map_unit_square_inverse @ %def map_unit_square_inverse @ \subsubsection{Precise mapping of the unit square} A more precise version (with unit power parameter). This version should be numerically stable near $x=1$ and $y=0,1$. The formulas are again \begin{equation} r_1 = p_1^{p_2}, \qquad r_2 = p_1^{\bar p_2}, \qquad f = - \log p_1 \end{equation} but we compute both $r_i$ and $\bar r_i$ simultaneously and make direct use of both $p_i$ and $\bar p_i$ as appropriate. <>= subroutine map_unit_square_prec (r, rb, factor, p, pb) real(default), dimension(2), intent(out) :: r real(default), dimension(2), intent(out) :: rb real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), dimension(2), intent(in) :: pb if (p(1) > 0.5_default) then call compute_prec_xy_1 (r(1), rb(1), p(1), pb(1), p (2)) call compute_prec_xy_1 (r(2), rb(2), p(1), pb(1), pb(2)) factor = - log_prec (p(1), pb(1)) else if (.not. vanishes (p(1))) then call compute_prec_xy_0 (r(1), rb(1), p(1), pb(1), p (2)) call compute_prec_xy_0 (r(2), rb(2), p(1), pb(1), pb(2)) factor = - log_prec (p(1), pb(1)) else r = 0 rb = 1 factor = 0 end if end subroutine map_unit_square_prec @ %def map_unit_square_prec @ This is the inverse mapping. <>= subroutine map_unit_square_inverse_prec (r, rb, factor, p, pb) real(default), dimension(2), intent(in) :: r real(default), dimension(2), intent(in) :: rb real(default), intent(out) :: factor real(default), dimension(2), intent(out) :: p real(default), dimension(2), intent(out) :: pb call inverse_prec_x (r, rb, p(1), pb(1)) if (all (r > 0)) then if (rb(1) < rb(2)) then call inverse_prec_y (r, rb, p(2), pb(2)) else call inverse_prec_y ([r(2),r(1)], [rb(2),rb(1)], pb(2), p(2)) end if factor = - log_prec (p(1), pb(1)) else p(1) = 0 pb(1) = 1 p(2) = 0.5_default pb(2) = 0.5_default factor = 0 end if end subroutine map_unit_square_inverse_prec @ %def map_unit_square_prec_inverse @ This is an auxiliary function: evaluate the expression $\bar z = 1 - x^y$ in a numerically stable way. Instabilities occur for $y=0$ and $x=1$. The idea is to replace the bracket by the first terms of its Taylor expansion around $x=1$ (read $\bar x\equiv 1 -x$) \begin{equation} 1 - x^y = y\bar x\left(1 + \frac12(1-y)\bar x + \frac16(2-y)(1-y)\bar x^2\right) \end{equation} whenever this is the better approximation. Actually, the relative numerical error of the exact formula is about $\eta/(y\bar x)$ where $\eta$ is given by [[epsilon(KIND)]] in Fortran. The relative error of the approximation is better than the last included term divided by $(y\bar x)$. The first subroutine computes $z$ and $\bar z$ near $x=1$ where $\log x$ should be expanded, the second one near $x=0$ where $\log x$ can be kept. <>= subroutine compute_prec_xy_1 (z, zb, x, xb, y) real(default), intent(out) :: z, zb real(default), intent(in) :: x, xb, y real(default) :: a1, a2, a3 a1 = y * xb a2 = a1 * (1 - y) * xb / 2 a3 = a2 * (2 - y) * xb / 3 if (abs (a3) < epsilon (a3)) then zb = a1 + a2 + a3 z = 1 - zb else z = x ** y zb = 1 - z end if end subroutine compute_prec_xy_1 subroutine compute_prec_xy_0 (z, zb, x, xb, y) real(default), intent(out) :: z, zb real(default), intent(in) :: x, xb, y real(default) :: a1, a2, a3, lx lx = -log (x) a1 = y * lx a2 = a1 * y * lx / 2 a3 = a2 * y * lx / 3 if (abs (a3) < epsilon (a3)) then zb = a1 + a2 + a3 z = 1 - zb else z = x ** y zb = 1 - z end if end subroutine compute_prec_xy_0 @ %def compute_prec_xy_1 @ %def compute_prec_xy_0 @ For the inverse calculation, we evaluate $x=r_1r_2$ in a stable way. Since it is just a polynomial, the expansion near $x=1$ is analytically exact, and we don't need to choose based on precision. <>= subroutine inverse_prec_x (r, rb, x, xb) real(default), dimension(2), intent(in) :: r, rb real(default), intent(out) :: x, xb real(default) :: a0, a1 a0 = rb(1) + rb(2) a1 = rb(1) * rb(2) if (a0 > 0.5_default) then xb = a0 - a1 x = 1 - xb else x = r(1) * r(2) xb = 1 - x end if end subroutine inverse_prec_x @ %def inverse_prec_x @ The inverse calculation for the relative momentum fraction \begin{equation} y = \frac{1}{1 + \frac{\log{r_2}}{\log{r_1}}} \end{equation} is slightly more complicated. We should take the precise form of the logarithm, so we are safe near $r_i=1$. A series expansion is required if $r_1\ll r_2$, since then $y$ becomes small. (We assume $r_1>= subroutine inverse_prec_y (r, rb, y, yb) real(default), dimension(2), intent(in) :: r, rb real(default), intent(out) :: y, yb real(default) :: log1, log2, a1, a2, a3 log1 = log_prec (r(1), rb(1)) log2 = log_prec (r(2), rb(2)) if (abs (log2**3) < epsilon (one)) then if (abs(log1) < epsilon (one)) then y = zero else y = one / (one + log2 / log1) end if if (abs(log2) < epsilon (one)) then yb = zero else yb = one / (one + log1 / log2) end if return end if a1 = - rb(1) / log2 a2 = - rb(1) ** 2 * (one / log2**2 + one / (2 * log2)) a3 = - rb(1) ** 3 * (one / log2**3 + one / log2**2 + one/(3 * log2)) if (abs (a3) < epsilon (a3)) then y = a1 + a2 + a3 yb = one - y else y = one / (one + log2 / log1) yb = one / (one + log1 / log2) end if end subroutine inverse_prec_y @ %def inverse_prec_y @ \subsubsection{Mapping for on-shell s-channel} The limiting case, if the product $r_1r_2$ is fixed for on-shell production. The parameter $p_1$ is ignored. In the inverse mapping, it is returned zero. The parameter [[x_free]], if present, rescales the total energy. If it is less than one, the rescaled mass parameter $m^2$ should be increased accordingly. Public for access in unit test. <>= public :: map_on_shell public :: map_on_shell_inverse <>= subroutine map_on_shell (r, factor, p, lm2, x_free) real(default), dimension(2), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(in) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) r(1) = exp (- p(2) * lx) r(2) = exp (- (1 - p(2)) * lx) factor = lx end subroutine map_on_shell subroutine map_on_shell_inverse (r, factor, p, lm2, x_free) real(default), dimension(2), intent(in) :: r real(default), intent(out) :: factor real(default), dimension(2), intent(out) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) p(1) = 0 p(2) = abs (log (r(1))) / lx factor = lx end subroutine map_on_shell_inverse @ %def map_on_shell @ %def map_on_shell_inverse @ \subsubsection{Mapping for on-shell s-channel, single parameter} This is a pseudo-mapping which applies if there is actually just one parameter [[p]]. The output parameter [[r]] is fixed for on-shell production. The lone parameter $p_1$ is ignored. In the inverse mapping, it is returned zero. The parameter [[x_free]], if present, rescales the total energy. If it is less than one, the rescaled mass parameter $m^2$ should be increased accordingly. Public for access in unit test. <>= public :: map_on_shell_single public :: map_on_shell_single_inverse <>= subroutine map_on_shell_single (r, factor, p, lm2, x_free) real(default), dimension(1), intent(out) :: r real(default), intent(out) :: factor real(default), dimension(1), intent(in) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) r(1) = exp (- lx) factor = 1 end subroutine map_on_shell_single subroutine map_on_shell_single_inverse (r, factor, p, lm2, x_free) real(default), dimension(1), intent(in) :: r real(default), intent(out) :: factor real(default), dimension(1), intent(out) :: p real(default), intent(in) :: lm2 real(default), intent(in), optional :: x_free real(default) :: lx lx = lm2; if (present (x_free)) lx = lx + log (x_free) p(1) = 0 factor = 1 end subroutine map_on_shell_single_inverse @ %def map_on_shell_single @ %def map_on_shell_single_inverse @ \subsubsection{Mapping for a Breit-Wigner resonance} This is the standard Breit-Wigner mapping. We apply it to a single variable, independently of or in addition to a unit-square mapping. We assume here that the limits for the variable are 0 and 1, and that the mass $m$ and width $w$ are rescaled appropriately, so they are dimensionless and usually between 0 and 1. If [[x_free]] is set, it rescales the total energy and thus mass and width, since these are defined with respect to the total energy. <>= subroutine map_breit_wigner (r, factor, p, m, w, x_free) real(default), intent(out) :: r real(default), intent(out) :: factor real(default), intent(in) :: p real(default), intent(in) :: m real(default), intent(in) :: w real(default), intent(in), optional :: x_free real(default) :: m2, mw, a1, a2, a3, z, tmp m2 = m ** 2 mw = m * w if (present (x_free)) then m2 = m2 / x_free mw = mw / x_free end if a1 = atan (- m2 / mw) a2 = atan ((1 - m2) / mw) a3 = (a2 - a1) * mw z = (1-p) * a1 + p * a2 if (-pi/2 < z .and. z < pi/2) then tmp = tan (z) r = max (m2 + mw * tmp, 0._default) factor = a3 * (1 + tmp ** 2) else r = 0 factor = 0 end if end subroutine map_breit_wigner subroutine map_breit_wigner_inverse (r, factor, p, m, w, x_free) real(default), intent(in) :: r real(default), intent(out) :: factor real(default), intent(out) :: p real(default), intent(in) :: m real(default), intent(in) :: w real(default) :: m2, mw, a1, a2, a3, tmp real(default), intent(in), optional :: x_free m2 = m ** 2 mw = m * w if (present (x_free)) then m2 = m2 / x_free mw = mw / x_free end if a1 = atan (- m2 / mw) a2 = atan ((1 - m2) / mw) a3 = (a2 - a1) * mw tmp = (r - m2) / mw p = (atan (tmp) - a1) / (a2 - a1) factor = a3 * (1 + tmp ** 2) end subroutine map_breit_wigner_inverse @ %def map_breit_wigner @ %def map_breit_wigner_inverse @ \subsubsection{Mapping with endpoint enhancement} This is a mapping which is close to the unit mapping, except that at the endpoint(s), the output values are exponentially enhanced. \begin{equation} y = \tanh (a \tan (\frac{\pi}{2}x)) \end{equation} We have two variants: one covers endpoints at $0$ and $1$ symmetrically, while the other one (which essentially maps one-half of the range), covers only the endpoint at $1$. <>= subroutine map_endpoint_1 (x3, factor, x1, a) real(default), intent(out) :: x3, factor real(default), intent(in) :: x1 real(default), intent(in) :: a real(default) :: x2 if (abs (x1) < 1) then x2 = tan (x1 * pi / 2) x3 = tanh (a * x2) factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2) else x3 = x1 factor = 0 end if end subroutine map_endpoint_1 subroutine map_endpoint_inverse_1 (x3, factor, x1, a) real(default), intent(in) :: x3 real(default), intent(out) :: x1, factor real(default), intent(in) :: a real(default) :: x2 if (abs (x3) < 1) then x2 = atanh (x3) / a x1 = 2 / pi * atan (x2) factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2) else x1 = x3 factor = 0 end if end subroutine map_endpoint_inverse_1 subroutine map_endpoint_01 (x4, factor, x0, a) real(default), intent(out) :: x4, factor real(default), intent(in) :: x0 real(default), intent(in) :: a real(default) :: x1, x3 x1 = 2 * x0 - 1 call map_endpoint_1 (x3, factor, x1, a) x4 = (x3 + 1) / 2 end subroutine map_endpoint_01 subroutine map_endpoint_inverse_01 (x4, factor, x0, a) real(default), intent(in) :: x4 real(default), intent(out) :: x0, factor real(default), intent(in) :: a real(default) :: x1, x3 x3 = 2 * x4 - 1 call map_endpoint_inverse_1 (x3, factor, x1, a) x0 = (x1 + 1) / 2 end subroutine map_endpoint_inverse_01 @ %def map_endpoint_1 @ %def map_endpoint_inverse_1 @ %def map_endpoint_01 @ %def map_endpoint_inverse_01 @ \subsubsection{Mapping with endpoint enhancement (ISR)} This is another endpoint mapping. It is designed to flatten the ISR singularity which is of power type at $x=1$, i.e., if \begin{equation} \sigma = \int_0^1 dx\,f(x)\,G(x) = \int_0^1 dx\,\epsilon(1-x)^{-1+\epsilon} G(x), \end{equation} we replace this by \begin{equation} r = x^\epsilon \quad\Longrightarrow\quad \sigma = \int_0^1 dr\,G(1- (1-r)^{1/\epsilon}). \end{equation} We expect that $\epsilon$ is small. The actual mapping is $r\to x$ (so $x$ emerges closer to $1$). The Jacobian that we return is thus $1/f(x)$. We compute the mapping in terms of $\bar x\equiv 1 - x$, so we can achieve the required precision. Because some compilers show quite wild numeric fluctuations, we internally convert numeric types to explicit [[double]] precision. <>= public :: map_power_1 public :: map_power_inverse_1 <>= subroutine map_power_1 (xb, factor, rb, eps) real(default), intent(out) :: xb, factor real(default), intent(in) :: rb real(double) :: rb_db, factor_db, eps_db, xb_db real(default), intent(in) :: eps rb_db = real (rb, kind=double) eps_db = real (eps, kind=double) xb_db = rb_db ** (1 / eps_db) if (rb_db > 0) then factor_db = xb_db / rb_db / eps_db factor = real (factor_db, kind=default) else factor = 0 end if xb = real (xb_db, kind=default) end subroutine map_power_1 subroutine map_power_inverse_1 (xb, factor, rb, eps) real(default), intent(in) :: xb real(default), intent(out) :: rb, factor real(double) :: xb_db, factor_db, eps_db, rb_db real(default), intent(in) :: eps xb_db = real (xb, kind=double) eps_db = real (eps, kind=double) rb_db = xb_db ** eps_db if (xb_db > 0) then factor_db = xb_db / rb_db / eps_db factor = real (factor_db, kind=default) else factor = 0 end if rb = real (rb_db, kind=default) end subroutine map_power_inverse_1 @ %def map_power_1 @ %def map_power_inverse_1 @ Here we apply a power mapping to both endpoints. We divide the interval in two equal halves and apply the power mapping for the nearest endpoint, either $0$ or $1$. <>= subroutine map_power_01 (y, yb, factor, r, eps) real(default), intent(out) :: y, yb, factor real(default), intent(in) :: r real(default), intent(in) :: eps real(default) :: u, ub, zp, zm u = 2 * r - 1 if (u > 0) then ub = 2 * (1 - r) call map_power_1 (zm, factor, ub, eps) zp = 2 - zm else if (u < 0) then ub = 2 * r call map_power_1 (zp, factor, ub, eps) zm = 2 - zp else factor = 1 / eps zp = 1 zm = 1 end if y = zp / 2 yb = zm / 2 end subroutine map_power_01 subroutine map_power_inverse_01 (y, yb, factor, r, eps) real(default), intent(in) :: y, yb real(default), intent(out) :: r, factor real(default), intent(in) :: eps real(default) :: ub, zp, zm zp = 2 * y zm = 2 * yb if (zm < zp) then call map_power_inverse_1 (zm, factor, ub, eps) r = 1 - ub / 2 else if (zp < zm) then call map_power_inverse_1 (zp, factor, ub, eps) r = ub / 2 else factor = 1 / eps ub = 1 r = ub / 2 end if end subroutine map_power_inverse_01 @ %def map_power_01 @ %def map_power_inverse_01 @ \subsubsection{Structure-function channels} A structure-function chain parameterization (channel) may contain a mapping that applies to multiple structure functions. This is described by an extension of the [[sf_mapping_t]] type. In addition, it may contain mappings that apply to (other) individual structure functions. The details of these mappings are implementation-specific. The [[sf_channel_t]] type combines this information. It contains an array of map codes, one for each structure-function entry. The code values are: \begin{description} \item[none] MC input parameters $r$ directly become energy fractions $x$ \item[single] default mapping for a single structure-function entry \item[multi/s] map $r\to x$ such that one MC input parameter is $\hat s/s$ \item[multi/resonance] as before, adapted to s-channel resonance \item[multi/on-shell] as before, adapted to an on-shell particle in the s channel \item[multi/endpoint] like multi/s, but enhance the region near $r_i=1$ \item[multi/endpoint/res] endpoint mapping with resonance \item[multi/endpoint/os] endpoint mapping for on-shell \item[multi/power/os] like multi/endpoint, regulating a power singularity \end{description} <>= integer, parameter :: SFMAP_NONE = 0 integer, parameter :: SFMAP_SINGLE = 1 integer, parameter :: SFMAP_MULTI_S = 2 integer, parameter :: SFMAP_MULTI_RES = 3 integer, parameter :: SFMAP_MULTI_ONS = 4 integer, parameter :: SFMAP_MULTI_EP = 5 integer, parameter :: SFMAP_MULTI_EPR = 6 integer, parameter :: SFMAP_MULTI_EPO = 7 integer, parameter :: SFMAP_MULTI_IP = 8 integer, parameter :: SFMAP_MULTI_IPR = 9 integer, parameter :: SFMAP_MULTI_IPO = 10 integer, parameter :: SFMAP_MULTI_EI = 11 integer, parameter :: SFMAP_MULTI_SRS = 13 integer, parameter :: SFMAP_MULTI_SON = 14 @ %def SFMAP_NONE SFMAP_SINGLE @ %def SFMAP_MULTI_S SFMAP_MULTI_RES SFMAP_MULTI_ONS @ %def SFMAP_MULTI_EP SFMAP_MULTI_EPR SFMAP_MULTI_EPO @ %def SFMAP_MULTI_IP SFMAP_MULTI_IPR SFMAP_MULTI_IPO @ %def SFMAP_MULTI_EI @ %def SFMAP_MULTI_SRS SFMAP_MULTI_SON @ Then, it contains an allocatable entry for the multi mapping. This entry holds the MC-parameter indices on which the mapping applies (there may be more than one MC parameter per structure-function entry) and any parameters associated with the mapping. There can be only one multi-mapping per channel. <>= public :: sf_channel_t <>= type :: sf_channel_t integer, dimension(:), allocatable :: map_code class(sf_mapping_t), allocatable :: multi_mapping contains <> end type sf_channel_t @ %def sf_channel_t @ The output format prints a single character for each structure-function entry and, if applicable, an account of the mapping parameters. <>= procedure :: write => sf_channel_write <>= subroutine sf_channel_write (object, unit) class(sf_channel_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) if (allocated (object%map_code)) then do i = 1, size (object%map_code) select case (object%map_code (i)) case (SFMAP_NONE) write (u, "(1x,A)", advance="no") "-" case (SFMAP_SINGLE) write (u, "(1x,A)", advance="no") "+" case (SFMAP_MULTI_S) write (u, "(1x,A)", advance="no") "s" case (SFMAP_MULTI_RES, SFMAP_MULTI_SRS) write (u, "(1x,A)", advance="no") "r" case (SFMAP_MULTI_ONS, SFMAP_MULTI_SON) write (u, "(1x,A)", advance="no") "o" case (SFMAP_MULTI_EP) write (u, "(1x,A)", advance="no") "e" case (SFMAP_MULTI_EPR) write (u, "(1x,A)", advance="no") "p" case (SFMAP_MULTI_EPO) write (u, "(1x,A)", advance="no") "q" case (SFMAP_MULTI_IP) write (u, "(1x,A)", advance="no") "i" case (SFMAP_MULTI_IPR) write (u, "(1x,A)", advance="no") "i" case (SFMAP_MULTI_IPO) write (u, "(1x,A)", advance="no") "i" case (SFMAP_MULTI_EI) write (u, "(1x,A)", advance="no") "i" case default write (u, "(1x,A)", advance="no") "?" end select end do else write (u, "(1x,A)", advance="no") "-" end if if (allocated (object%multi_mapping)) then write (u, "(1x,'/')", advance="no") call object%multi_mapping%write (u) else write (u, *) end if end subroutine sf_channel_write @ %def sf_channel_write @ Initializer for a single [[sf_channel]] object. <>= procedure :: init => sf_channel_init <>= subroutine sf_channel_init (channel, n_strfun) class(sf_channel_t), intent(out) :: channel integer, intent(in) :: n_strfun allocate (channel%map_code (n_strfun)) channel%map_code = SFMAP_NONE end subroutine sf_channel_init @ %def sf_channel_init @ Assignment. This merely copies intrinsic assignment, but apparently the latter is bugged in gfortran 4.6.3, causing memory corruption. <>= generic :: assignment (=) => sf_channel_assign procedure :: sf_channel_assign <>= subroutine sf_channel_assign (copy, original) class(sf_channel_t), intent(out) :: copy type(sf_channel_t), intent(in) :: original allocate (copy%map_code (size (original%map_code))) copy%map_code = original%map_code if (allocated (original%multi_mapping)) then allocate (copy%multi_mapping, source = original%multi_mapping) end if end subroutine sf_channel_assign @ %def sf_channel_assign @ This initializer allocates an array of channels with common number of structure-function entries, therefore it is not a type-bound procedure. <>= public :: allocate_sf_channels <>= subroutine allocate_sf_channels (channel, n_channel, n_strfun) type(sf_channel_t), dimension(:), intent(out), allocatable :: channel integer, intent(in) :: n_channel integer, intent(in) :: n_strfun integer :: c allocate (channel (n_channel)) do c = 1, n_channel call channel(c)%init (n_strfun) end do end subroutine allocate_sf_channels @ %def allocate_sf_channels @ This marks a given subset of indices as single-mapping. <>= procedure :: activate_mapping => sf_channel_activate_mapping <>= subroutine sf_channel_activate_mapping (channel, i_sf) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf channel%map_code(i_sf) = SFMAP_SINGLE end subroutine sf_channel_activate_mapping @ %def sf_channel_activate_mapping @ This sets an s-channel multichannel mapping. The parameter indices are not yet set. <>= procedure :: set_s_mapping => sf_channel_set_s_mapping <>= subroutine sf_channel_set_s_mapping (channel, i_sf, power) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: power channel%map_code(i_sf) = SFMAP_MULTI_S allocate (sf_s_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_s_mapping_t) call mapping%init (power) end select end subroutine sf_channel_set_s_mapping @ %def sf_channel_set_s_mapping @ This sets an s-channel resonance multichannel mapping. <>= procedure :: set_res_mapping => sf_channel_set_res_mapping <>= subroutine sf_channel_set_res_mapping (channel, i_sf, m, w, single) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: m, w logical, intent(in) :: single if (single) then channel%map_code(i_sf) = SFMAP_MULTI_SRS allocate (sf_res_mapping_single_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_res_mapping_single_t) call mapping%init (m, w) end select else channel%map_code(i_sf) = SFMAP_MULTI_RES allocate (sf_res_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_res_mapping_t) call mapping%init (m, w) end select end if end subroutine sf_channel_set_res_mapping @ %def sf_channel_set_res_mapping @ This sets an s-channel on-shell multichannel mapping. The length of the [[i_sf]] array must be 2. (The first parameter actually becomes an irrelevant dummy.) <>= procedure :: set_os_mapping => sf_channel_set_os_mapping <>= subroutine sf_channel_set_os_mapping (channel, i_sf, m, single) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: m logical, intent(in) :: single if (single) then channel%map_code(i_sf) = SFMAP_MULTI_SON allocate (sf_os_mapping_single_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_os_mapping_single_t) call mapping%init (m) end select else channel%map_code(i_sf) = SFMAP_MULTI_ONS allocate (sf_os_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_os_mapping_t) call mapping%init (m) end select end if end subroutine sf_channel_set_os_mapping @ %def sf_channel_set_os_mapping @ This sets an s-channel endpoint mapping. The parameter $a$ is the slope parameter (default 1); increasing it moves the endpoint region (at $x=1$ to lower values in the input parameter. region even more. <>= procedure :: set_ep_mapping => sf_channel_set_ep_mapping <>= subroutine sf_channel_set_ep_mapping (channel, i_sf, a) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a channel%map_code(i_sf) = SFMAP_MULTI_EP allocate (sf_ep_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ep_mapping_t) call mapping%init (a = a) end select end subroutine sf_channel_set_ep_mapping @ %def sf_channel_set_ep_mapping @ This sets a resonant endpoint mapping. <>= procedure :: set_epr_mapping => sf_channel_set_epr_mapping <>= subroutine sf_channel_set_epr_mapping (channel, i_sf, a, m, w) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: a, m, w channel%map_code(i_sf) = SFMAP_MULTI_EPR allocate (sf_epr_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_epr_mapping_t) call mapping%init (a, m, w) end select end subroutine sf_channel_set_epr_mapping @ %def sf_channel_set_epr_mapping @ This sets an on-shell endpoint mapping. <>= procedure :: set_epo_mapping => sf_channel_set_epo_mapping <>= subroutine sf_channel_set_epo_mapping (channel, i_sf, a, m) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in) :: a, m channel%map_code(i_sf) = SFMAP_MULTI_EPO allocate (sf_epo_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_epo_mapping_t) call mapping%init (a, m) end select end subroutine sf_channel_set_epo_mapping @ %def sf_channel_set_epo_mapping @ This sets an s-channel power mapping, regulating a singularity of type $(1-x)^{-1+\epsilon}$. The parameter $\epsilon$ depends on the structure function. <>= procedure :: set_ip_mapping => sf_channel_set_ip_mapping <>= subroutine sf_channel_set_ip_mapping (channel, i_sf, eps) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: eps channel%map_code(i_sf) = SFMAP_MULTI_IP allocate (sf_ip_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ip_mapping_t) call mapping%init (eps) end select end subroutine sf_channel_set_ip_mapping @ %def sf_channel_set_ip_mapping @ This sets an s-channel resonant power mapping, regulating a singularity of type $(1-x)^{-1+\epsilon}$ in the presence of an s-channel resonance. The parameter $\epsilon$ depends on the structure function. <>= procedure :: set_ipr_mapping => sf_channel_set_ipr_mapping <>= subroutine sf_channel_set_ipr_mapping (channel, i_sf, eps, m, w) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: eps, m, w channel%map_code(i_sf) = SFMAP_MULTI_IPR allocate (sf_ipr_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ipr_mapping_t) call mapping%init (eps, m, w) end select end subroutine sf_channel_set_ipr_mapping @ %def sf_channel_set_ipr_mapping @ This sets an on-shell power mapping, regulating a singularity of type $(1-x)^{-1+\epsilon}$ for the production of a single on-shell particle.. The parameter $\epsilon$ depends on the structure function. <>= procedure :: set_ipo_mapping => sf_channel_set_ipo_mapping <>= subroutine sf_channel_set_ipo_mapping (channel, i_sf, eps, m) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: eps, m channel%map_code(i_sf) = SFMAP_MULTI_IPO allocate (sf_ipo_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ipo_mapping_t) call mapping%init (eps, m) end select end subroutine sf_channel_set_ipo_mapping @ %def sf_channel_set_ipo_mapping @ This sets a combined endpoint/ISR mapping. <>= procedure :: set_ei_mapping => sf_channel_set_ei_mapping <>= subroutine sf_channel_set_ei_mapping (channel, i_sf, a, eps) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a, eps channel%map_code(i_sf) = SFMAP_MULTI_EI allocate (sf_ei_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_ei_mapping_t) call mapping%init (a, eps) end select end subroutine sf_channel_set_ei_mapping @ %def sf_channel_set_ei_mapping @ This sets a combined endpoint/ISR mapping with resonance. <>= procedure :: set_eir_mapping => sf_channel_set_eir_mapping <>= subroutine sf_channel_set_eir_mapping (channel, i_sf, a, eps, m, w) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a, eps, m, w channel%map_code(i_sf) = SFMAP_MULTI_EI allocate (sf_eir_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_eir_mapping_t) call mapping%init (a, eps, m, w) end select end subroutine sf_channel_set_eir_mapping @ %def sf_channel_set_eir_mapping @ This sets a combined endpoint/ISR mapping, on-shell. <>= procedure :: set_eio_mapping => sf_channel_set_eio_mapping <>= subroutine sf_channel_set_eio_mapping (channel, i_sf, a, eps, m) class(sf_channel_t), intent(inout) :: channel integer, dimension(:), intent(in) :: i_sf real(default), intent(in), optional :: a, eps, m channel%map_code(i_sf) = SFMAP_MULTI_EI allocate (sf_eio_mapping_t :: channel%multi_mapping) select type (mapping => channel%multi_mapping) type is (sf_eio_mapping_t) call mapping%init (a, eps, m) end select end subroutine sf_channel_set_eio_mapping @ %def sf_channel_set_eio_mapping @ Return true if the mapping code at position [[i_sf]] is [[SFMAP_SINGLE]]. <>= procedure :: is_single_mapping => sf_channel_is_single_mapping <>= function sf_channel_is_single_mapping (channel, i_sf) result (flag) class(sf_channel_t), intent(in) :: channel integer, intent(in) :: i_sf logical :: flag flag = channel%map_code(i_sf) == SFMAP_SINGLE end function sf_channel_is_single_mapping @ %def sf_channel_is_single_mapping @ Return true if the mapping code at position [[i_sf]] is any of the [[SFMAP_MULTI]] mappings. <>= procedure :: is_multi_mapping => sf_channel_is_multi_mapping <>= function sf_channel_is_multi_mapping (channel, i_sf) result (flag) class(sf_channel_t), intent(in) :: channel integer, intent(in) :: i_sf logical :: flag select case (channel%map_code(i_sf)) case (SFMAP_NONE, SFMAP_SINGLE) flag = .false. case default flag = .true. end select end function sf_channel_is_multi_mapping @ %def sf_channel_is_multi_mapping @ Return the number of parameters that the multi-mapping requires. The mapping object must be allocated. <>= procedure :: get_multi_mapping_n_par => sf_channel_get_multi_mapping_n_par <>= function sf_channel_get_multi_mapping_n_par (channel) result (n_par) class(sf_channel_t), intent(in) :: channel integer :: n_par if (allocated (channel%multi_mapping)) then n_par = channel%multi_mapping%get_n_dim () else n_par = 0 end if end function sf_channel_get_multi_mapping_n_par @ %def sf_channel_is_multi_mapping @ Return true if there is any nontrivial mapping in any of the channels. Note: we provide an explicit public function. gfortran 4.6.3 has problems with the alternative implementation as a type-bound procedure for an array base object. <>= public :: any_sf_channel_has_mapping <>= function any_sf_channel_has_mapping (channel) result (flag) type(sf_channel_t), dimension(:), intent(in) :: channel logical :: flag integer :: c flag = .false. do c = 1, size (channel) flag = flag .or. any (channel(c)%map_code /= SFMAP_NONE) end do end function any_sf_channel_has_mapping @ %def any_sf_channel_has_mapping @ Set a parameter index for an active multi mapping. We assume that the index array is allocated properly. <>= procedure :: set_par_index => sf_channel_set_par_index <>= subroutine sf_channel_set_par_index (channel, j, i_par) class(sf_channel_t), intent(inout) :: channel integer, intent(in) :: j integer, intent(in) :: i_par associate (mapping => channel%multi_mapping) if (j >= 1 .and. j <= mapping%get_n_dim ()) then if (mapping%get_index (j) == 0) then call channel%multi_mapping%set_index (j, i_par) else call msg_bug ("Structure-function setup: mapping index set twice") end if else call msg_bug ("Structure-function setup: mapping index out of range") end if end associate end subroutine sf_channel_set_par_index @ %def sf_channel_set_par_index @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_mappings_ut.f90]]>>= <> module sf_mappings_ut use unit_tests use sf_mappings_uti <> <> contains <> end module sf_mappings_ut @ %def sf_mappings_ut @ <<[[sf_mappings_uti.f90]]>>= <> module sf_mappings_uti <> use format_defs, only: FMT_11, FMT_12, FMT_13, FMT_14, FMT_15, FMT_16 use sf_mappings <> <> contains <> end module sf_mappings_uti @ %def sf_mappings_ut @ API: driver for the unit tests below. <>= public :: sf_mappings_test <>= subroutine sf_mappings_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_mappings_test @ %def sf_mappings_test @ \subsubsection{Check standard mapping} Probe the standard mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_1, "sf_mappings_1", & "standard pair mapping", & u, results) <>= public :: sf_mappings_1 <>= subroutine sf_mappings_1 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_1" write (u, "(A)") "* Purpose: probe standard mapping" write (u, "(A)") allocate (sf_s_mapping_t :: mapping) select type (mapping) type is (sf_s_mapping_t) call mapping%init () call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.1):" p = [0.1_default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) allocate (sf_s_mapping_t :: mapping) select type (mapping) type is (sf_s_mapping_t) call mapping%init (power=2._default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select write (u, *) call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.1):" p = [0.1_default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_1" end subroutine sf_mappings_1 @ %def sf_mappings_1 @ \subsubsection{Channel entries} Construct channel entries and print them. <>= call test (sf_mappings_2, "sf_mappings_2", & "structure-function mapping channels", & u, results) <>= public :: sf_mappings_2 <>= subroutine sf_mappings_2 (u) integer, intent(in) :: u type(sf_channel_t), dimension(:), allocatable :: channel integer :: c write (u, "(A)") "* Test output: sf_mappings_2" write (u, "(A)") "* Purpose: construct and display & &mapping-channel objects" write (u, "(A)") call allocate_sf_channels (channel, n_channel = 8, n_strfun = 2) call channel(2)%activate_mapping ([1]) call channel(3)%set_s_mapping ([1,2]) call channel(4)%set_s_mapping ([1,2], power=2._default) call channel(5)%set_res_mapping ([1,2], m = 0.5_default, w = 0.1_default, single = .false.) call channel(6)%set_os_mapping ([1,2], m = 0.5_default, single = .false.) call channel(7)%set_res_mapping ([1], m = 0.5_default, w = 0.1_default, single = .true.) call channel(8)%set_os_mapping ([1], m = 0.5_default, single = .true.) call channel(3)%set_par_index (1, 1) call channel(3)%set_par_index (2, 4) call channel(4)%set_par_index (1, 1) call channel(4)%set_par_index (2, 4) call channel(5)%set_par_index (1, 1) call channel(5)%set_par_index (2, 3) call channel(6)%set_par_index (1, 1) call channel(6)%set_par_index (2, 2) call channel(7)%set_par_index (1, 1) call channel(8)%set_par_index (1, 1) do c = 1, size (channel) write (u, "(I0,':')", advance="no") c call channel(c)%write (u) end do write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_2" end subroutine sf_mappings_2 @ %def sf_mappings_2 @ \subsubsection{Check resonance mapping} Probe the resonance mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. The resonance mass is at $1/2$ the energy, the width is $1/10$. <>= call test (sf_mappings_3, "sf_mappings_3", & "resonant pair mapping", & u, results) <>= public :: sf_mappings_3 <>= subroutine sf_mappings_3 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_3" write (u, "(A)") "* Purpose: probe resonance pair mapping" write (u, "(A)") allocate (sf_res_mapping_t :: mapping) select type (mapping) type is (sf_res_mapping_t) call mapping%init (0.5_default, 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.1):" p = [0.1_default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_3" end subroutine sf_mappings_3 @ %def sf_mappings_3 @ \subsubsection{Check on-shell mapping} Probe the on-shell mapping of the unit square for different parameter values. Also calculates integrals. In this case, the Jacobian is constant and given by $|\log m^2|$, so this is also the value of the integral. The factor results from the variable change in the $\delta$ function $\delta (m^2 - x_1x_2)$ which multiplies the cross section for the case at hand. For the test, the (rescaled) resonance mass is set at $1/2$ the energy. <>= call test (sf_mappings_4, "sf_mappings_4", & "on-shell pair mapping", & u, results) <>= public :: sf_mappings_4 <>= subroutine sf_mappings_4 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_4" write (u, "(A)") "* Purpose: probe on-shell pair mapping" write (u, "(A)") allocate (sf_os_mapping_t :: mapping) select type (mapping) type is (sf_os_mapping_t) call mapping%init (0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0,0.1):" p = [0._default, 0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0,1.0):" p = [0._default, 1.0_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_4" end subroutine sf_mappings_4 @ %def sf_mappings_4 @ \subsubsection{Check endpoint mapping} Probe the endpoint mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_5, "sf_mappings_5", & "endpoint pair mapping", & u, results) <>= public :: sf_mappings_5 <>= subroutine sf_mappings_5 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_5" write (u, "(A)") "* Purpose: probe endpoint pair mapping" write (u, "(A)") allocate (sf_ep_mapping_t :: mapping) select type (mapping) type is (sf_ep_mapping_t) call mapping%init () call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_5" end subroutine sf_mappings_5 @ %def sf_mappings_5 @ \subsubsection{Check endpoint resonant mapping} Probe the endpoint mapping with resonance. Also calculates integrals. <>= call test (sf_mappings_6, "sf_mappings_6", & "endpoint resonant mapping", & u, results) <>= public :: sf_mappings_6 <>= subroutine sf_mappings_6 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_6" write (u, "(A)") "* Purpose: probe endpoint resonant mapping" write (u, "(A)") allocate (sf_epr_mapping_t :: mapping) select type (mapping) type is (sf_epr_mapping_t) call mapping%init (a = 1._default, m = 0.5_default, w = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Same mapping without resonance:" write (u, "(A)") allocate (sf_epr_mapping_t :: mapping) select type (mapping) type is (sf_epr_mapping_t) call mapping%init (a = 1._default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_6" end subroutine sf_mappings_6 @ %def sf_mappings_6 @ \subsubsection{Check endpoint on-shell mapping} Probe the endpoint mapping with an on-shell particle. Also calculates integrals. <>= call test (sf_mappings_7, "sf_mappings_7", & "endpoint on-shell mapping", & u, results) <>= public :: sf_mappings_7 <>= subroutine sf_mappings_7 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p write (u, "(A)") "* Test output: sf_mappings_7" write (u, "(A)") "* Purpose: probe endpoint on-shell mapping" write (u, "(A)") allocate (sf_epo_mapping_t :: mapping) select type (mapping) type is (sf_epo_mapping_t) call mapping%init (a = 1._default, m = 0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0):" p = [0._default, 0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1,0.5):" p = [0.1_default, 0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_7" end subroutine sf_mappings_7 @ %def sf_mappings_7 @ \subsubsection{Check power mapping} Probe the power mapping of the unit square for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_8, "sf_mappings_8", & "power pair mapping", & u, results) <>= public :: sf_mappings_8 <>= subroutine sf_mappings_8 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p, pb write (u, "(A)") "* Test output: sf_mappings_8" write (u, "(A)") "* Purpose: probe power pair mapping" write (u, "(A)") allocate (sf_ip_mapping_t :: mapping) select type (mapping) type is (sf_ip_mapping_t) call mapping%init (eps = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] pb= [0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9,0.5):" p = [0.9_default, 0.5_default] pb= [0.1_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] pb= [0.3_default, 0.8_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.8):" p = [0.7_default, 0.8_default] pb= [0.3_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.99,0.02):" p = [0.99_default, 0.02_default] pb= [0.01_default, 0.98_default] call mapping%check (u, p, pb, FMT_14, FMT_12) write (u, *) write (u, "(A)") "Probe at (0.99,0.98):" p = [0.99_default, 0.98_default] pb= [0.01_default, 0.02_default] call mapping%check (u, p, pb, FMT_14, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_8" end subroutine sf_mappings_8 @ %def sf_mappings_8 @ \subsubsection{Check resonant power mapping} Probe the power mapping of the unit square, adapted for an s-channel resonance, for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_9, "sf_mappings_9", & "power resonance mapping", & u, results) <>= public :: sf_mappings_9 <>= subroutine sf_mappings_9 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p, pb write (u, "(A)") "* Test output: sf_mappings_9" write (u, "(A)") "* Purpose: probe power resonant pair mapping" write (u, "(A)") allocate (sf_ipr_mapping_t :: mapping) select type (mapping) type is (sf_ipr_mapping_t) call mapping%init (eps = 0.1_default, m = 0.5_default, w = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] pb= [0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9,0.5):" p = [0.9_default, 0.5_default] pb= [0.1_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] pb= [0.3_default, 0.8_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.8):" p = [0.7_default, 0.8_default] pb= [0.3_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9999,0.02):" p = [0.9999_default, 0.02_default] pb= [0.0001_default, 0.98_default] call mapping%check (u, p, pb, FMT_11, FMT_12) write (u, *) write (u, "(A)") "Probe at (0.9999,0.98):" p = [0.9999_default, 0.98_default] pb= [0.0001_default, 0.02_default] call mapping%check (u, p, pb, FMT_11, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Same mapping without resonance:" write (u, "(A)") allocate (sf_ipr_mapping_t :: mapping) select type (mapping) type is (sf_ipr_mapping_t) call mapping%init (eps = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.5,0.5):" p = [0.5_default, 0.5_default] pb= [0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9,0.5):" p = [0.9_default, 0.5_default] pb= [0.1_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.2):" p = [0.7_default, 0.2_default] pb= [0.3_default, 0.8_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7,0.8):" p = [0.7_default, 0.8_default] pb= [0.3_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_9" end subroutine sf_mappings_9 @ %def sf_mappings_9 @ \subsubsection{Check on-shell power mapping} Probe the power mapping of the unit square, adapted for single-particle production, for different parameter values. Also calculates integrals. For a finite number of bins, they differ slightly from $1$, but the result is well-defined because we are not using random points. <>= call test (sf_mappings_10, "sf_mappings_10", & "power on-shell mapping", & u, results) <>= public :: sf_mappings_10 <>= subroutine sf_mappings_10 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(2) :: p, pb write (u, "(A)") "* Test output: sf_mappings_10" write (u, "(A)") "* Purpose: probe power on-shell mapping" write (u, "(A)") allocate (sf_ipo_mapping_t :: mapping) select type (mapping) type is (sf_ipo_mapping_t) call mapping%init (eps = 0.1_default, m = 0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0,0.5):" p = [0._default, 0.5_default] pb= [1._default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0,0.02):" p = [0._default, 0.02_default] pb= [1._default, 0.98_default] call mapping%check (u, p, pb, FMT_15, FMT_12) write (u, *) write (u, "(A)") "Probe at (0,0.98):" p = [0._default, 0.98_default] pb= [1._default, 0.02_default] call mapping%check (u, p, pb, FMT_15, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_10" end subroutine sf_mappings_10 @ %def sf_mappings_10 @ \subsubsection{Check combined endpoint-power mapping} Probe the mapping for the beamstrahlung/ISR combination. <>= call test (sf_mappings_11, "sf_mappings_11", & "endpoint/power combined mapping", & u, results) <>= public :: sf_mappings_11 <>= subroutine sf_mappings_11 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(4) :: p, pb write (u, "(A)") "* Test output: sf_mappings_11" write (u, "(A)") "* Purpose: probe power pair mapping" write (u, "(A)") allocate (sf_ei_mapping_t :: mapping) select type (mapping) type is (sf_ei_mapping_t) call mapping%init (eps = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) call mapping%set_index (3, 3) call mapping%set_index (4, 4) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):" p = [0.5_default, 0.5_default, 0.5_default, 0.5_default] pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):" p = [0.7_default, 0.2_default, 0.4_default, 0.8_default] pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):" p = [0.9_default, 0.06_default, 0.95_default, 0.1_default] pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default] call mapping%check (u, p, pb, FMT_13, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_11" end subroutine sf_mappings_11 @ %def sf_mappings_11 @ \subsubsection{Check resonant endpoint-power mapping} Probe the mapping for the beamstrahlung/ISR combination. <>= call test (sf_mappings_12, "sf_mappings_12", & "endpoint/power resonant combined mapping", & u, results) <>= public :: sf_mappings_12 <>= subroutine sf_mappings_12 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(4) :: p, pb write (u, "(A)") "* Test output: sf_mappings_12" write (u, "(A)") "* Purpose: probe resonant combined mapping" write (u, "(A)") allocate (sf_eir_mapping_t :: mapping) select type (mapping) type is (sf_eir_mapping_t) call mapping%init (a = 1._default, & eps = 0.1_default, m = 0.5_default, w = 0.1_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) call mapping%set_index (3, 3) call mapping%set_index (4, 4) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):" p = [0.5_default, 0.5_default, 0.5_default, 0.5_default] pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):" p = [0.7_default, 0.2_default, 0.4_default, 0.8_default] pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):" p = [0.9_default, 0.06_default, 0.95_default, 0.1_default] pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default] call mapping%check (u, p, pb, FMT_15, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_12" end subroutine sf_mappings_12 @ %def sf_mappings_12 @ \subsubsection{Check on-shell endpoint-power mapping} Probe the mapping for the beamstrahlung/ISR combination. <>= call test (sf_mappings_13, "sf_mappings_13", & "endpoint/power on-shell combined mapping", & u, results) <>= public :: sf_mappings_13 <>= subroutine sf_mappings_13 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(4) :: p, pb write (u, "(A)") "* Test output: sf_mappings_13" write (u, "(A)") "* Purpose: probe on-shell combined mapping" write (u, "(A)") allocate (sf_eio_mapping_t :: mapping) select type (mapping) type is (sf_eio_mapping_t) call mapping%init (a = 1._default, eps = 0.1_default, m = 0.5_default) call mapping%set_index (1, 1) call mapping%set_index (2, 2) call mapping%set_index (3, 3) call mapping%set_index (4, 4) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0.5, 0.5, 0.5, 0.5):" p = [0.5_default, 0.5_default, 0.5_default, 0.5_default] pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.7, 0.2, 0.4, 0.8):" p = [0.7_default, 0.2_default, 0.4_default, 0.8_default] pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default] call mapping%check (u, p, pb, FMT_16) write (u, *) write (u, "(A)") "Probe at (0.9, 0.06, 0.95, 0.1):" p = [0.9_default, 0.06_default, 0.95_default, 0.1_default] pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default] call mapping%check (u, p, pb, FMT_14, FMT_12) write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_13" end subroutine sf_mappings_13 @ %def sf_mappings_13 @ \subsubsection{Check rescaling} Check the rescaling factor in on-shell basic mapping. <>= call test (sf_mappings_14, "sf_mappings_14", & "rescaled on-shell mapping", & u, results) <>= public :: sf_mappings_14 <>= subroutine sf_mappings_14 (u) integer, intent(in) :: u real(default), dimension(2) :: p2, r2 real(default), dimension(1) :: p1, r1 real(default) :: f, x_free, m2 write (u, "(A)") "* Test output: sf_mappings_14" write (u, "(A)") "* Purpose: probe rescaling in os mapping" write (u, "(A)") x_free = 0.9_default m2 = 0.5_default write (u, "(A)") "* Two parameters" write (u, "(A)") p2 = [0.1_default, 0.2_default] call map_on_shell (r2, f, p2, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p2 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r2 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r2) write (u, *) call map_on_shell_inverse (r2, f, p2, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p2 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r2 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r2) write (u, "(A)") write (u, "(A)") "* One parameter" write (u, "(A)") p1 = [0.1_default] call map_on_shell_single (r1, f, p1, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p1 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r1 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r1) write (u, *) call map_on_shell_single_inverse (r1, f, p1, -log (m2), x_free) write (u, "(A,9(1x," // FMT_14 // "))") "p =", p1 write (u, "(A,9(1x," // FMT_14 // "))") "r =", r1 write (u, "(A,9(1x," // FMT_14 // "))") "f =", f write (u, "(A,9(1x," // FMT_14 // "))") "*r=", x_free * product (r1) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_14" end subroutine sf_mappings_14 @ %def sf_mappings_14 @ \subsubsection{Check single parameter resonance mapping} Probe the resonance mapping of the unit interval for different parameter values. Also calculates integrals. The resonance mass is at $1/2$ the energy, the width is $1/10$. <>= call test (sf_mappings_15, "sf_mappings_15", & "resonant single mapping", & u, results) <>= public :: sf_mappings_15 <>= subroutine sf_mappings_15 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(1) :: p write (u, "(A)") "* Test output: sf_mappings_15" write (u, "(A)") "* Purpose: probe resonance single mapping" write (u, "(A)") allocate (sf_res_mapping_single_t :: mapping) select type (mapping) type is (sf_res_mapping_single_t) call mapping%init (0.5_default, 0.1_default) call mapping%set_index (1, 1) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0):" p = [0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5):" p = [0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.1):" p = [0.1_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_15" end subroutine sf_mappings_15 @ %def sf_mappings_15 @ \subsubsection{Check single parameter on-shell mapping} Probe the on-shell (pseudo) mapping of the unit interval for different parameter values. Also calculates integrals. The resonance mass is at $1/2$ the energy. <>= call test (sf_mappings_16, "sf_mappings_16", & "on-shell single mapping", & u, results) <>= public :: sf_mappings_16 <>= subroutine sf_mappings_16 (u) integer, intent(in) :: u class(sf_mapping_t), allocatable :: mapping real(default), dimension(1) :: p write (u, "(A)") "* Test output: sf_mappings_16" write (u, "(A)") "* Purpose: probe on-shell single mapping" write (u, "(A)") allocate (sf_os_mapping_single_t :: mapping) select type (mapping) type is (sf_os_mapping_single_t) call mapping%init (0.5_default) call mapping%set_index (1, 1) end select call mapping%write (u) write (u, *) write (u, "(A)") "Probe at (0):" p = [0._default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Probe at (0.5):" p = [0.5_default] call mapping%check (u, p, 1-p, "F7.5") write (u, *) write (u, "(A)") "Compute integral:" write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000) deallocate (mapping) write (u, "(A)") write (u, "(A)") "* Test output end: sf_mappings_16" end subroutine sf_mappings_16 @ %def sf_mappings_16 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Structure function base} <<[[sf_base.f90]]>>= <> module sf_base <> <> use io_units use format_utils, only: write_separator use format_defs, only: FMT_17, FMT_19 use 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) + 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) + 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, rescale, i_sub) import class(sf_int_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub 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. Note: nagfor 5.3.1 appears to be slightly confused with the allocation status. We check both for allocation and nonzero size. <>= procedure :: write => sf_chain_instance_write <>= subroutine sf_chain_instance_write (object, unit, col_verbose) class(sf_chain_instance_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: col_verbose integer :: u, i, c u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "Structure-function chain instance:" call write_sf_status (object%status, u) if (allocated (object%out_sf)) then write (u, "(3x,A)", advance="no") "outgoing (interactions) =" do i = 1, size (object%out_sf) write (u, "(1x,I0,':',I0)", advance="no") & object%out_sf(i), object%out_sf_i(i) end do write (u, *) end if if (object%out_eval /= 0) then write (u, "(3x,A)", advance="no") "outgoing (evaluators) =" do i = 1, size (object%out_sf) write (u, "(1x,I0,':',I0)", advance="no") & object%out_eval, object%out_eval_i(i) end do write (u, *) end if if (allocated (object%sf)) then if (size (object%sf) /= 0) then write (u, "(1x,A)") "Structure-function parameters:" do c = 1, size (object%f) write (u, "(1x,A,I0,A)", advance="no") "Channel #", c, ":" if (c == object%selected_channel) then write (u, "(1x,A)") "[selected]" else write (u, *) end if write (u, "(3x,A,9(1x,F9.7))") "p =", object%p(:,c) write (u, "(3x,A,9(1x,F9.7))") "pb=", object%pb(:,c) write (u, "(3x,A,9(1x,F9.7))") "r =", object%r(:,c) write (u, "(3x,A,9(1x,F9.7))") "rb=", object%rb(:,c) write (u, "(3x,A,9(1x,ES13.7))") "f =", object%f(c) write (u, "(3x,A)", advance="no") "m =" call object%channel(c)%write (u) end do write (u, "(3x,A,9(1x,F9.7))") "x =", object%x write (u, "(3x,A,9(1x,F9.7))") "xb=", object%xb if (.not. all (object%bound)) then write (u, "(3x,A,9(1x,L1))") "bound =", object%bound end if end if end if call write_separator (u) call beam_write (object%beam_t, u, col_verbose = col_verbose) if (allocated (object%sf)) then do i = 1, size (object%sf) associate (sf => object%sf(i)) call write_separator (u) if (allocated (sf%int)) then if (allocated (sf%r)) then write (u, "(1x,A)") "Structure-function parameters:" do c = 1, size (sf%f) write (u, "(1x,A,I0,A)", advance="no") "Channel #", c, ":" if (c == object%selected_channel) then write (u, "(1x,A)") "[selected]" else write (u, *) end if write (u, "(3x,A,9(1x,F9.7))") "r =", sf%r(:,c) write (u, "(3x,A,9(1x,F9.7))") "rb=", sf%rb(:,c) write (u, "(3x,A,9(1x,ES13.7))") "f =", sf%f(c) write (u, "(3x,A,9(1x,L1,7x))") "m =", sf%m(c) end do write (u, "(3x,A,9(1x,F9.7))") "x =", sf%x write (u, "(3x,A,9(1x,F9.7))") "xb=", sf%xb end if call sf%int%write(u) if (.not. sf%eval%is_empty ()) then call sf%eval%write (u, col_verbose = col_verbose) end if end if end associate end do end if end subroutine sf_chain_instance_write @ %def sf_chain_instance_write @ Initialize. This creates a copy of the interactions in the configuration chain, assumed to be properly initialized. In the copy, we allocate the [[p]] etc.\ arrays. The brute-force assignment of the [[sf]] component would be straightforward, but at least gfortran 4.6.3 would like a more fine-grained copy. In any case, the copy is deep as far as allocatables are concerned, but for the contained [[interaction_t]] objects the copy is shallow, as long as we do not bind defined assignment to the type. Therefore, we have to re-assign the [[interaction_t]] components explicitly, this time calling the proper defined assignment. Furthermore, we allocate the parameter arrays for each structure function. <>= procedure :: init => sf_chain_instance_init <>= subroutine sf_chain_instance_init (chain, config, n_channel) class(sf_chain_instance_t), intent(out), target :: chain type(sf_chain_t), intent(in), target :: config integer, intent(in) :: n_channel integer :: i, j integer :: n_par_tot, n_par, n_strfun chain%config => config n_strfun = config%n_strfun chain%beam_t = config%beam_t allocate (chain%out_sf (config%n_in), chain%out_sf_i (config%n_in)) allocate (chain%out_eval_i (config%n_in)) chain%out_sf = 0 chain%out_sf_i = [(i, i = 1, config%n_in)] chain%out_eval_i = chain%out_sf_i n_par_tot = 0 if (n_strfun /= 0) then allocate (chain%sf (n_strfun)) do i = 1, n_strfun associate (sf => chain%sf(i)) allocate (sf%int, source=config%sf(i)%int) sf%int%interaction_t = config%sf(i)%int%interaction_t n_par = size (sf%int%par_index) allocate (sf%r (n_par, n_channel)); sf%r = 0 allocate (sf%rb(n_par, n_channel)); sf%rb= 0 allocate (sf%f (n_channel)); sf%f = 0 allocate (sf%m (n_channel)); sf%m = .false. allocate (sf%x (n_par)); sf%x = 0 allocate (sf%xb(n_par)); sf%xb= 0 n_par_tot = n_par_tot + n_par end associate end do allocate (chain%p (n_par_tot, n_channel)); chain%p = 0 allocate (chain%pb(n_par_tot, n_channel)); chain%pb= 0 allocate (chain%r (n_par_tot, n_channel)); chain%r = 0 allocate (chain%rb(n_par_tot, n_channel)); chain%rb= 0 allocate (chain%f (n_channel)); chain%f = 0 allocate (chain%x (n_par_tot)); chain%x = 0 allocate (chain%xb(n_par_tot)); chain%xb= 0 call allocate_sf_channels & (chain%channel, n_channel=n_channel, n_strfun=n_strfun) end if allocate (chain%bound (n_par_tot), source = .true.) do i = 1, n_strfun associate (sf => chain%sf(i)) if (sf%int%is_generator ()) then do j = 1, size (sf%int%par_index) chain%bound(sf%int%par_index(j)) = .false. end do end if end associate end do chain%status = SF_INITIAL end subroutine sf_chain_instance_init @ %def sf_chain_instance_init @ Manually select a channel. <>= procedure :: select_channel => sf_chain_instance_select_channel <>= subroutine sf_chain_instance_select_channel (chain, channel) class(sf_chain_instance_t), intent(inout) :: chain integer, intent(in), optional :: channel if (present (channel)) then chain%selected_channel = channel else chain%selected_channel = 0 end if end subroutine sf_chain_instance_select_channel @ %def sf_chain_instance_select_channel @ Copy a channel-mapping object to the structure-function chain instance. We assume that assignment is sufficient, i.e., any non-static components of the [[channel]] object are allocatable und thus recursively copied. After the copy, we extract the single-entry mappings and activate them for the individual structure functions. If there is a multi-entry mapping, we obtain the corresponding MC parameter indices and set them in the copy of the channel object. <>= procedure :: set_channel => sf_chain_instance_set_channel <>= subroutine sf_chain_instance_set_channel (chain, c, channel) class(sf_chain_instance_t), intent(inout) :: chain integer, intent(in) :: c type(sf_channel_t), intent(in) :: channel integer :: i, j, k if (chain%status >= SF_INITIAL) then chain%channel(c) = channel j = 0 do i = 1, chain%config%n_strfun associate (sf => chain%sf(i)) sf%m(c) = channel%is_single_mapping (i) if (channel%is_multi_mapping (i)) then do k = 1, size (sf%int%beam_index) j = j + 1 call chain%channel(c)%set_par_index & (j, sf%int%par_index(k)) end do end if end associate end do if (j /= chain%channel(c)%get_multi_mapping_n_par ()) then print *, "index last filled = ", j print *, "number of parameters = ", & chain%channel(c)%get_multi_mapping_n_par () call msg_bug ("Structure-function setup: mapping index mismatch") end if chain%status = SF_INITIAL end if end subroutine sf_chain_instance_set_channel @ %def sf_chain_instance_set_channel @ Link the interactions in the chain. First, link the beam instance to its template in the configuration chain, which should have the appropriate momenta fixed. Then, we follow the chain via the arrays [[out_sf]] and [[out_sf_i]]. The arrays are (up to) two-dimensional, the entries correspond to the beam particle(s). For each beam, the entry [[out_sf]] points to the last interaction that affected this beam, and [[out_sf_i]] is the out-particle index within that interaction. For the initial beam, [[out_sf]] is zero by definition. For each entry in the chain, we scan the affected beams (one or two). We look for [[out_sf]] and link the out-particle there to the corresponding in-particle in the current interaction. Then, we update the entry in [[out_sf]] and [[out_sf_i]] to point to the current interaction. <>= procedure :: link_interactions => sf_chain_instance_link_interactions <>= subroutine sf_chain_instance_link_interactions (chain) class(sf_chain_instance_t), intent(inout), target :: chain type(interaction_t), pointer :: int integer :: i, j, b if (chain%status >= SF_INITIAL) then do b = 1, chain%config%n_in int => beam_get_int_ptr (chain%beam_t) call interaction_set_source_link (int, b, & chain%config%beam_t, b) end do if (allocated (chain%sf)) then do i = 1, size (chain%sf) associate (sf_int => chain%sf(i)%int) do j = 1, size (sf_int%beam_index) b = sf_int%beam_index(j) call link (sf_int%interaction_t, b, sf_int%incoming(j)) chain%out_sf(b) = i chain%out_sf_i(b) = sf_int%outgoing(j) end do end associate end do end if chain%status = SF_DONE_LINKS end if contains subroutine link (int, b, in_index) type(interaction_t), intent(inout) :: int integer, intent(in) :: b, in_index integer :: i i = chain%out_sf(b) select case (i) case (0) call interaction_set_source_link (int, in_index, & chain%beam_t, chain%out_sf_i(b)) case default call int%set_source_link (in_index, & chain%sf(i)%int, chain%out_sf_i(b)) end select end subroutine link end subroutine sf_chain_instance_link_interactions @ %def sf_chain_instance_link_interactions @ Exchange the quantum-number masks between the interactions in the chain, so we can combine redundant entries and detect any obvious mismatch. We proceed first in the forward direction and then backwards again. After this is finished, we finalize initialization by calling the [[setup_constants]] method, which prepares constant data that depend on the matrix element structure. <>= procedure :: exchange_mask => sf_chain_exchange_mask <>= subroutine sf_chain_exchange_mask (chain) class(sf_chain_instance_t), intent(inout), target :: chain type(interaction_t), pointer :: int type(quantum_numbers_mask_t), dimension(:), allocatable :: mask integer :: i if (chain%status >= SF_DONE_LINKS) then if (allocated (chain%sf)) then int => beam_get_int_ptr (chain%beam_t) allocate (mask (int%get_n_out ())) mask = int%get_mask () if (size (chain%sf) /= 0) then do i = 1, size (chain%sf) - 1 call interaction_exchange_mask (chain%sf(i)%int%interaction_t) end do do i = size (chain%sf), 1, -1 call interaction_exchange_mask (chain%sf(i)%int%interaction_t) end do if (any (mask .neqv. int%get_mask ())) then chain%status = SF_FAILED_MASK return end if do i = 1, size (chain%sf) call chain%sf(i)%int%setup_constants () end do end if end if chain%status = SF_DONE_MASK end if end subroutine sf_chain_exchange_mask @ %def sf_chain_exchange_mask @ Initialize the evaluators that connect the interactions in the chain. <>= procedure :: init_evaluators => sf_chain_instance_init_evaluators <>= subroutine sf_chain_instance_init_evaluators (chain, extended_sf) class(sf_chain_instance_t), intent(inout), target :: chain logical, intent(in), optional :: extended_sf type(interaction_t), pointer :: int type(quantum_numbers_mask_t) :: mask integer :: i logical :: yorn yorn = .false.; if (present (extended_sf)) yorn = extended_sf if (chain%status >= SF_DONE_MASK) then if (allocated (chain%sf)) then if (size (chain%sf) /= 0) then mask = quantum_numbers_mask (.false., .false., .true.) int => beam_get_int_ptr (chain%beam_t) do i = 1, size (chain%sf) associate (sf => chain%sf(i)) if (yorn) then if (int%get_n_sub () == 0) then call int%declare_subtraction (n_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 logical, dimension(size (chain%bound)) :: bound integer :: i, j, c if (chain%status >= SF_DONE_CONNECTIONS) then call chain%select_channel (c_sel) int => beam_get_int_ptr (chain%beam_t) call int%receive_momenta () if (allocated (chain%sf)) then if (size (chain%sf) /= 0) then forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL !!! Bug in nagfor 5.3.1(907), fixed in 5.3.1(982) ! chain%p (:,c_sel) = unpack (p_in, chain%bound, 0._default) !!! Workaround: bound = chain%bound chain%p (:,c_sel) = unpack (p_in, bound, 0._default) chain%pb(:,c_sel) = 1 - chain%p(:,c_sel) chain%f = 1 chain%x_free = 1 do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%generate_free (sf%r(:,c_sel), sf%rb(:,c_sel), & chain%x_free) do j = 1, size (sf%x) if (.not. chain%bound(sf%int%par_index(j))) then chain%p (sf%int%par_index(j),c_sel) = sf%r (j,c_sel) chain%pb(sf%int%par_index(j),c_sel) = sf%rb(j,c_sel) end if end do end associate end do if (allocated (chain%channel(c_sel)%multi_mapping)) then call chain%channel(c_sel)%multi_mapping%compute & (chain%r(:,c_sel), chain%rb(:,c_sel), & f_mapping, & chain%p(:,c_sel), chain%pb(:,c_sel), & chain%x_free) chain%f(c_sel) = f_mapping else chain%r (:,c_sel) = chain%p (:,c_sel) chain%rb(:,c_sel) = chain%pb(:,c_sel) chain%f(c_sel) = 1 end if do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%seed_kinematics () do j = 1, size (sf%x) sf%r (j,c_sel) = chain%r (sf%int%par_index(j),c_sel) sf%rb(j,c_sel) = chain%rb(sf%int%par_index(j),c_sel) end do call sf%int%complete_kinematics & (sf%x, sf%xb, sf%f(c_sel), sf%r(:,c_sel), sf%rb(:,c_sel), & sf%m(c_sel)) do j = 1, size (sf%x) chain%x(sf%int%par_index(j)) = sf%x(j) chain%xb(sf%int%par_index(j)) = sf%xb(j) end do if (sf%int%status <= SF_FAILED_KINEMATICS) then chain%status = SF_FAILED_KINEMATICS return end if do c = 1, size (sf%f) if (c /= c_sel) then call sf%int%inverse_kinematics & (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c)) do j = 1, size (sf%x) chain%r (sf%int%par_index(j),c) = sf%r (j,c) chain%rb(sf%int%par_index(j),c) = sf%rb(j,c) end do end if chain%f(c) = chain%f(c) * sf%f(c) end do if (.not. sf%eval%is_empty ()) then call sf%eval%receive_momenta () end if end associate end do do c = 1, size (chain%f) if (c /= c_sel) then if (allocated (chain%channel(c)%multi_mapping)) then call chain%channel(c)%multi_mapping%inverse & (chain%r(:,c), chain%rb(:,c), & f_mapping, & chain%p(:,c), chain%pb(:,c), & chain%x_free) chain%f(c) = chain%f(c) * f_mapping else chain%p (:,c) = chain%r (:,c) chain%pb(:,c) = chain%rb(:,c) end if end if end do end if end if chain%status = SF_DONE_KINEMATICS end if end subroutine sf_chain_instance_compute_kinematics @ %def sf_chain_instance_compute_kinematics @ This is a variant of the previous procedure. We know the $x$ parameters and reconstruct the momenta and the MC input parameters [[p]]. We do not need to select a channel. Note: this is probably redundant, since the method we actually want starts from the momenta, recovers all $x$ parameters, and then inverts mappings. See below [[recover_kinematics]]. <>= procedure :: inverse_kinematics => sf_chain_instance_inverse_kinematics <>= subroutine sf_chain_instance_inverse_kinematics (chain, x, xb) class(sf_chain_instance_t), intent(inout), target :: chain real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb type(interaction_t), pointer :: int real(default) :: f_mapping integer :: i, j, c if (chain%status >= SF_DONE_CONNECTIONS) then call chain%select_channel () int => beam_get_int_ptr (chain%beam_t) call int%receive_momenta () if (allocated (chain%sf)) then chain%f = 1 if (size (chain%sf) /= 0) then forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL chain%x = x chain%xb= xb do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%seed_kinematics () do j = 1, size (sf%x) sf%x(j) = chain%x(sf%int%par_index(j)) sf%xb(j) = chain%xb(sf%int%par_index(j)) end do do c = 1, size (sf%f) call sf%int%inverse_kinematics & (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), & set_momenta = c==1) chain%f(c) = chain%f(c) * sf%f(c) do j = 1, size (sf%x) chain%r (sf%int%par_index(j),c) = sf%r (j,c) chain%rb(sf%int%par_index(j),c) = sf%rb(j,c) end do end do if (.not. sf%eval%is_empty ()) then call sf%eval%receive_momenta () end if end associate end do do c = 1, size (chain%f) if (allocated (chain%channel(c)%multi_mapping)) then call chain%channel(c)%multi_mapping%inverse & (chain%r(:,c), chain%rb(:,c), & f_mapping, & chain%p(:,c), chain%pb(:,c), & chain%x_free) chain%f(c) = chain%f(c) * f_mapping else chain%p (:,c) = chain%r (:,c) chain%pb(:,c) = chain%rb(:,c) end if end do end if end if chain%status = SF_DONE_KINEMATICS end if end subroutine sf_chain_instance_inverse_kinematics @ %def sf_chain_instance_inverse_kinematics @ Recover the kinematics: assuming that the last evaluator has been filled with a valid set of momenta, we travel the momentum links backwards and fill the preceding evaluators and, as a side effect, interactions. We stop at the beam interaction. After all momenta are set, apply the [[inverse_kinematics]] procedure above, suitably modified, to recover the $x$ and $p$ parameters and the Jacobian factors. The [[c_sel]] (channel) argument is just used to mark a selected channel for the records, otherwise the recovery procedure is independent of this. <>= procedure :: recover_kinematics => sf_chain_instance_recover_kinematics <>= subroutine sf_chain_instance_recover_kinematics (chain, c_sel) class(sf_chain_instance_t), intent(inout), target :: chain integer, intent(in) :: c_sel real(default) :: f_mapping integer :: i, j, c if (chain%status >= SF_DONE_CONNECTIONS) then call chain%select_channel (c_sel) if (allocated (chain%sf)) then do i = size (chain%sf), 1, -1 associate (sf => chain%sf(i)) if (.not. sf%eval%is_empty ()) then call interaction_send_momenta (sf%eval%interaction_t) end if end associate end do chain%f = 1 if (size (chain%sf) /= 0) then forall (i = 1:size (chain%sf)) chain%sf(i)%int%status = SF_INITIAL chain%x_free = 1 do i = 1, size (chain%sf) associate (sf => chain%sf(i)) call sf%int%seed_kinematics () call sf%int%recover_x (sf%x, sf%xb, chain%x_free) do j = 1, size (sf%x) chain%x(sf%int%par_index(j)) = sf%x(j) chain%xb(sf%int%par_index(j)) = sf%xb(j) end do do c = 1, size (sf%f) call sf%int%inverse_kinematics & (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), & set_momenta = .false.) chain%f(c) = chain%f(c) * sf%f(c) do j = 1, size (sf%x) chain%r (sf%int%par_index(j),c) = sf%r (j,c) chain%rb(sf%int%par_index(j),c) = sf%rb(j,c) end do end do end associate end do do c = 1, size (chain%f) if (allocated (chain%channel(c)%multi_mapping)) then call chain%channel(c)%multi_mapping%inverse & (chain%r(:,c), chain%rb(:,c), & f_mapping, & chain%p(:,c), chain%pb(:,c), & chain%x_free) chain%f(c) = chain%f(c) * f_mapping else chain%p (:,c) = chain%r (:,c) chain%pb(:,c) = chain%rb(:,c) end if end do end if end if chain%status = SF_DONE_KINEMATICS end if end subroutine sf_chain_instance_recover_kinematics @ %def sf_chain_instance_recover_kinematics @ Return the initial beam momenta to their source, thus completing kinematics recovery. Obviously, this works as a side effect. <>= procedure :: return_beam_momenta => sf_chain_instance_return_beam_momenta <>= subroutine sf_chain_instance_return_beam_momenta (chain) class(sf_chain_instance_t), intent(in), target :: chain type(interaction_t), pointer :: int if (chain%status >= SF_DONE_KINEMATICS) then int => beam_get_int_ptr (chain%beam_t) call interaction_send_momenta (int) end if end subroutine sf_chain_instance_return_beam_momenta @ %def sf_chain_instance_return_beam_momenta @ Evaluate all interactions in the chain and the product evaluators. We provide a [[scale]] argument that is given to all structure functions in the chain. Hadronic NLO calculations involve rescaled fractions of the original beam momentum. 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, sf_rescale) class(sf_chain_instance_t), intent(inout), target :: chain real(default), intent(in) :: scale class(sf_rescale_t), intent(inout), optional :: sf_rescale type(interaction_t), pointer :: out_int real(default) :: sf_sum integer :: i_beam, i_sub, n_sub 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, sf_rescale, i_sub = i_sub) else call sf%int%apply (scale, i_sub = i_sub) end if case default if (i_beam == i_sub) then call sf%int%apply (scale, sf_rescale, i_sub = i_sub) else call sf%int%apply (scale, i_sub = i_sub) end if end select end do else call sf%int%apply (scale, 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_array_get (pdg_in, 1) /= 25) then call msg_fatal ("Test spectrum function: input flavor must be 's'") end if call data%flv_in%init (25, model) data%m = data%flv_in%get_mass () if (present (collinear)) data%collinear = collinear call data%flv_out%init (25, model) call data%flv_rad%init (25, model) if (present (qbounds)) then allocate (data%qbounds (2)) data%qbounds = qbounds end if end subroutine sf_test_data_init @ %def sf_test_data_init @ Return the number of parameters: 1 if only consider collinear splitting, 3 otherwise. <>= procedure :: get_n_par => sf_test_data_get_n_par <>= function sf_test_data_get_n_par (data) result (n) class(sf_test_data_t), intent(in) :: data integer :: n if (data%collinear) then n = 1 else n = 3 end if end function sf_test_data_get_n_par @ %def sf_test_data_get_n_par @ Return the outgoing particle PDG code: 25 <>= procedure :: get_pdg_out => sf_test_data_get_pdg_out <>= subroutine sf_test_data_get_pdg_out (data, pdg_out) class(sf_test_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = 25 end subroutine sf_test_data_get_pdg_out @ %def sf_test_data_get_pdg_out @ Allocate the matching interaction. <>= procedure :: allocate_sf_int => sf_test_data_allocate_sf_int <>= subroutine sf_test_data_allocate_sf_int (data, sf_int) class(sf_test_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int if (allocated (sf_int)) deallocate (sf_int) allocate (sf_test_t :: sf_int) end subroutine sf_test_data_allocate_sf_int @ %def sf_test_data_allocate_sf_int @ \subsubsection{Interaction} <>= type, extends (sf_int_t) :: sf_test_t type(sf_test_data_t), pointer :: data => null () real(default) :: x = 0 contains <> end type sf_test_t @ %def sf_test_t @ Type string: constant <>= procedure :: type_string => sf_test_type_string <>= function sf_test_type_string (object) result (string) class(sf_test_t), intent(in) :: object type(string_t) :: string string = "Test" end function sf_test_type_string @ %def sf_test_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => sf_test_write <>= subroutine sf_test_write (object, unit, testflag) class(sf_test_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "SF test data: [undefined]" end if end subroutine sf_test_write @ %def sf_test_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. Optionally, we can provide minimum and maximum values for the momentum transfer. <>= procedure :: init => sf_test_init <>= subroutine sf_test_init (sf_int, data) class(sf_test_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask type(helicity_t) :: hel0 type(color_t) :: col0 type(quantum_numbers_t), dimension(3) :: qn mask = quantum_numbers_mask (.false., .false., .false.) select type (data) type is (sf_test_data_t) if (allocated (data%qbounds)) then call sf_int%base_init (mask, & [data%m**2], [0._default], [data%m**2], & [data%qbounds(1)], [data%qbounds(2)]) else call sf_int%base_init (mask, & [data%m**2], [0._default], [data%m**2]) end if sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_rad, col0, hel0) call qn(3)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn) call sf_int%freeze () call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) end select sf_int%status = SF_INITIAL end subroutine sf_test_init @ %def sf_test_init @ Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ and consequently $f(r)=2r$. <>= procedure :: complete_kinematics => sf_test_complete_kinematics <>= subroutine sf_test_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(sf_test_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then x(1) = r(1)**2 f = 2 * r(1) else x(1) = r(1) f = 1 end if xb(1) = 1 - x(1) if (size (x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) sf_int%x = x(1) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end subroutine sf_test_complete_kinematics @ %def sf_test_complete_kinematics @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => sf_test_inverse_kinematics <>= subroutine sf_test_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(sf_test_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then r(1) = sqrt (x(1)) f = 2 * r(1) else r(1) = x(1) f = 1 end if if (size (x) == 3) r(2:3) = x(2:3) rb = 1 - r sf_int%x = x(1) if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine sf_test_inverse_kinematics @ %def sf_test_inverse_kinematics @ Apply the structure function. The matrix element becomes unity and the application always succeeds. If the [[mode]] indicator is one, the matrix element is equal to the parameter~$x$. <>= procedure :: apply => sf_test_apply <>= subroutine sf_test_apply (sf_int, scale, rescale, i_sub) class(sf_test_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub select case (sf_int%data%mode) case (0) call sf_int%set_matrix_element & (cmplx (1._default, kind=default)) case (1) call sf_int%set_matrix_element & (cmplx (sf_int%x, kind=default)) end select sf_int%status = SF_EVALUATED end subroutine sf_test_apply @ %def sf_test_apply @ \subsection{Test implementation: pair spectrum} Another template, this time for a incoming particle pair, splitting into two radiated and two outgoing particles. \subsubsection{Configuration data} For simplicity, the spectrum contains two mirror images of the previous structure-function configuration: the incoming and all outgoing particles are test scalars. We have two versions, one with radiated particles, one without. <>= type, extends (sf_data_t) :: sf_test_spectrum_data_t class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in type(flavor_t) :: flv_out type(flavor_t) :: flv_rad logical :: with_radiation = .true. real(default) :: m = 0 contains <> end type sf_test_spectrum_data_t @ %def sf_test_spectrum_data_t @ Output. <>= procedure :: write => sf_test_spectrum_data_write <>= subroutine sf_test_spectrum_data_write (data, unit, verbose) class(sf_test_spectrum_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "SF test spectrum data:" write (u, "(3x,A,A)") "model = ", char (data%model%get_name ()) write (u, "(3x,A)", advance="no") "incoming = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A)", advance="no") "outgoing = " call data%flv_out%write (u); write (u, *) write (u, "(3x,A)", advance="no") "radiated = " call data%flv_rad%write (u); write (u, *) write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m end subroutine sf_test_spectrum_data_write @ %def sf_test_spectrum_data_write @ Initialization. <>= procedure :: init => sf_test_spectrum_data_init <>= subroutine sf_test_spectrum_data_init (data, model, pdg_in, with_radiation) class(sf_test_spectrum_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in logical, intent(in) :: with_radiation data%model => model data%with_radiation = with_radiation if (pdg_array_get (pdg_in, 1) /= 25) then call msg_fatal ("Test structure function: input flavor must be 's'") end if call data%flv_in%init (25, model) data%m = data%flv_in%get_mass () call data%flv_out%init (25, model) if (with_radiation) then call data%flv_rad%init (25, model) end if end subroutine sf_test_spectrum_data_init @ %def sf_test_spectrum_data_init @ Return the number of parameters: 2, since we have only collinear splitting here. <>= procedure :: get_n_par => sf_test_spectrum_data_get_n_par <>= function sf_test_spectrum_data_get_n_par (data) result (n) class(sf_test_spectrum_data_t), intent(in) :: data integer :: n n = 2 end function sf_test_spectrum_data_get_n_par @ %def sf_test_spectrum_data_get_n_par @ Return the outgoing particle PDG codes: 25 <>= procedure :: get_pdg_out => sf_test_spectrum_data_get_pdg_out <>= subroutine sf_test_spectrum_data_get_pdg_out (data, pdg_out) class(sf_test_spectrum_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = 25 pdg_out(2) = 25 end subroutine sf_test_spectrum_data_get_pdg_out @ %def sf_test_spectrum_data_get_pdg_out @ Allocate the matching interaction. <>= procedure :: allocate_sf_int => & sf_test_spectrum_data_allocate_sf_int <>= subroutine sf_test_spectrum_data_allocate_sf_int (data, sf_int) class(sf_test_spectrum_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (sf_test_spectrum_t :: sf_int) end subroutine sf_test_spectrum_data_allocate_sf_int @ %def sf_test_spectrum_data_allocate_sf_int @ \subsubsection{Interaction} <>= type, extends (sf_int_t) :: sf_test_spectrum_t type(sf_test_spectrum_data_t), pointer :: data => null () contains <> end type sf_test_spectrum_t @ %def sf_test_spectrum_t <>= procedure :: type_string => sf_test_spectrum_type_string <>= function sf_test_spectrum_type_string (object) result (string) class(sf_test_spectrum_t), intent(in) :: object type(string_t) :: string string = "Test Spectrum" end function sf_test_spectrum_type_string @ %def sf_test_spectrum_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => sf_test_spectrum_write <>= subroutine sf_test_spectrum_write (object, unit, testflag) class(sf_test_spectrum_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "SF test spectrum data: [undefined]" end if end subroutine sf_test_spectrum_write @ %def sf_test_spectrum_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_spectrum_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. Optionally, we can provide minimum and maximum values for the momentum transfer. <>= procedure :: init => sf_test_spectrum_init <>= subroutine sf_test_spectrum_init (sf_int, data) class(sf_test_spectrum_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(6) :: mask type(helicity_t) :: hel0 type(color_t) :: col0 type(quantum_numbers_t), dimension(6) :: qn mask = quantum_numbers_mask (.false., .false., .false.) select type (data) type is (sf_test_spectrum_data_t) if (data%with_radiation) then call sf_int%base_init (mask(1:6), & [data%m**2, data%m**2], & [0._default, 0._default], & [data%m**2, data%m**2]) sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_in, col0, hel0) call qn(3)%init (data%flv_rad, col0, hel0) call qn(4)%init (data%flv_rad, col0, hel0) call qn(5)%init (data%flv_out, col0, hel0) call qn(6)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn(1:6)) call sf_int%set_incoming ([1,2]) call sf_int%set_radiated ([3,4]) call sf_int%set_outgoing ([5,6]) else call sf_int%base_init (mask(1:4), & [data%m**2, data%m**2], & [real(default) :: ], & [data%m**2, data%m**2]) sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_in, col0, hel0) call qn(3)%init (data%flv_out, col0, hel0) call qn(4)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn(1:4)) call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) end if call sf_int%freeze () end select sf_int%status = SF_INITIAL end subroutine sf_test_spectrum_init @ %def sf_test_spectrum_init @ Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ (as above) for both $x$ parameters and consequently $f(r)=4r_1r_2$. <>= procedure :: complete_kinematics => sf_test_spectrum_complete_kinematics <>= subroutine sf_test_spectrum_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(sf_test_spectrum_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default), dimension(2) :: xb1 if (map) then x = r**2 f = 4 * r(1) * r(2) else x = r f = 1 end if xb = 1 - x if (sf_int%data%with_radiation) then call sf_int%split_momenta (x, xb) else call sf_int%reduce_momenta (x) end if select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end subroutine sf_test_spectrum_complete_kinematics @ %def sf_test_spectrum_complete_kinematics @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => sf_test_spectrum_inverse_kinematics <>= subroutine sf_test_spectrum_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(sf_test_spectrum_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default), dimension(2) :: xb1 logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then r = sqrt (x) f = 4 * r(1) * r(2) else r = x f = 1 end if rb = 1 - r if (set_mom) then if (sf_int%data%with_radiation) then call sf_int%split_momenta (x, xb) else call sf_int%reduce_momenta (x) end if select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine sf_test_spectrum_inverse_kinematics @ %def sf_test_spectrum_inverse_kinematics @ Apply the structure function. The matrix element becomes unity and the application always succeeds. <>= procedure :: apply => sf_test_spectrum_apply <>= subroutine sf_test_spectrum_apply (sf_int, scale, rescale, i_sub) class(sf_test_spectrum_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub call sf_int%set_matrix_element & (cmplx (1._default, kind=default)) sf_int%status = SF_EVALUATED end subroutine sf_test_spectrum_apply @ %def sf_test_spectrum_apply @ \subsection{Test implementation: generator spectrum} A generator for two beams, no radiation (for simplicity). \subsubsection{Configuration data} For simplicity, the spectrum contains two mirror images of the previous structure-function configuration: the incoming and all outgoing particles are test scalars. We have two versions, one with radiated particles, one without. <>= type, extends (sf_data_t) :: sf_test_generator_data_t class(model_data_t), pointer :: model => null () type(flavor_t) :: flv_in type(flavor_t) :: flv_out type(flavor_t) :: flv_rad real(default) :: m = 0 contains <> end type sf_test_generator_data_t @ %def sf_test_generator_data_t @ Output. <>= procedure :: write => sf_test_generator_data_write <>= subroutine sf_test_generator_data_write (data, unit, verbose) class(sf_test_generator_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "SF test generator data:" write (u, "(3x,A,A)") "model = ", char (data%model%get_name ()) write (u, "(3x,A)", advance="no") "incoming = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A)", advance="no") "outgoing = " call data%flv_out%write (u); write (u, *) write (u, "(3x,A," // FMT_19 // ")") "mass = ", data%m end subroutine sf_test_generator_data_write @ %def sf_test_generator_data_write @ Initialization. <>= procedure :: init => sf_test_generator_data_init <>= subroutine sf_test_generator_data_init (data, model, pdg_in) class(sf_test_generator_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in data%model => model if (pdg_array_get (pdg_in, 1) /= 25) then call msg_fatal ("Test generator: input flavor must be 's'") end if call data%flv_in%init (25, model) data%m = data%flv_in%get_mass () call data%flv_out%init (25, model) end subroutine sf_test_generator_data_init @ %def sf_test_generator_data_init @ This structure function is a generator. <>= procedure :: is_generator => sf_test_generator_data_is_generator <>= function sf_test_generator_data_is_generator (data) result (flag) class(sf_test_generator_data_t), intent(in) :: data logical :: flag flag = .true. end function sf_test_generator_data_is_generator @ %def sf_test_generator_data_is_generator @ Return the number of parameters: 2, since we have only collinear splitting here. <>= procedure :: get_n_par => sf_test_generator_data_get_n_par <>= function sf_test_generator_data_get_n_par (data) result (n) class(sf_test_generator_data_t), intent(in) :: data integer :: n n = 2 end function sf_test_generator_data_get_n_par @ %def sf_test_generator_data_get_n_par @ Return the outgoing particle PDG codes: 25 <>= procedure :: get_pdg_out => sf_test_generator_data_get_pdg_out <>= subroutine sf_test_generator_data_get_pdg_out (data, pdg_out) class(sf_test_generator_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = 25 pdg_out(2) = 25 end subroutine sf_test_generator_data_get_pdg_out @ %def sf_test_generator_data_get_pdg_out @ Allocate the matching interaction. <>= procedure :: allocate_sf_int => & sf_test_generator_data_allocate_sf_int <>= subroutine sf_test_generator_data_allocate_sf_int (data, sf_int) class(sf_test_generator_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (sf_test_generator_t :: sf_int) end subroutine sf_test_generator_data_allocate_sf_int @ %def sf_test_generator_data_allocate_sf_int @ \subsubsection{Interaction} <>= type, extends (sf_int_t) :: sf_test_generator_t type(sf_test_generator_data_t), pointer :: data => null () contains <> end type sf_test_generator_t @ %def sf_test_generator_t <>= procedure :: type_string => sf_test_generator_type_string <>= function sf_test_generator_type_string (object) result (string) class(sf_test_generator_t), intent(in) :: object type(string_t) :: string string = "Test Generator" end function sf_test_generator_type_string @ %def sf_test_generator_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => sf_test_generator_write <>= subroutine sf_test_generator_write (object, unit, testflag) class(sf_test_generator_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "SF test generator data: [undefined]" end if end subroutine sf_test_generator_write @ %def sf_test_generator_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_generator_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass. No radiation. <>= procedure :: init => sf_test_generator_init <>= subroutine sf_test_generator_init (sf_int, data) class(sf_test_generator_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(4) :: mask type(helicity_t) :: hel0 type(color_t) :: col0 type(quantum_numbers_t), dimension(4) :: qn mask = quantum_numbers_mask (.false., .false., .false.) select type (data) type is (sf_test_generator_data_t) call sf_int%base_init (mask(1:4), & [data%m**2, data%m**2], & [real(default) :: ], & [data%m**2, data%m**2]) sf_int%data => data call hel0%init (0) call col0%init () call qn(1)%init (data%flv_in, col0, hel0) call qn(2)%init (data%flv_in, col0, hel0) call qn(3)%init (data%flv_out, col0, hel0) call qn(4)%init (data%flv_out, col0, hel0) call sf_int%add_state (qn(1:4)) call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%freeze () end select sf_int%status = SF_INITIAL end subroutine sf_test_generator_init @ %def sf_test_generator_init @ This structure function is a generator. <>= procedure :: is_generator => sf_test_generator_is_generator <>= function sf_test_generator_is_generator (sf_int) result (flag) class(sf_test_generator_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function sf_test_generator_is_generator @ %def sf_test_generator_is_generator @ Generate free parameters. This mock generator always produces the nubmers 0.8 and 0.5. <>= procedure :: generate_free => sf_test_generator_generate_free <>= subroutine sf_test_generator_generate_free (sf_int, r, rb, x_free) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free r = [0.8, 0.5] rb= 1 - r x_free = x_free * product (r) end subroutine sf_test_generator_generate_free @ %def sf_test_generator_generate_free @ Recover momentum fractions. Since the x values are free, we also set the [[x_free]] parameter. <>= procedure :: recover_x => sf_test_generator_recover_x <>= subroutine sf_test_generator_recover_x (sf_int, x, xb, x_free) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb) if (present (x_free)) x_free = x_free * product (x) end subroutine sf_test_generator_recover_x @ %def sf_test_generator_recover_x @ Set kinematics. Since this is a generator, just transfer input to output. <>= procedure :: complete_kinematics => sf_test_generator_complete_kinematics <>= subroutine sf_test_generator_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map x = r xb= rb f = 1 call sf_int%reduce_momenta (x) end subroutine sf_test_generator_complete_kinematics @ %def sf_test_generator_complete_kinematics @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => sf_test_generator_inverse_kinematics <>= subroutine sf_test_generator_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(sf_test_generator_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta r = x rb= xb f = 1 if (set_mom) call sf_int%reduce_momenta (x) end subroutine sf_test_generator_inverse_kinematics @ %def sf_test_generator_inverse_kinematics @ Apply the structure function. The matrix element becomes unity and the application always succeeds. <>= procedure :: apply => sf_test_generator_apply <>= subroutine sf_test_generator_apply (sf_int, scale, rescale, i_sub) class(sf_test_generator_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub call sf_int%set_matrix_element & (cmplx (1._default, kind=default)) sf_int%status = SF_EVALUATED end subroutine sf_test_generator_apply @ %def sf_test_generator_apply @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_base_1, "sf_base_1", & "structure function configuration", & u, results) <>= public :: sf_base_1 <>= subroutine sf_base_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_base_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") call model%init_test () pdg_in = 25 allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle code:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_1" end subroutine sf_base_1 @ %def sf_base_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the test structure function. <>= call test (sf_base_2, "sf_base_2", & "structure function instance", & u, results) <>= public :: sf_base_2 <>= subroutine sf_base_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () pdg_in = 25 call flv%init (25, model) call reset_interaction_counter () allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics for x=1" write (u, "(A)") r = 1 rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5" write (u, "(A)") r = 0.5_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics with mapping for r=0.8" write (u, "(A)") r = 0.8_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics for x=0.64 and evaluate" write (u, "(A)") x = 0.64_default call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_2" end subroutine sf_base_2 @ %def sf_base_2 @ \subsubsection{Collinear kinematics} Scan over the possibilities for mass assignment and on-shell projections, collinear case. <>= call test (sf_base_3, "sf_base_3", & "alternatives for collinear kinematics", & u, results) <>= public :: sf_base_3 <>= subroutine sf_base_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_3" write (u, "(A)") "* Purpose: check various kinematical setups" write (u, "(A)") "* for collinear structure-function splitting." write (u, "(A)") " (two masses equal, one zero)" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () pdg_in = 25 call flv%init (25, model) call reset_interaction_counter () allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%write (u) allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set radiated mass to zero" sf_int%mr2 = 0 sf_int%mo2 = sf_int%mi2 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set outgoing mass to zero" sf_int%mr2 = sf_int%mi2 sf_int%mo2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set incoming mass to zero" k = vector4_moving (E, E, 3) call sf_int%seed_kinematics ([k]) sf_int%mr2 = sf_int%mi2 sf_int%mo2 = sf_int%mi2 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set all masses to zero" sf_int%mr2 = 0 sf_int%mo2 = 0 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping energy" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5, keeping momentum" write (u, "(A)") r = 0.5_default rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_3" end subroutine sf_base_3 @ %def sf_base_3 @ \subsubsection{Non-collinear kinematics} Scan over the possibilities for mass assignment and on-shell projections, non-collinear case. <>= call test (sf_base_4, "sf_base_4", & "alternatives for non-collinear kinematics", & u, results) <>= public :: sf_base_4 <>= subroutine sf_base_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_4" write (u, "(A)") "* Purpose: check various kinematical setups" write (u, "(A)") "* for free structure-function splitting." write (u, "(A)") " (two masses equal, one zero)" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () pdg_in = 25 call flv%init (25, model) call reset_interaction_counter () allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in, collinear=.false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%write (u) allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set radiated mass to zero" sf_int%mr2 = 0 sf_int%mo2 = sf_int%mi2 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set outgoing mass to zero" sf_int%mr2 = sf_int%mi2 sf_int%mo2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set incoming mass to zero" k = vector4_moving (E, E, 3) call sf_int%seed_kinematics ([k]) sf_int%mr2 = sf_int%mi2 sf_int%mo2 = sf_int%mi2 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set all masses to zero" sf_int%mr2 = 0 sf_int%mo2 = 0 sf_int%mi2 = 0 write (u, "(A)") write (u, "(A)") "* Re-Initialize structure-function object with Q bounds" call reset_interaction_counter () select type (data) type is (sf_test_data_t) call data%init (model, pdg_in, collinear=.false., & qbounds = [1._default, 100._default]) end select call sf_int%init (data) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping energy" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.125, keeping momentum" write (u, "(A)") r = [0.5_default, 0.5_default, 0.125_default] rb = 1 - r sf_int%on_shell_mode = KEEP_MOMENTUM call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Recover x and r" write (u, "(A)") call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_4" end subroutine sf_base_4 @ %def sf_base_4 @ \subsubsection{Pair spectrum} Construct and display a structure function object for a pair spectrum (a structure function involving two particles simultaneously). <>= call test (sf_base_5, "sf_base_5", & "pair spectrum with radiation", & u, results) <>= public :: sf_base_5 <>= subroutine sf_base_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t), dimension(2) :: k type(vector4_t), dimension(4) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_5" write (u, "(A)") "* Purpose: initialize and fill & &a pair spectrum object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () allocate (sf_test_spectrum_data_t :: data) select type (data) type is (sf_test_spectrum_data_t) call data%init (model, pdg_in, with_radiation=.true.) end select write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 write (u, "(A)") write (u, "(A)") "* Initialize spectrum object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momenta with sqrts=1000" E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics (k) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.4,0.8" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.4_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Set kinematics with mapping for r=0.6,0.8" write (u, "(A)") r = [0.6_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call reset_interaction_counter () call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%seed_kinematics (k) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics for x=0.36,0.64 & &and evaluate" write (u, "(A)") x = [0.36_default, 0.64_default] xb = 1 - x call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_5" end subroutine sf_base_5 @ %def sf_base_5 @ \subsubsection{Pair spectrum without radiation} Construct and display a structure function object for a pair spectrum (a structure function involving two particles simultaneously). <>= call test (sf_base_6, "sf_base_6", & "pair spectrum without radiation", & u, results) <>= public :: sf_base_6 <>= subroutine sf_base_6 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_base_6" write (u, "(A)") "* Purpose: initialize and fill & &a pair spectrum object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () allocate (sf_test_spectrum_data_t :: data) select type (data) type is (sf_test_spectrum_data_t) call data%init (model, pdg_in, with_radiation=.false.) end select write (u, "(A)") "* Initialize spectrum object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) write (u, "(A)") "* Initialize incoming momenta with sqrts=1000" E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics (k) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.4,0.8" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.4_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call reset_interaction_counter () call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%seed_kinematics (k) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics for x=0.4,0.8 & &and evaluate" write (u, "(A)") x = [0.4_default, 0.8_default] xb = 1 - x call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_6" end subroutine sf_base_6 @ %def sf_base_6 @ \subsubsection{Direct access to structure function} Probe a structure function directly. <>= call test (sf_base_7, "sf_base_7", & "direct access", & u, results) <>= public :: sf_base_7 <>= subroutine sf_base_7 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int real(default), dimension(:), allocatable :: value write (u, "(A)") "* Test output: sf_base_7" write (u, "(A)") "* Purpose: check direct access method" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select call data%allocate_sf_int (sf_int) call sf_int%init (data) write (u, "(A)") "* Probe structure function: states" write (u, "(A)") write (u, "(A,I0)") "n_states = ", sf_int%get_n_states () write (u, "(A,I0)") "n_in = ", sf_int%get_n_in () write (u, "(A,I0)") "n_rad = ", sf_int%get_n_rad () write (u, "(A,I0)") "n_out = ", sf_int%get_n_out () write (u, "(A)") write (u, "(A)", advance="no") "state(1) = " call quantum_numbers_write (sf_int%get_state (1), u) write (u, *) allocate (value (sf_int%get_n_states ())) call sf_int%compute_values (value, & E=[500._default], x=[0.5_default], xb=[0.5_default], scale=0._default) write (u, "(A)") write (u, "(A)", advance="no") "value (E=500, x=0.5) =" write (u, "(9(1x," // FMT_19 // "))") value call sf_int%compute_values (value, & x=[0.1_default], xb=[0.9_default], scale=0._default) write (u, "(A)") write (u, "(A)", advance="no") "value (E=500, x=0.1) =" write (u, "(9(1x," // FMT_19 // "))") value write (u, "(A)") write (u, "(A)") "* Initialize spectrum object" write (u, "(A)") deallocate (value) call sf_int%final () deallocate (sf_int) deallocate (data) allocate (sf_test_spectrum_data_t :: data) select type (data) type is (sf_test_spectrum_data_t) call data%init (model, pdg_in, with_radiation=.false.) end select call data%allocate_sf_int (sf_int) call sf_int%init (data) write (u, "(A)") "* Probe spectrum: states" write (u, "(A)") write (u, "(A,I0)") "n_states = ", sf_int%get_n_states () write (u, "(A,I0)") "n_in = ", sf_int%get_n_in () write (u, "(A,I0)") "n_rad = ", sf_int%get_n_rad () write (u, "(A,I0)") "n_out = ", sf_int%get_n_out () write (u, "(A)") write (u, "(A)", advance="no") "state(1) = " call quantum_numbers_write (sf_int%get_state (1), u) write (u, *) allocate (value (sf_int%get_n_states ())) call sf_int%compute_value (1, value(1), & E = [500._default, 500._default], & x = [0.5_default, 0.6_default], & xb= [0.5_default, 0.4_default], & scale = 0._default) write (u, "(A)") write (u, "(A)", advance="no") "value (E=500,500, x=0.5,0.6) =" write (u, "(9(1x," // FMT_19 // "))") value write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_7" end subroutine sf_base_7 @ %def sf_base_7 @ \subsubsection{Structure function chain configuration} <>= call test (sf_base_8, "sf_base_8", & "structure function chain configuration", & u, results) <>= public :: sf_base_8 <>= subroutine sf_base_8 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_spectrum type(sf_config_t), dimension(:), allocatable :: sf_config type(sf_chain_t) :: sf_chain write (u, "(A)") "* Test output: sf_base_8" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_spectrum_data_t :: data_spectrum) select type (data_spectrum) type is (sf_test_spectrum_data_t) call data_spectrum%init (model, pdg_in, with_radiation=.true.) end select write (u, "(A)") "* Set up chain with beams only" write (u, "(A)") call sf_chain%init (beam_data) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with structure function" write (u, "(A)") allocate (sf_config (1)) call sf_config(1)%init ([1], data_strfun) call sf_chain%init (beam_data, sf_config) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with spectrum and structure function" write (u, "(A)") deallocate (sf_config) allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_spectrum) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_8" end subroutine sf_base_8 @ %def sf_base_8 @ \subsubsection{Structure function instance configuration} We create a structure-function chain instance which implements a configured structure-function chain. We link the momentum entries in the interactions and compute kinematics. We do not actually connect the interactions and create evaluators. We skip this step and manually advance the status of the chain instead. <>= call test (sf_base_9, "sf_base_9", & "structure function chain instance", & u, results) <>= public :: sf_base_9 <>= subroutine sf_base_9 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_spectrum type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance type(sf_channel_t), dimension(2) :: sf_channel type(vector4_t), dimension(2) :: p integer :: j write (u, "(A)") "* Test output: sf_base_9" write (u, "(A)") "* Purpose: set up a structure-function chain & &and create an instance" write (u, "(A)") "* compute kinematics" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_spectrum_data_t :: data_spectrum) select type (data_spectrum) type is (sf_test_spectrum_data_t) call data_spectrum%init (model, pdg_in, with_radiation=.true.) end select write (u, "(A)") "* Set up chain with beams only" write (u, "(A)") call sf_chain%init (beam_data) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics (1, [real(default) ::]) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%get_out_momenta (p) write (u, "(A)") write (u, "(A)") "* Outgoing momenta:" do j = 1, 2 write (u, "(A)") call vector4_write (p(j), u) end do call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with structure function" write (u, "(A)") allocate (sf_config (1)) call sf_config(1)%init ([1], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (1) call sf_channel(1)%activate_mapping ([1]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics (1, [0.8_default]) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%get_out_momenta (p) write (u, "(A)") write (u, "(A)") "* Outgoing momenta:" do j = 1, 2 write (u, "(A)") call vector4_write (p(j), u) end do call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Set up chain with spectrum and structure function" write (u, "(A)") deallocate (sf_config) allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_spectrum) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics & (1, [0.5_default, 0.6_default, 0.8_default]) call write_separator (u, 2) call sf_chain%write (u) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%get_out_momenta (p) write (u, "(A)") write (u, "(A)") "* Outgoing momenta:" do j = 1, 2 write (u, "(A)") call vector4_write (p(j), u) end do call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_9" end subroutine sf_base_9 @ %def sf_base_9 @ \subsubsection{Structure function chain mappings} Set up a structure function chain instance with a pair of single-particle structure functions. We test different global mappings for this setup. Again, we skip evaluators. <>= call test (sf_base_10, "sf_base_10", & "structure function chain mapping", & u, results) <>= public :: sf_base_10 <>= subroutine sf_base_10 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance type(sf_channel_t), dimension(2) :: sf_channel real(default), dimension(2) :: x_saved write (u, "(A)") "* Test output: sf_base_10" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") "* and check mappings" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select write (u, "(A)") "* Set up chain with structure function pair & &and standard mapping" write (u, "(A)") allocate (sf_config (2)) call sf_config(1)%init ([1], data_strfun) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (2) call sf_channel(1)%set_s_mapping ([1,2]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default]) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Invert the kinematics calculation" write (u, "(A)") x_saved = sf_chain_instance%x call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%set_s_mapping ([1, 2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () sf_chain_instance%status = SF_DONE_CONNECTIONS call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_10" end subroutine sf_base_10 @ %def sf_base_10 @ \subsubsection{Structure function chain evaluation} Here, we test the complete workflow for structure-function chains. First, we create the template chain, then initialize an instance. We set up links, mask, and evaluators. Finally, we set kinematics and evaluate the matrix elements and their products. <>= call test (sf_base_11, "sf_base_11", & "structure function chain evaluation", & u, results) <>= public :: sf_base_11 <>= subroutine sf_base_11 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_spectrum type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance type(sf_channel_t), dimension(2) :: sf_channel type(particle_set_t) :: pset type(interaction_t), pointer :: int logical :: ok write (u, "(A)") "* Test output: sf_base_11" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") "* create an instance and evaluate" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_spectrum_data_t :: data_spectrum) select type (data_spectrum) type is (sf_test_spectrum_data_t) call data_spectrum%init (model, pdg_in, with_radiation=.true.) end select write (u, "(A)") "* Set up chain with beams only" write (u, "(A)") call sf_chain%init (beam_data) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () call sf_chain_instance%compute_kinematics (1, [real(default) ::]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) int => sf_chain_instance%get_out_int_ptr () call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true.) call sf_chain_instance%final () write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover chain:" write (u, "(A)") call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () int => sf_chain_instance%get_out_int_ptr () call pset%fill_interaction (int, 2, check_match=.false.) call sf_chain_instance%recover_kinematics (1) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call pset%final () call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Set up chain with structure function" write (u, "(A)") allocate (sf_config (1)) call sf_config(1)%init ([1], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (1) call sf_channel(1)%activate_mapping ([1]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () call sf_chain_instance%compute_kinematics (1, [0.8_default]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) int => sf_chain_instance%get_out_int_ptr () call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true.) call sf_chain_instance%final () write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover chain:" write (u, "(A)") call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(1)%init (1) call sf_channel(1)%activate_mapping ([1]) call sf_chain_instance%set_channel (1, sf_channel(1)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () int => sf_chain_instance%get_out_int_ptr () call pset%fill_interaction (int, 2, check_match=.false.) call sf_chain_instance%recover_kinematics (1) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call pset%final () call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Set up chain with spectrum and structure function" write (u, "(A)") deallocate (sf_config) allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_spectrum) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () call sf_chain_instance%compute_kinematics & (1, [0.5_default, 0.6_default, 0.8_default]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) int => sf_chain_instance%get_out_int_ptr () call pset%init (ok, int, int, FM_IGNORE_HELICITY, & [0._default, 0._default], .false., .true.) call sf_chain_instance%final () write (u, "(A)") write (u, "(A)") "* Particle content:" write (u, "(A)") call write_separator (u) call pset%write (u) call write_separator (u) write (u, "(A)") write (u, "(A)") "* Recover chain:" write (u, "(A)") call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_channel(2)%init (2) call sf_channel(2)%activate_mapping ([2]) call sf_chain_instance%set_channel (1, sf_channel(2)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () int => sf_chain_instance%get_out_int_ptr () call pset%fill_interaction (int, 2, check_match=.false.) call sf_chain_instance%recover_kinematics (1) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) call pset%final () call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_11" end subroutine sf_base_11 @ %def sf_base_11 @ \subsubsection{Multichannel case} We set up a structure-function chain as before, but with three different parameterizations. The first instance is without mappings, the second one with single-particle mappings, and the third one with two-particle mappings. <>= call test (sf_base_12, "sf_base_12", & "multi-channel structure function chain", & u, results) <>= public :: sf_base_12 <>= subroutine sf_base_12 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data type(sf_config_t), dimension(:), allocatable, target :: sf_config type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance real(default), dimension(2) :: x_saved real(default), dimension(2,3) :: p_saved type(sf_channel_t), dimension(:), allocatable :: sf_channel write (u, "(A)") "* Test output: sf_base_12" write (u, "(A)") "* Purpose: set up and evaluate a multi-channel & &structure-function chain" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data) select type (data) type is (sf_test_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Set up chain with structure function pair & &and three different mappings" write (u, "(A)") allocate (sf_config (2)) call sf_config(1)%init ([1], data) call sf_config(2)%init ([2], data) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 3) call allocate_sf_channels (sf_channel, n_channel = 3, n_strfun = 2) ! channel 1: no mapping call sf_chain_instance%set_channel (1, sf_channel(1)) ! channel 2: single-particle mappings call sf_channel(2)%activate_mapping ([1,2]) ! call sf_chain_instance%activate_mapping (2, [1,2]) call sf_chain_instance%set_channel (2, sf_channel(2)) ! channel 3: two-particle mapping call sf_channel(3)%set_s_mapping ([1,2]) ! call sf_chain_instance%set_s_mapping (3, [1, 2]) call sf_chain_instance%set_channel (3, sf_channel(3)) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () write (u, "(A)") "* Compute kinematics in channel 1 and evaluate" write (u, "(A)") call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default]) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Invert the kinematics calculation" write (u, "(A)") x_saved = sf_chain_instance%x call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Compute kinematics in channel 2 and evaluate" write (u, "(A)") p_saved = sf_chain_instance%p call sf_chain_instance%compute_kinematics (2, p_saved(:,2)) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Compute kinematics in channel 3 and evaluate" write (u, "(A)") call sf_chain_instance%compute_kinematics (3, p_saved(:,3)) call sf_chain_instance%evaluate (scale=0._default) call write_separator (u, 2) call sf_chain_instance%write (u) call write_separator (u, 2) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_chain_instance%final () call sf_chain%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_12" end subroutine sf_base_12 @ %def sf_base_12 @ \subsubsection{Generated spectrum} Construct and evaluate a structure function object for a pair spectrum which is evaluated as a beam-event generator. <>= call test (sf_base_13, "sf_base_13", & "pair spectrum generator", & u, results) <>= public :: sf_base_13 <>= subroutine sf_base_13 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t), dimension(2) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_base_13" write (u, "(A)") "* Purpose: initialize and fill & &a pair generator object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () allocate (sf_test_generator_data_t :: data) select type (data) type is (sf_test_generator_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize generator object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) write (u, "(A)") "* Generate free r values" write (u, "(A)") x_free = 1 call sf_int%generate_free (r, rb, x_free) write (u, "(A)") "* Initialize incoming momenta with sqrts=1000" E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call sf_int%seed_kinematics (k) write (u, "(A)") write (u, "(A)") "* Complete kinematics" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call reset_interaction_counter () call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%seed_kinematics (k) call sf_int%set_momenta (q, outgoing=.true.) x_free = 1 call sf_int%recover_x (x, xb, x_free) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Compute inverse kinematics & &and evaluate" write (u, "(A)") call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale=0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_13" end subroutine sf_base_13 @ %def sf_base_13 @ \subsubsection{Structure function chain evaluation} Here, we test the complete workflow for a structure-function chain with generator. First, we create the template chain, then initialize an instance. We set up links, mask, and evaluators. Finally, we set kinematics and evaluate the matrix elements and their products. <>= call test (sf_base_14, "sf_base_14", & "structure function generator evaluation", & u, results) <>= public :: sf_base_14 <>= subroutine sf_base_14 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in type(beam_data_t), target :: beam_data class(sf_data_t), allocatable, target :: data_strfun class(sf_data_t), allocatable, target :: data_generator type(sf_config_t), dimension(:), allocatable, target :: sf_config real(default), dimension(:), allocatable :: p_in type(sf_chain_t), target :: sf_chain type(sf_chain_instance_t), target :: sf_chain_instance write (u, "(A)") "* Test output: sf_base_14" write (u, "(A)") "* Purpose: set up a structure-function chain" write (u, "(A)") "* create an instance and evaluate" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_test () call flv%init (25, model) pdg_in = 25 call reset_interaction_counter () call beam_data%init_sqrts (1000._default, [flv, flv]) allocate (sf_test_data_t :: data_strfun) select type (data_strfun) type is (sf_test_data_t) call data_strfun%init (model, pdg_in) end select allocate (sf_test_generator_data_t :: data_generator) select type (data_generator) type is (sf_test_generator_data_t) call data_generator%init (model, pdg_in) end select write (u, "(A)") "* Set up chain with generator and structure function" write (u, "(A)") allocate (sf_config (2)) call sf_config(1)%init ([1,2], data_generator) call sf_config(2)%init ([2], data_strfun) call sf_chain%init (beam_data, sf_config) call sf_chain_instance%init (sf_chain, n_channel = 1) call sf_chain_instance%link_interactions () call sf_chain_instance%exchange_mask () call sf_chain_instance%init_evaluators () write (u, "(A)") "* Inject integration parameter" write (u, "(A)") allocate (p_in (sf_chain%get_n_bound ()), source = 0.9_default) write (u, "(A,9(1x,F10.7))") "p_in =", p_in write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_chain_instance%compute_kinematics (1, p_in) call sf_chain_instance%evaluate (scale=0._default) call sf_chain_instance%write (u) write (u, "(A)") write (u, "(A)") "* Extract integration parameter" write (u, "(A)") call sf_chain_instance%get_mcpar (1, p_in) write (u, "(A,9(1x,F10.7))") "p_in =", p_in call sf_chain_instance%final () call sf_chain%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_base_14" end subroutine sf_base_14 @ %def sf_base_14 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Photon radiation: ISR} <<[[sf_isr.f90]]>>= <> module sf_isr <> <> use io_units use constants, only: pi use format_defs, only: FMT_15, FMT_19 use numeric_utils use diagnostics use physics_defs, only: PHOTON use lorentz use sm_physics, only: Li2 use pdg_arrays use model_data use flavors use colors use quantum_numbers use polarizations use sf_aux use sf_mappings use sf_base use electron_pdfs <> <> <> <> contains <> end module sf_isr @ %def sf_isr @ \subsection{Physics} The ISR structure function is in the most crude approximation (LLA without $\alpha$ corrections, i.e. $\epsilon^0$) \begin{equation} f_0(x) = \epsilon (1-x)^{-1+\epsilon} \qquad\text{with}\qquad \epsilon = \frac{\alpha}{\pi}q_e^2\ln\frac{s}{m^2}, \end{equation} where $m$ is the mass of the incoming (and outgoing) particle, which is initially assumed on-shell. In $f_0(x)$, there is an integrable singularity at $x=1$ which does not spoil the integration, but would lead to an unbounded $f_{\rm max}$. Therefore, we map this singularity like \begin{equation}\label{ISR-mapping} x = 1 - (1-x')^{1/\epsilon} \end{equation} such that \begin{equation} \int dx\,f_0(x) = \int dx' \end{equation} For the detailed form of the QED ISR structure function cf. Chap.~\ref{chap:qed_pdf}. \subsection{Implementation} In the concrete implementation, the zeroth order mapping (\ref{ISR-mapping}) is implemented, and the Jacobian is equal to $f_i(x)/f_0(x)$. This can be written as \begin{align} \frac{f_0(x)}{f_0(x)} &= 1 \\ \frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon - \frac{1-x^2}{2(1-x')} \\ \begin{split}\label{ISR-f2} \frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon + \frac{27 - 8\pi^2}{96}\epsilon^2 - \frac{1-x^2}{2(1-x')} \\ &\quad - \frac{(1+3x^2)\ln x + (1-x)\left(4(1+x)\ln(1-x) + 5 + x\right)}{8(1-x')}\epsilon \end{split} \end{align} %' For $x=1$ (i.e., numerically indistinguishable from $1$), this reduces to \begin{align} \frac{f_0(x)}{f_0(x)} &= 1 \\ \frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon \\ \frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon + \frac{27 - 8\pi^2}{96}\epsilon^2 \end{align} The last line in (\ref{ISR-f2}) is zero for \begin{equation} x_{\rm min} = 0.00714053329734592839549879772019 \end{equation} (Mathematica result), independent of $\epsilon$. For $x$ values less than this we ignore this correction because of the logarithmic singularity which should in principle be resummed. \subsection{The ISR data block} <>= public :: isr_data_t <>= type, extends (sf_data_t) :: isr_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:), allocatable :: flv_in type(qed_pdf_t) :: pdf real(default) :: alpha = 0 real(default) :: q_max = 0 real(default) :: real_mass = 0 real(default) :: mass = 0 real(default) :: eps = 0 real(default) :: log = 0 logical :: recoil = .false. logical :: keep_energy = .true. integer :: order = 3 integer :: error = NONE contains <> end type isr_data_t @ %def isr_data_t @ Error codes <>= integer, parameter :: NONE = 0 integer, parameter :: ZERO_MASS = 1 integer, parameter :: Q_MAX_TOO_SMALL = 2 integer, parameter :: EPS_TOO_LARGE = 3 integer, parameter :: INVALID_ORDER = 4 integer, parameter :: CHARGE_MIX = 5 integer, parameter :: CHARGE_ZERO = 6 integer, parameter :: MASS_MIX = 7 @ Generate flavor-dependent ISR data: <>= procedure :: init => isr_data_init <>= subroutine isr_data_init (data, model, pdg_in, alpha, q_max, & mass, order, recoil, keep_energy) class(isr_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in real(default), intent(in) :: alpha real(default), intent(in) :: q_max real(default), intent(in), optional :: mass integer, intent(in), optional :: order logical, intent(in), optional :: recoil logical, intent(in), optional :: keep_energy integer :: i, n_flv real(default) :: charge data%model => model n_flv = pdg_array_get_length (pdg_in) allocate (data%flv_in (n_flv)) do i = 1, n_flv call data%flv_in(i)%init (pdg_array_get (pdg_in, i), model) end do data%alpha = alpha data%q_max = q_max if (present (order)) then call data%set_order (order) end if if (present (recoil)) then data%recoil = recoil end if if (present (keep_energy)) then data%keep_energy = keep_energy end if data%real_mass = data%flv_in(1)%get_mass () if (present (mass)) then if (mass > 0) then data%mass = mass else data%mass = data%real_mass if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if else data%mass = data%real_mass if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if if (vanishes (data%mass)) then data%error = ZERO_MASS; return else if (data%mass >= data%q_max) then data%error = Q_MAX_TOO_SMALL; return end if data%log = log (1 + (data%q_max / data%mass)**2) charge = data%flv_in(1)%get_charge () if (any (abs (data%flv_in%get_charge ()) /= abs (charge))) then data%error = CHARGE_MIX; return else if (charge == 0) then data%error = CHARGE_ZERO; return end if data%eps = data%alpha / pi * charge ** 2 & * (2 * log (data%q_max / data%mass) - 1) if (data%eps > 1) then data%error = EPS_TOO_LARGE; return end if call data%pdf%init & (data%mass, data%alpha, charge, data%q_max, data%order) end subroutine isr_data_init @ %def isr_data_init @ Explicitly set ISR order <>= procedure :: set_order => isr_data_set_order <>= elemental subroutine isr_data_set_order (data, order) class(isr_data_t), intent(inout) :: data integer, intent(in) :: order if (order < 0 .or. order > 3) then data%error = INVALID_ORDER else data%order = order end if end subroutine isr_data_set_order @ %def isr_data_set_order @ Handle error conditions. Should always be done after initialization, unless we are sure everything is ok. <>= procedure :: check => isr_data_check <>= subroutine isr_data_check (data) class(isr_data_t), intent(in) :: data select case (data%error) case (ZERO_MASS) call msg_fatal ("ISR: Particle mass is zero") case (Q_MAX_TOO_SMALL) call msg_fatal ("ISR: Particle mass exceeds Qmax") case (EPS_TOO_LARGE) call msg_fatal ("ISR: Expansion parameter too large, " // & "perturbative expansion breaks down") case (INVALID_ORDER) call msg_error ("ISR: LLA order invalid (valid values are 0,1,2,3)") case (MASS_MIX) call msg_fatal ("ISR: Incoming particle masses must be uniform") case (CHARGE_MIX) call msg_fatal ("ISR: Incoming particle charges must be uniform") case (CHARGE_ZERO) call msg_fatal ("ISR: Incoming particle must be charged") end select end subroutine isr_data_check @ %def isr_data_check @ Output <>= procedure :: write => isr_data_write <>= subroutine isr_data_write (data, unit, verbose) class(isr_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "ISR data:" if (allocated (data%flv_in)) then write (u, "(3x,A)", advance="no") " flavor = " do i = 1, size (data%flv_in) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_in(i)%write (u) end do write (u, *) write (u, "(3x,A," // FMT_19 // ")") " alpha = ", data%alpha write (u, "(3x,A," // FMT_19 // ")") " q_max = ", data%q_max write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass write (u, "(3x,A," // FMT_19 // ")") " eps = ", data%eps write (u, "(3x,A," // FMT_19 // ")") " log = ", data%log write (u, "(3x,A,I2)") " order = ", data%order write (u, "(3x,A,L2)") " recoil = ", data%recoil write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy else write (u, "(3x,A)") "[undefined]" end if end subroutine isr_data_write @ %def isr_data_write @ For ISR, there is the option to generate transverse momentum is generated. Hence, there can be up to three parameters, $x$, and two angles. <>= procedure :: get_n_par => isr_data_get_n_par <>= function isr_data_get_n_par (data) result (n) class(isr_data_t), intent(in) :: data integer :: n if (data%recoil) then n = 3 else n = 1 end if end function isr_data_get_n_par @ %def isr_data_get_n_par @ Return the outgoing particles PDG codes. For ISR, these are identical to the incoming particles. <>= procedure :: get_pdg_out => isr_data_get_pdg_out <>= subroutine isr_data_get_pdg_out (data, pdg_out) class(isr_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = data%flv_in%get_pdg () end subroutine isr_data_get_pdg_out @ %def isr_data_get_pdg_out @ Return the [[eps]] value. We need it for an appropriate mapping of structure-function parameters. <>= procedure :: get_eps => isr_data_get_eps <>= function isr_data_get_eps (data) result (eps) class(isr_data_t), intent(in) :: data real(default) :: eps eps = data%eps end function isr_data_get_eps @ %def isr_data_get_eps @ Allocate the interaction record. <>= procedure :: allocate_sf_int => isr_data_allocate_sf_int <>= subroutine isr_data_allocate_sf_int (data, sf_int) class(isr_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (isr_t :: sf_int) end subroutine isr_data_allocate_sf_int @ %def isr_data_allocate_sf_int @ \subsection{The ISR object} The [[isr_t]] data type is a $1\to 2$ interaction, i.e., we allow for single-photon emission only (but use the multi-photon resummed radiator function). The particles are ordered as (incoming, photon, outgoing). There is no need to handle several flavors (and data blocks) in parallel, since ISR is always applied immediately after beam collision. (ISR for partons is accounted for by the PDFs themselves.) Polarization is carried through, i.e., we retain the polarization of the incoming particle and treat the emitted photon as unpolarized. Color is trivially carried through. This implies that particles 1 and 3 should be locked together. For ISR we don't need the q variable. <>= public :: isr_t <>= type, extends (sf_int_t) :: isr_t private type(isr_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: xb= 0 contains <> end type isr_t @ %def isr_t @ Type string: has to be here, but there is no string variable on which ISR depends. Hence, a dummy routine. <>= procedure :: type_string => isr_type_string <>= function isr_type_string (object) result (string) class(isr_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "ISR: e+ e- ISR spectrum" else string = "ISR: [undefined]" end if end function isr_type_string @ %def isr_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => isr_write <>= subroutine isr_write (object, unit, testflag) class(isr_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_15 // ")") "x =", object%x write (u, "(3x,A," // FMT_15 // ")") "xb=", object%xb end if call object%base_write (u, testflag) else write (u, "(1x,A)") "ISR data: [undefined]" end if end subroutine isr_write @ %def isr_write @ Explicitly set ISR order (for unit test). <>= procedure :: set_order => isr_set_order <>= subroutine isr_set_order (object, order) class(isr_t), intent(inout) :: object integer, intent(in) :: order call object%data%set_order (order) call object%data%pdf%set_order (order) end subroutine isr_set_order @ %def isr_set_order @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ were trivial. The ISR structure function allows for a straightforward mapping of the unit interval. So, to leading order, the structure function value is unity, but the $x$ value is transformed. Higher orders affect the function value. The structure function implementation applies the above mapping to the input (random) number [[r]] to generate the momentum fraction [[x]] and the function value [[f]]. For numerical stability reasons, we also output [[xb]], which is $\bar x=1-x$. For the ISR structure function, the mapping Jacobian cancels the structure function (to order zero). We apply the cancellation explicitly, therefore both the Jacobian [[f]] and the zeroth-order value (see the [[apply]] method) are unity if mapping is turned on. If mapping is turned off, the Jacobian [[f]] includes the value of the (zeroth-order) structure function, and strongly peaked. <>= procedure :: complete_kinematics => isr_complete_kinematics <>= subroutine isr_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default) :: eps eps = sf_int%data%eps if (map) then call map_power_1 (sf_int%xb, f, rb(1), eps) else sf_int%xb = rb(1) if (rb(1) > 0) then f = 1 else f = 0 end if end if sf_int%x = 1 - sf_int%xb x(1) = sf_int%x xb(1) = sf_int%xb if (size (x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS) sf_int%x = 0 sf_int%xb= 0 f = 0 end select end subroutine isr_complete_kinematics @ %def isr_complete_kinematics @ Overriding the default method: we compute the [[x]] array from the momentum configuration. In the specific case of ISR, we also set the internally stored $x$ and $\bar x$ values, so they can be used in the following routine. <>= procedure :: recover_x => sf_isr_recover_x <>= subroutine sf_isr_recover_x (sf_int, x, xb, x_free) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) sf_int%xb = xb(1) end subroutine sf_isr_recover_x @ %def sf_isr_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. For extracting $x$, we rely on the stored $\bar x$ value, since the $x$ value in the argument is likely imprecise. This means that either [[complete_kinematics]] or [[recover_x]] must be called first, for the current sampling point (but maybe another channel). <>= procedure :: inverse_kinematics => isr_inverse_kinematics <>= subroutine isr_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(isr_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: eps logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta eps = sf_int%data%eps if (map) then call map_power_inverse_1 (xb(1), f, rb(1), eps) else rb(1) = xb(1) if (rb(1) > 0) then f = 1 else f = 0 end if end if r(1) = 1 - rb(1) if (size(r) == 3) then r(2:3) = x(2:3) rb(2:3)= xb(2:3) end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS) r = 0 rb= 0 f = 0 end select end if end subroutine isr_inverse_kinematics @ %def isr_inverse_kinematics @ <>= procedure :: init => isr_init <>= subroutine isr_init (sf_int, data) class(isr_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask integer, dimension(3) :: hel_lock type(polarization_t), target :: pol type(quantum_numbers_t), dimension(1) :: qn_fc type(flavor_t) :: flv_photon type(color_t) :: col_photon type(quantum_numbers_t) :: qn_hel, qn_photon, qn type(polarization_iterator_t) :: it_hel real(default) :: m2 integer :: i mask = quantum_numbers_mask (.false., .false., & mask_h = [.false., .true., .false.]) hel_lock = [3, 0, 1] select type (data) type is (isr_data_t) m2 = data%mass**2 call sf_int%base_init (mask, [m2], [0._default], [m2], & hel_lock = hel_lock) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col_photon%init () call qn_photon%init (flv_photon, col_photon) call qn_photon%tag_radiated () do i = 1, size (data%flv_in) call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init (& flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) call sf_int%add_state ([qn, qn_photon, qn]) call it_hel%advance () end do ! call pol%final () !!! Obsolete end do call sf_int%freeze () if (data%keep_energy) then sf_int%on_shell_mode = KEEP_ENERGY else sf_int%on_shell_mode = KEEP_MOMENTUM end if call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) sf_int%status = SF_INITIAL end select end subroutine isr_init @ %def isr_init @ \subsection{ISR application} For ISR, we could in principle compute kinematics and function value in a single step. In order to be able to reweight matrix elements including structure functions we split kinematics and structure function calculation. The structure function works on a single beam, assuming that the input momentum has been set. For the structure-function evaluation, we rely on the fact that the power mapping, which we apply in the kinematics method (if the [[map]] flag is set), has a Jacobian which is just the inverse lowest-order structure function. With mapping active, the two should cancel exactly. After splitting momenta, we set the outgoing momenta on-shell. We choose to conserve momentum, so energy conservation may be violated. <>= procedure :: apply => isr_apply <>= subroutine isr_apply (sf_int, scale, rescale, i_sub) class(isr_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f, finv, x, xb, eps, rb real(default) :: log_x, log_xb, x_2 associate (data => sf_int%data) eps = sf_int%data%eps x = sf_int%x xb = sf_int%xb call map_power_inverse_1 (xb, finv, rb, eps) if (finv > 0) then f = 1 / finv else f = 0 end if call data%pdf%evolve_qed_pdf (x, xb, rb, f) end associate call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine isr_apply @ %def isr_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_isr_ut.f90]]>>= <> module sf_isr_ut use unit_tests use sf_isr_uti <> <> contains <> end module sf_isr_ut @ %def sf_isr_ut @ <<[[sf_isr_uti.f90]]>>= <> module sf_isr_uti <> <> use io_units use format_defs, only: FMT_12 use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use interactions, only: interaction_pacify_momenta use model_data use sf_aux, only: KEEP_ENERGY use sf_mappings use sf_base use sf_isr <> <> contains <> end module sf_isr_uti @ %def sf_isr_ut @ API: driver for the unit tests below. <>= public :: sf_isr_test <>= subroutine sf_isr_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_isr_test @ %def sf_isr_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_isr_1, "sf_isr_1", & "structure function configuration", & u, results) <>= public :: sf_isr_1 <>= subroutine sf_isr_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_isr_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_qed_test () pdg_in = ELECTRON allocate (isr_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 10._default, & 0.000511_default, order = 3, recoil = .false.) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_1" end subroutine sf_isr_1 @ %def sf_isr_1 @ \subsubsection{Structure function without mapping} Direct ISR evaluation. This is the use case for a double-beam structure function. The parameter pair is mapped in the calling program. <>= call test (sf_isr_2, "sf_isr_2", & "no ISR mapping", & u, results) <>= public :: sf_isr_2 <>= subroutine sf_isr_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(flavor_t) :: flv class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, f_isr write (u, "(A)") "* Test output: sf_isr_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () pdg_in = ELECTRON call flv%init (ELECTRON, model) call reset_interaction_counter () allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.9, no ISR mapping, & &collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.9_default rb = 1 - r write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A)") write (u, "(A,9(1x," // FMT_12 // "))") "x =", x write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Invert kinematics" write (u, "(A)") call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Structure-function value, default order" write (u, "(A)") f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Re-evaluate structure function, leading order" write (u, "(A)") select type (sf_int) type is (isr_t) call sf_int%set_order (0) end select call sf_int%apply (scale = 100._default) f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_2" end subroutine sf_isr_2 @ %def sf_isr_2 @ \subsubsection{Structure function with mapping} Apply the optimal ISR mapping. This is the use case for a single-beam structure function. <>= call test (sf_isr_3, "sf_isr_3", & "ISR mapping", & u, results) <>= public :: sf_isr_3 <>= subroutine sf_isr_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, f_isr write (u, "(A)") "* Test output: sf_isr_3" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.7, with ISR mapping, & &collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.7_default rb = 1 - r write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A)") write (u, "(A,9(1x," // FMT_12 // "))") "x =", x write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Invert kinematics" write (u, "(A)") call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Structure-function value, default order" write (u, "(A)") f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Re-evaluate structure function, leading order" write (u, "(A)") select type (sf_int) type is (isr_t) call sf_int%set_order (0) end select call sf_int%apply (scale = 100._default) f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_3" end subroutine sf_isr_3 @ %def sf_isr_3 @ \subsubsection{Non-collinear ISR splitting} Construct and display a structure function object based on the ISR structure function. We blank out numerical fluctuations for 32bit. <>= call test (sf_isr_4, "sf_isr_4", & "ISR non-collinear", & u, results) <>= public :: sf_isr_4 <>= subroutine sf_isr_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, f_isr character(len=80) :: buffer integer :: u_scratch, iostat write (u, "(A)") "* Test output: sf_isr_4" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () write (u, "(A)") write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .true.) end select call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.5/0.5/0.25, with ISR mapping, " write (u, "(A)") " non-coll., keeping energy" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.5_default, 0.5_default, 0.25_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x and r from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) call sf_int%apply (scale = 10._default) u_scratch = free_unit () open (u_scratch, status="scratch", action = "readwrite") call sf_int%write (u_scratch, testflag = .true.) rewind (u_scratch) do read (u_scratch, "(A)", iostat=iostat) buffer if (iostat /= 0) exit if (buffer(1:25) == " P = 0.000000E+00 9.57") then buffer = replace (buffer, 26, "XXXX") end if if (buffer(1:25) == " P = 0.000000E+00 -9.57") then buffer = replace (buffer, 26, "XXXX") end if write (u, "(A)") buffer end do close (u_scratch) write (u, "(A)") write (u, "(A)") "* Structure-function value" write (u, "(A)") f_isr = sf_int%get_matrix_element (1) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", f_isr write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", f_isr * f write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_4" end subroutine sf_isr_4 @ %def sf_isr_4 @ \subsubsection{Structure function pair with mapping} Apply the ISR mapping for a ISR pair. structure function. <>= call test (sf_isr_5, "sf_isr_5", & "ISR pair mapping", & u, results) <>= public :: sf_isr_5 <>= subroutine sf_isr_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_mapping_t), allocatable :: mapping class(sf_int_t), dimension(:), allocatable :: sf_int type(vector4_t), dimension(2) :: k real(default) :: E, f_map real(default), dimension(:), allocatable :: p, pb, r, rb, x, xb real(default), dimension(2) :: f, f_isr integer :: i write (u, "(A)") "* Test output: sf_isr_5" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (isr_data_t :: data) select type (data) type is (isr_data_t) call data%init (model, pdg_in, 1./137._default, 500._default, & 0.000511_default, order = 3, recoil = .false.) end select allocate (sf_ip_mapping_t :: mapping) select type (mapping) type is (sf_ip_mapping_t) select type (data) type is (isr_data_t) call mapping%init (eps = data%get_eps ()) end select call mapping%set_index (1, 1) call mapping%set_index (2, 2) end select call mapping%write (u) write (u, "(A)") write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") allocate (isr_t :: sf_int (2)) do i = 1, 2 call sf_int(i)%init (data) call sf_int(i)%set_beam_index ([i]) end do write (u, "(A)") "* Initialize incoming momenta with E=500" write (u, "(A)") E = 500 k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) k(2) = vector4_moving (E, - sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) do i = 1, 2 call vector4_write (k(i), u) call sf_int(i)%seed_kinematics (k(i:i)) end do write (u, "(A)") write (u, "(A)") "* Set kinematics for p=[0.7,0.4], collinear" write (u, "(A)") allocate (p (2 * data%get_n_par ())) allocate (pb(size (p))) allocate (r (size (p))) allocate (rb(size (p))) allocate (x (size (p))) allocate (xb(size (p))) p = [0.7_default, 0.4_default] pb= 1 - p call mapping%compute (r, rb, f_map, p, pb) write (u, "(A,9(1x," // FMT_12 // "))") "p =", p write (u, "(A,9(1x," // FMT_12 // "))") "pb=", pb write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "fm=", f_map do i = 1, 2 call sf_int(i)%complete_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), & map=.false.) end do write (u, "(A)") write (u, "(A,9(1x," // FMT_12 // "))") "x =", x write (u, "(A,9(1x," // FMT_12 // "))") "xb=", xb write (u, "(A,9(1x," // FMT_12 // "))") "f =", f write (u, "(A)") write (u, "(A)") "* Invert kinematics" write (u, "(A)") do i = 1, 2 call sf_int(i)%inverse_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), & map=.false.) end do call mapping%inverse (r, rb, f_map, p, pb) write (u, "(A,9(1x," // FMT_12 // "))") "p =", p write (u, "(A,9(1x," // FMT_12 // "))") "pb=", pb write (u, "(A,9(1x," // FMT_12 // "))") "r =", r write (u, "(A,9(1x," // FMT_12 // "))") "rb=", rb write (u, "(A,9(1x," // FMT_12 // "))") "fm=", f_map write (u, "(A)") write (u, "(A)") "* Evaluate ISR structure function" call sf_int(1)%apply (scale = 100._default) call sf_int(2)%apply (scale = 100._default) write (u, "(A)") write (u, "(A)") "* Structure function #1" write (u, "(A)") call sf_int(1)%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Structure function #2" write (u, "(A)") call sf_int(2)%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Structure-function value, default order" write (u, "(A)") do i = 1, 2 f_isr(i) = sf_int(i)%get_matrix_element (1) end do write (u, "(A,9(1x," // FMT_12 // "))") "f_isr =", & product (f_isr) write (u, "(A,9(1x," // FMT_12 // "))") "f_isr * f_map =", & product (f_isr * f) * f_map write (u, "(A)") write (u, "(A)") "* Cleanup" do i = 1, 2 call sf_int(i)%final () end do call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_isr_5" end subroutine sf_isr_5 @ %def sf_isr_5 @ \clearpage %------------------------------------------------------------------------ \section{EPA} <<[[sf_epa.f90]]>>= <> module sf_epa <> <> use io_units use constants, only: pi use format_defs, only: FMT_17, FMT_19 use numeric_utils use diagnostics use physics_defs, only: PHOTON use lorentz use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use interactions use sf_aux use sf_base <> <> <> <> contains <> end module sf_epa @ %def sf_epa @ \subsection{Physics} The EPA structure function for a photon inside an (elementary) particle $p$ with energy $E$, mass $m$ and charge $q_p$ (e.g., electron) is given by ($\bar x \equiv 1-x$) %% %\cite{Budnev:1974de} %% \bibitem{Budnev:1974de} %% V.~M.~Budnev, I.~F.~Ginzburg, G.~V.~Meledin and V.~G.~Serbo, %% %``The Two photon particle production mechanism. Physical problems. %% %Applications. Equivalent photon approximation,'' %% Phys.\ Rept.\ {\bf 15} (1974) 181. %% %%CITATION = PRPLC,15,181;%% \begin{multline} \label{EPA} f(x) = \frac{\alpha}{\pi}\,q_p^2\, \frac{1}{x}\, \biggl[\left(\bar x + \frac{x^2}{2}\right) \ln\frac{Q^2_{\rm max}}{Q^2_{\rm min}} \\ - \left(1 - \frac{x}{2}\right)^2 \ln\frac{x^2+\frac{Q^2_{\rm max}}{E^2}} {x^2+\frac{Q^2_{\rm min}}{E^2}} - x^2\frac{m^2}{Q^2_{\rm min}} \left(1 - \frac{Q^2_{\rm min}}{Q^2_{\rm max}}\right) \biggr]. \end{multline} If no explicit $Q$ bounds are provided, the kinematical bounds are \begin{align} -Q^2_{\rm max} &= t_0 = -2\bar x(E^2+p\bar p) + 2m^2 \approx -4\bar x E^2, \\ -Q^2_{\rm min} &= t_1 = -2\bar x(E^2-p\bar p) + 2m^2 \approx -\frac{x^2}{\bar x}m^2. \end{align} The second and third terms in (\ref{EPA}) are negative definite (and subleading). Noting that $\bar x + x^2/2$ is bounded between $1/2$ and $1$, we derive that $f(x)$ is always smaller than \begin{equation} \bar f(x) = \frac{\alpha}{\pi}\,q_p^2\,\frac{L - 2\ln x}{x} \qquad\text{where}\qquad L = \ln\frac{\min(4E_{\rm max}^2,Q^2_{\rm max})}{\max(m^2,Q_{\rm min}^2)}, \end{equation} where we allow for explicit $Q$ bounds that narrow the kinematical range. Therefore, we generate this distribution: \begin{equation}\label{EPA-subst} \int_{x_0}^{x_1} dx\,\bar f(x) = C(x_0,x_1)\int_0^1 dx' \end{equation} We set \begin{equation}\label{EPA-x(x')} \ln x = \frac12\left\{ L - \sqrt{L^2 - 4\left[ x'\ln x_1(L-\ln x_1) + \bar x'\ln x_0(L-\ln x_0) \right]} \right\} \end{equation} such that $x(0)=x_0$ and $x(1)=x_1$ and \begin{equation} \frac{dx}{dx'} = \left(\frac{\alpha}{\pi} q_p^2 \right)^{-1} x\frac{C(x_0,x_1)}{L - 2\ln x} \end{equation} with \begin{equation} C(x_0,x_1) = \frac{\alpha}{\pi} q_p^2\,\left[\ln x_1(L-\ln x_1) - \ln x_0(L-\ln x_0)\right] \end{equation} such that (\ref{EPA-subst}) is satisfied. Finally, we have \begin{equation} \int_{x_0}^{x_1} dx\,f(x) = C(x_0,x_1)\int_0^1 dx'\, \frac{f(x(x'))}{\bar f(x(x'))} \end{equation} where $x'$ is calculated from $x$ via (\ref{EPA-x(x')}). The structure of the mapping is most obvious from: \begin{equation} x'(x) = \frac{\log x ( L - \log x) - \log x_0 (L - \log x_0)} {\log x_1 ( L - \log x_1) - \log x_0 (L - \log x_0)} \; . \end{equation} \subsection{The EPA data block} The EPA parameters are: $\alpha$, $E_{\rm max}$, $m$, $Q_{\rm min}$, and $x_{\rm min}$. Instead of $m$ we can use the incoming particle PDG code as input; from this we can deduce the mass and charge. Internally we store in addition $C_{0/1} = \frac{\alpha}{\pi}q_e^2\ln x_{0/1} (L - \ln x_{0/1})$, the c.m. energy squared and the incoming particle mass. <>= public :: epa_data_t <>= type, extends(sf_data_t) :: epa_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:), allocatable :: flv_in real(default) :: alpha real(default) :: x_min real(default) :: x_max real(default) :: q_min real(default) :: q_max real(default) :: E_max real(default) :: mass real(default) :: log real(default) :: a real(default) :: c0 real(default) :: c1 real(default) :: dc integer :: error = NONE logical :: recoil = .false. logical :: keep_energy = .true. contains <> end type epa_data_t @ %def epa_data_t @ Error codes <>= integer, parameter :: NONE = 0 integer, parameter :: ZERO_QMIN = 1 integer, parameter :: Q_MAX_TOO_SMALL = 2 integer, parameter :: ZERO_XMIN = 3 integer, parameter :: MASS_MIX = 4 integer, parameter :: NO_EPA = 5 <>= procedure :: init => epa_data_init <>= subroutine epa_data_init (data, model, pdg_in, alpha, & x_min, q_min, E_max, mass, recoil, keep_energy) class(epa_data_t), intent(inout) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in real(default), intent(in) :: alpha, x_min, q_min, E_max real(default), intent(in), optional :: mass logical, intent(in), optional :: recoil logical, intent(in), optional :: keep_energy integer :: n_flv, i data%model => model n_flv = pdg_array_get_length (pdg_in) allocate (data%flv_in (n_flv)) do i = 1, n_flv call data%flv_in(i)%init (pdg_array_get (pdg_in, i), model) end do data%alpha = alpha data%E_max = E_max data%x_min = x_min data%x_max = 1 if (vanishes (data%x_min)) then data%error = ZERO_XMIN; return end if data%q_min = q_min data%q_max = 2 * data%E_max select case (char (data%model%get_name ())) case ("QCD","Test") data%error = NO_EPA; return end select if (present (recoil)) then data%recoil = recoil end if if (present (keep_energy)) then data%keep_energy = keep_energy end if if (present (mass)) then data%mass = mass else data%mass = data%flv_in(1)%get_mass () if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if if (max (data%mass, data%q_min) == 0) then data%error = ZERO_QMIN; return else if (max (data%mass, data%q_min) >= data%E_max) then data%error = Q_MAX_TOO_SMALL; return end if data%log = log (4 * (data%E_max / max (data%mass, data%q_min)) ** 2 ) data%a = data%alpha / pi data%c0 = log (data%x_min) * (data%log - log (data%x_min)) data%c1 = log (data%x_max) * (data%log - log (data%x_max)) data%dc = data%c1 - data%c0 end subroutine epa_data_init @ %def epa_data_init @ Handle error conditions. Should always be done after initialization, unless we are sure everything is ok. <>= procedure :: check => epa_data_check <>= subroutine epa_data_check (data) class(epa_data_t), intent(in) :: data select case (data%error) case (NO_EPA) call msg_fatal ("EPA structure function not available for model " & // char (data%model%get_name ()) // ".") case (ZERO_QMIN) call msg_fatal ("EPA: Particle mass is zero") case (Q_MAX_TOO_SMALL) call msg_fatal ("EPA: Particle mass exceeds Qmax") case (ZERO_XMIN) call msg_fatal ("EPA: x_min must be larger than zero") case (MASS_MIX) call msg_fatal ("EPA: incoming particle masses must be uniform") end select end subroutine epa_data_check @ %def epa_data_check @ Output <>= procedure :: write => epa_data_write <>= subroutine epa_data_write (data, unit, verbose) class(epa_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "EPA data:" if (allocated (data%flv_in)) then write (u, "(3x,A)", advance="no") " flavor = " do i = 1, size (data%flv_in) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_in(i)%write (u) end do write (u, *) write (u, "(3x,A," // FMT_19 // ")") " alpha = ", data%alpha write (u, "(3x,A," // FMT_19 // ")") " x_min = ", data%x_min write (u, "(3x,A," // FMT_19 // ")") " x_max = ", data%x_max write (u, "(3x,A," // FMT_19 // ")") " q_min = ", data%q_min write (u, "(3x,A," // FMT_19 // ")") " q_max = ", data%q_max write (u, "(3x,A," // FMT_19 // ")") " E_max = ", data%e_max write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass write (u, "(3x,A," // FMT_19 // ")") " a = ", data%a write (u, "(3x,A," // FMT_19 // ")") " c0 = ", data%c0 write (u, "(3x,A," // FMT_19 // ")") " c1 = ", data%c1 write (u, "(3x,A," // FMT_19 // ")") " log = ", data%log write (u, "(3x,A,L2)") " recoil = ", data%recoil write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy else write (u, "(3x,A)") "[undefined]" end if end subroutine epa_data_write @ %def epa_data_write @ The number of kinematic parameters. <>= procedure :: get_n_par => epa_data_get_n_par <>= function epa_data_get_n_par (data) result (n) class(epa_data_t), intent(in) :: data integer :: n if (data%recoil) then n = 3 else n = 1 end if end function epa_data_get_n_par @ %def epa_data_get_n_par @ Return the outgoing particles PDG codes. The outgoing particle is always the photon while the radiated particle is identical to the incoming one. <>= procedure :: get_pdg_out => epa_data_get_pdg_out <>= subroutine epa_data_get_pdg_out (data, pdg_out) class(epa_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out pdg_out(1) = PHOTON end subroutine epa_data_get_pdg_out @ %def epa_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => epa_data_allocate_sf_int <>= subroutine epa_data_allocate_sf_int (data, sf_int) class(epa_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (epa_t :: sf_int) end subroutine epa_data_allocate_sf_int @ %def epa_data_allocate_sf_int @ \subsection{The EPA object} The [[epa_t]] data type is a $1\to 2$ interaction. We should be able to handle several flavors in parallel, since EPA is not necessarily applied immediately after beam collision: Photons may be radiated from quarks. In that case, the partons are massless and $q_{\rm min}$ applies instead, so we do not need to generate several kinematical configurations in parallel. The squared charge values multiply the matrix elements, depending on the flavour. We scan the interaction after building it, so we have the correct assignments. The particles are ordered as (incoming, radiated, photon), where the photon initiates the hard interaction. We generate an unpolarized photon and transfer initial polarization to the radiated parton. Color is transferred in the same way. <>= type, extends (sf_int_t) :: epa_t type(epa_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: xb = 0 real(default) :: E = 0 real(default), dimension(:), allocatable :: charge2 contains <> end type epa_t @ %def epa_t @ Type string: has to be here, but there is no string variable on which EPA depends. Hence, a dummy routine. <>= procedure :: type_string => epa_type_string <>= function epa_type_string (object) result (string) class(epa_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "EPA: equivalent photon approx." else string = "EPA: [undefined]" end if end function epa_type_string @ %def epa_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => epa_write <>= subroutine epa_write (object, unit, testflag) class(epa_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A," // FMT_17 // ")") "E =", object%E end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "EPA data: [undefined]" end if end subroutine epa_write @ %def epa_write @ Prepare the interaction object. We have to construct transition matrix elements for all flavor and helicity combinations. <>= procedure :: init => epa_init <>= subroutine epa_init (sf_int, data) class(epa_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask integer, dimension(3) :: hel_lock type(polarization_t), target :: pol type(quantum_numbers_t), dimension(1) :: qn_fc type(flavor_t) :: flv_photon type(color_t) :: col_photon type(quantum_numbers_t) :: qn_hel, qn_photon, qn, qn_rad type(polarization_iterator_t) :: it_hel integer :: i mask = quantum_numbers_mask (.false., .false., & mask_h = [.false., .false., .true.]) hel_lock = [2, 1, 0] select type (data) type is (epa_data_t) call sf_int%base_init (mask, [data%mass**2], & [data%mass**2], [0._default], hel_lock = hel_lock) sf_int%data => data call flv_photon%init (PHOTON, data%model) call col_photon%init () call qn_photon%init (flv_photon, col_photon) do i = 1, size (data%flv_in) call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) qn_rad = qn call qn_rad%tag_radiated () call sf_int%add_state ([qn, qn_rad, qn_photon]) call it_hel%advance () end do ! call pol%final () end do call sf_int%freeze () if (data%keep_energy) then sf_int%on_shell_mode = KEEP_ENERGY else sf_int%on_shell_mode = KEEP_MOMENTUM end if call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) end select end subroutine epa_init @ %def epa_init @ Prepare the charge array. This is separate from the previous routine since the state matrix may be helicity-contracted. <>= procedure :: setup_constants => epa_setup_constants <>= subroutine epa_setup_constants (sf_int) class(epa_t), intent(inout), target :: sf_int type(state_iterator_t) :: it type(flavor_t) :: flv integer :: i, n_me n_me = sf_int%get_n_matrix_elements () allocate (sf_int%charge2 (n_me)) call it%init (sf_int%interaction_t%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () flv = it%get_flavor (1) sf_int%charge2(i) = flv%get_charge () ** 2 call it%advance () end do sf_int%status = SF_INITIAL end subroutine epa_setup_constants @ %def epa_setup_constants @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. The EPA structure function allows for a straightforward mapping of the unit interval. The $x$ value is transformed, and the mapped structure function becomes unity at its upper boundary. The structure function implementation applies the above mapping to the input (random) number [[r]] to generate the momentum fraction [[x]] and the function value [[f]]. For numerical stability reasons, we also output [[xb]], which is $\bar x=1-x$. <>= procedure :: complete_kinematics => epa_complete_kinematics <>= subroutine epa_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default) :: delta, sqrt_delta, lx if (map) then associate (data => sf_int%data) delta = data%log ** 2 - 4 * (r(1) * data%c1 + rb(1) * data%c0) if (delta > 0) then sqrt_delta = sqrt (delta) lx = (data%log - sqrt_delta) / 2 else sf_int%status = SF_FAILED_KINEMATICS f = 0 return end if x(1) = exp (lx) f = x(1) * data%dc / sqrt_delta end associate else x(1) = r(1) if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then f = 1 else sf_int%status = SF_FAILED_KINEMATICS f = 0 return end if end if xb(1) = 1 - x(1) if (size(x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) sf_int%xb= xb(1) sf_int%E = energy (sf_int%get_momentum (1)) case (SF_FAILED_KINEMATICS) sf_int%x = 0 sf_int%xb= 0 f = 0 end select end subroutine epa_complete_kinematics @ %def epa_complete_kinematics @ Overriding the default method: we compute the [[x]] array from the momentum configuration. In the specific case of EPA, we also set the internally stored $x$ and $\bar x$ values, so they can be used in the following routine. Note: the extraction of $\bar x$ is not numerically safe, but it cannot be as long as the base [[recover_x]] is not. <>= procedure :: recover_x => sf_epa_recover_x <>= subroutine sf_epa_recover_x (sf_int, x, xb, x_free) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) sf_int%xb = xb(1) end subroutine sf_epa_recover_x @ %def sf_epa_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => epa_inverse_kinematics <>= subroutine epa_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(epa_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: lx, delta, sqrt_delta, c logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then associate (data => sf_int%data) lx = log (x(1)) sqrt_delta = data%log - 2 * lx delta = sqrt_delta ** 2 c = (data%log ** 2 - delta) / 4 r (1) = (c - data%c0) / data%dc rb(1) = (data%c1 - c) / data%dc f = x(1) * data%dc / sqrt_delta end associate else r (1) = x(1) rb(1) = xb(1) if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then f = 1 else f = 0 end if end if if (size(r) == 3) then r (2:3) = x(2:3) rb(2:3) = xb(2:3) end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if sf_int%E = energy (sf_int%get_momentum (1)) end subroutine epa_inverse_kinematics @ %def epa_inverse_kinematics @ \subsection{EPA application} For EPA, we can in principle compute kinematics and function value in a single step. In order to be able to reweight events, kinematics and structure function application are separated. This function works on a single beam, assuming that the input momentum has been set. We need three random numbers as input: one for $x$, and two for the polar and azimuthal angles. Alternatively, for the no-recoil case, we can skip $p_T$ generation; in this case, we only need one. For obtaining splitting kinematics, we rely on the assumption that all in-particles are mass-degenerate (or there is only one), so the generated $x$ values are identical. <>= procedure :: apply => epa_apply <>= subroutine epa_apply (sf_int, scale, rescale, i_sub) class(epa_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: x, xb, qminsq, qmaxsq, f, E associate (data => sf_int%data) x = sf_int%x xb= sf_int%xb E = sf_int%E qminsq = max (x ** 2 / xb * data%mass ** 2, data%q_min ** 2) qmaxsq = min (4 * xb * E ** 2, data%q_max ** 2) if (qminsq < qmaxsq) then f = data%a / x & * ((xb + x ** 2 / 2) * log (qmaxsq / qminsq) & - (1 - x / 2) ** 2 & * log ((x**2 + qmaxsq / E ** 2) / (x**2 + qminsq / E ** 2)) & - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq)) else f = 0 end if call sf_int%set_matrix_element & (cmplx (f, kind=default) * sf_int%charge2) end associate sf_int%status = SF_EVALUATED end subroutine epa_apply @ %def epa_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_epa_ut.f90]]>>= <> module sf_epa_ut use unit_tests use sf_epa_uti <> <> contains <> end module sf_epa_ut @ %def sf_epa_ut @ <<[[sf_epa_uti.f90]]>>= <> module sf_epa_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use interactions, only: interaction_pacify_momenta use model_data use sf_aux use sf_base use sf_epa <> <> contains <> end module sf_epa_uti @ %def sf_epa_ut @ API: driver for the unit tests below. <>= public :: sf_epa_test <>= subroutine sf_epa_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_epa_test @ %def sf_epa_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_epa_1, "sf_epa_1", & "structure function configuration", & u, results) <>= public :: sf_epa_1 <>= subroutine sf_epa_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_epa_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_qed_test () pdg_in = ELECTRON allocate (epa_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (epa_data_t) call data%init (model, pdg_in, 1./137._default, 0.01_default, & 10._default, 50._default, 0.000511_default, recoil = .false.) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_1" end subroutine sf_epa_1 @ %def sf_epa_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the EPA structure function. <>= call test (sf_epa_2, "sf_epa_2", & "structure function instance", & u, results) <>= public :: sf_epa_2 <>= subroutine sf_epa_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, pdg_in, 1./137._default, 0.01_default, & 10._default, 50._default, 0.000511_default, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EPA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_2" end subroutine sf_epa_2 @ %def sf_epa_2 @ \subsubsection{Standard mapping} Construct and display a structure function object based on the EPA structure function, applying the standard single-particle mapping. <>= call test (sf_epa_3, "sf_epa_3", & "apply mapping", & u, results) <>= public :: sf_epa_3 <>= subroutine sf_epa_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_3" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, pdg_in, 1./137._default, 0.01_default, & 10._default, 50._default, 0.000511_default, recoil = .false.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, with EPA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_3" end subroutine sf_epa_3 @ %def sf_epa_3 @ \subsubsection{Non-collinear case} Construct and display a structure function object based on the EPA structure function. <>= call test (sf_epa_4, "sf_epa_4", & "non-collinear", & u, results) <>= public :: sf_epa_4 <>= subroutine sf_epa_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E, m real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_4" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv%init (ELECTRON, model) pdg_in = ELECTRON call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, pdg_in, 1./137._default, 0.01_default, & 10._default, 50._default, 5.0_default, recoil = .true.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500, me = 5 GeV" write (u, "(A)") E = 500 m = 5 k = vector4_moving (E, sqrt (E**2 - m**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.5/0.5/0.25, with EPA mapping, " write (u, "(A)") " non-coll., keeping energy, me = 5 GeV" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.5_default, 0.5_default, 0.25_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x and r from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_4" end subroutine sf_epa_4 @ %def sf_epa_4 @ \subsubsection{Structure function for multiple flavors} Construct and display a structure function object based on the EPA structure function. The incoming state has multiple particles with non-uniform charge. <>= call test (sf_epa_5, "sf_epa_5", & "multiple flavors", & u, results) <>= public :: sf_epa_5 <>= subroutine sf_epa_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_epa_5" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (1, model) pdg_in = [1, 2, -1, -2] call reset_interaction_counter () allocate (epa_data_t :: data) select type (data) type is (epa_data_t) call data%init (model, pdg_in, 1./137._default, 0.01_default, & 10._default, 50._default, 0.000511_default, recoil = .false.) call data%check () end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EPA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EPA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_epa_5" end subroutine sf_epa_5 @ %def sf_epa_5 @ \clearpage %------------------------------------------------------------------------ \section{EWA} <<[[sf_ewa.f90]]>>= <> module sf_ewa <> <> use io_units use constants, only: pi use format_defs, only: FMT_17, FMT_19 use numeric_utils use diagnostics use physics_defs, only: W_BOSON, Z_BOSON use lorentz use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use interactions use sf_aux use sf_base <> <> <> <> contains <> end module sf_ewa @ %def sf_ewa @ \subsection{Physics} The EWA structure function for a $Z$ or $W$ inside a fermion (lepton or quark) depends on the vector-boson polarization. We distinguish transversal ($\pm$) and longitudinal ($0$) polarization. \begin{align} F_{+}(x) &= \frac{1}{16\pi^2}\,\frac{(v-a)^2 + (v+a)^2\bar x^2}{x} \left[ \ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right) - \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2} \right] \\ F_{-}(x) &= \frac{1}{16\pi^2}\,\frac{(v+a)^2 + (v-a)^2\bar x^2}{x} \left[ \ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right) - \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2} \right] \\ F_0(x) &= \frac{v^2+a^2}{8\pi^2}\,\frac{2\bar x}{x}\, \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2} \end{align} where $p_{\perp,\textrm{max}}$ is the cutoff in transversal momentum, $M$ is the vector-boson mass, $v$ and $a$ are the vector and axial-vector couplings, and $\bar x\equiv 1-x$. Note that the longitudinal structure function is finite for large cutoff, while the transversal structure function is logarithmically divergent. The maximal transverse momentum is given by the kinematical limit, it is \begin{equation} p_{\perp,\textrm{max}} = \bar x \sqrt{s}/2. \end{equation} The vector and axial couplings for a fermion branching into a $W$ are \begin{align} v_W &= \frac{g}{2\sqrt 2}, & a_W &= \frac{g}{2\sqrt 2}. \end{align} For $Z$ emission, this is replaced by \begin{align} v_Z &= \frac{g}{2\cos\theta_w}\left(t_3 - 2q\sin^2\theta_w\right), & a_Z &= \frac{g}{2\cos\theta_w}t_3, \end{align} where $t_3=\pm\frac12$ is the fermion isospin, and $q$ its charge. For an initial antifermion, the signs of the axial couplings are inverted. Note that a common sign change of $v$ and $a$ is irrelevant. %% Differentiating with respect to the cutoff, we get structure functions %% \begin{align} %% f_{W,\pm}(x,p_T) &= \frac{g^2}{16\pi^2}\, %% \frac{1+\bar x^2}{x} %% \frac{p_\perp}{p_\perp^2 + \bar x M^2} %% \\ %% f_{W,0}(x,p_T) &= \frac{g^2}{16\pi^2}\, %% \frac{2\bar x}{x}\, %% \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2} %% \\ %% F_{Z,\pm}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2} %% \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\, %% \frac{1+\bar x^2}{x} %% \frac{p_\perp}{p_\perp^2 + \bar x M^2} %% \\ %% F_{Z,0}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2}\, %% \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\, %% \frac{2\bar x}{x}\, %% \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2} %% \end{align} %% Here, $t_3^f$ is the $SU(2)_L$ quantum number of the fermion %% $(\pm\frac12)$, and $q^f$ is the fermion charge in units of the %% positron charge. The EWA depends on the parameters $g$, $\sin^2\theta_w$, $M_W$, and $M_Z$. These can all be taken from the SM input, and the prefactors are calculated from those and the incoming particle type. Since these structure functions have a $1/x$ singularity (which is not really relevant in practice, however, since the vector boson mass is finite), we map this singularity allowing for nontrivial $x$ bounds: \begin{equation} x = \exp(\bar r\ln x_0 + r\ln x_1) \end{equation} such that \begin{equation} \int_{x_0}^{x_1}\frac{dx}{x} = (\ln x_1 - \ln x_0)\int_0^1 dr. \end{equation} As a user parameter, we have the cutoff $p_{\perp,\textrm{max}}$. The divergence $1/x$ also requires a $x_0$ cutoff; and for completeness we introduce a corresponding $x_1$. Physically, the minimal sensible value of $x$ is $M^2/s$, although the approximation loses its value already at higher $x$ values. \subsection{The EWA data block} The EWA parameters are: $p_{T,\rm max}$, $c_V$, $c_A$, and $m$. Instead of $m$ we can use the incoming particle PDG code as input; from this we can deduce the mass and charges. In the initialization phase it is not yet determined whether a $W$ or a $Z$ is radiated, hence we set the vector and axial-vector couplings equal to the common prefactors $g/2 = e/2/\sin\theta_W$. In principle, for EWA it would make sense to allow the user to also set the upper bound for $x$, $x_{\rm max}$, but we fix it to one here. <>= public :: ewa_data_t <>= type, extends(sf_data_t) :: ewa_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(:), allocatable :: flv_in type(flavor_t), dimension(:), allocatable :: flv_out real(default) :: pt_max real(default) :: sqrts real(default) :: x_min real(default) :: x_max real(default) :: mass real(default) :: m_out real(default) :: q_min real(default) :: cv real(default) :: ca real(default) :: costhw real(default) :: sinthw real(default) :: mW real(default) :: mZ real(default) :: coeff logical :: mass_set = .false. logical :: recoil = .false. logical :: keep_energy = .false. integer :: id = 0 integer :: error = NONE contains <> end type ewa_data_t @ %def ewa_data_t @ Error codes <>= integer, parameter :: NONE = 0 integer, parameter :: ZERO_QMIN = 1 integer, parameter :: Q_MAX_TOO_SMALL = 2 integer, parameter :: ZERO_XMIN = 3 integer, parameter :: MASS_MIX = 4 integer, parameter :: ZERO_SW = 5 integer, parameter :: ISOSPIN_MIX = 6 integer, parameter :: WRONG_PRT = 7 integer, parameter :: MASS_MIX_OUT = 8 integer, parameter :: NO_EWA = 9 <>= procedure :: init => ewa_data_init <>= subroutine ewa_data_init (data, model, pdg_in, x_min, pt_max, & sqrts, recoil, keep_energy, mass) class(ewa_data_t), intent(inout) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), intent(in) :: pdg_in real(default), intent(in) :: x_min, pt_max, sqrts logical, intent(in) :: recoil, keep_energy real(default), intent(in), optional :: mass real(default) :: g, ee integer :: n_flv, i data%model => model if (.not. any (pdg_in .match. & [1,2,3,4,5,6,11,13,15,-1,-2,-3,-4,-5,-6,-11,-13,-15])) then data%error = WRONG_PRT; return end if n_flv = pdg_array_get_length (pdg_in) allocate (data%flv_in (n_flv)) allocate (data%flv_out(n_flv)) do i = 1, n_flv call data%flv_in(i)%init (pdg_array_get (pdg_in, i), model) end do data%pt_max = pt_max data%sqrts = sqrts data%x_min = x_min data%x_max = 1 if (vanishes (data%x_min)) then data%error = ZERO_XMIN; return end if select case (char (data%model%get_name ())) case ("QCD","QED","Test") data%error = NO_EWA; return end select ee = data%model%get_real (var_str ("ee")) data%sinthw = data%model%get_real (var_str ("sw")) data%costhw = data%model%get_real (var_str ("cw")) data%mZ = data%model%get_real (var_str ("mZ")) data%mW = data%model%get_real (var_str ("mW")) if (data%sinthw /= 0) then g = ee / data%sinthw else data%error = ZERO_SW; return end if data%cv = g / 2._default data%ca = g / 2._default data%coeff = 1._default / (8._default * PI**2) data%recoil = recoil data%keep_energy = keep_energy if (present (mass)) then data%mass = mass data%m_out = mass data%mass_set = .true. else data%mass = data%flv_in(1)%get_mass () if (any (data%flv_in%get_mass () /= data%mass)) then data%error = MASS_MIX; return end if end if end subroutine ewa_data_init @ %def ewa_data_init @ Set the vector boson ID for distinguishing $W$ and $Z$ bosons. <>= procedure :: set_id => ewa_set_id <>= subroutine ewa_set_id (data, id) class(ewa_data_t), intent(inout) :: data integer, intent(in) :: id integer :: i, isospin, pdg if (.not. allocated (data%flv_in)) & call msg_bug ("EWA: incoming particles not set") data%id = id select case (data%id) case (23) data%m_out = data%mass data%flv_out = data%flv_in case (24) do i = 1, size (data%flv_in) pdg = data%flv_in(i)%get_pdg () isospin = data%flv_in(i)%get_isospin_type () if (isospin > 0) then !!! up-type quark or neutrinos if (data%flv_in(i)%is_antiparticle ()) then call data%flv_out(i)%init (pdg + 1, data%model) else call data%flv_out(i)%init (pdg - 1, data%model) end if else !!! down-type quark or lepton if (data%flv_in(i)%is_antiparticle ()) then call data%flv_out(i)%init (pdg - 1, data%model) else call data%flv_out(i)%init (pdg + 1, data%model) end if end if end do if (.not. data%mass_set) then data%m_out = data%flv_out(1)%get_mass () if (any (data%flv_out%get_mass () /= data%m_out)) then data%error = MASS_MIX_OUT; return end if end if end select end subroutine ewa_set_id @ %def ewa_set_id @ Handle error conditions. Should always be done after initialization, unless we are sure everything is ok. <>= procedure :: check => ewa_data_check <>= subroutine ewa_data_check (data) class(ewa_data_t), intent(in) :: data select case (data%error) case (WRONG_PRT) call msg_fatal ("EWA structure function only accessible for " & // "SM quarks and leptons.") case (NO_EWA) call msg_fatal ("EWA structure function not available for model " & // char (data%model%get_name ())) case (ZERO_SW) call msg_fatal ("EWA: Vanishing value of sin(theta_w)") case (ZERO_QMIN) call msg_fatal ("EWA: Particle mass is zero") case (Q_MAX_TOO_SMALL) call msg_fatal ("EWA: Particle mass exceeds Qmax") case (ZERO_XMIN) call msg_fatal ("EWA: x_min must be larger than zero") case (MASS_MIX) call msg_fatal ("EWA: incoming particle masses must be uniform") case (MASS_MIX_OUT) call msg_fatal ("EWA: outgoing particle masses must be uniform") case (ISOSPIN_MIX) call msg_fatal ("EWA: incoming particle isospins must be uniform") end select end subroutine ewa_data_check @ %def ewa_data_check @ Output <>= procedure :: write => ewa_data_write <>= subroutine ewa_data_write (data, unit, verbose) class(ewa_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "EWA data:" if (allocated (data%flv_in) .and. allocated (data%flv_out)) then write (u, "(3x,A)", advance="no") " flavor(in) = " do i = 1, size (data%flv_in) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_in(i)%write (u) end do write (u, *) write (u, "(3x,A)", advance="no") " flavor(out) = " do i = 1, size (data%flv_out) if (i > 1) write (u, "(',',1x)", advance="no") call data%flv_out(i)%write (u) end do write (u, *) write (u, "(3x,A," // FMT_19 // ")") " x_min = ", data%x_min write (u, "(3x,A," // FMT_19 // ")") " x_max = ", data%x_max write (u, "(3x,A," // FMT_19 // ")") " pt_max = ", data%pt_max write (u, "(3x,A," // FMT_19 // ")") " sqrts = ", data%sqrts write (u, "(3x,A," // FMT_19 // ")") " mass = ", data%mass write (u, "(3x,A," // FMT_19 // ")") " cv = ", data%cv write (u, "(3x,A," // FMT_19 // ")") " ca = ", data%ca write (u, "(3x,A," // FMT_19 // ")") " coeff = ", data%coeff write (u, "(3x,A," // FMT_19 // ")") " costhw = ", data%costhw write (u, "(3x,A," // FMT_19 // ")") " sinthw = ", data%sinthw write (u, "(3x,A," // FMT_19 // ")") " mZ = ", data%mZ write (u, "(3x,A," // FMT_19 // ")") " mW = ", data%mW write (u, "(3x,A,L2)") " recoil = ", data%recoil write (u, "(3x,A,L2)") " keep en. = ", data%keep_energy write (u, "(3x,A,I2)") " PDG (VB) = ", data%id else write (u, "(3x,A)") "[undefined]" end if end subroutine ewa_data_write @ %def ewa_data_write @ The number of parameters is one for collinear splitting, in case the [[recoil]] option is set, we take the recoil into account. <>= procedure :: get_n_par => ewa_data_get_n_par <>= function ewa_data_get_n_par (data) result (n) class(ewa_data_t), intent(in) :: data integer :: n if (data%recoil) then n = 3 else n = 1 end if end function ewa_data_get_n_par @ %def ewa_data_get_n_par @ Return the outgoing particles PDG codes. This depends, whether this is a charged-current or neutral-current interaction. <>= procedure :: get_pdg_out => ewa_data_get_pdg_out <>= subroutine ewa_data_get_pdg_out (data, pdg_out) class(ewa_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer, dimension(:), allocatable :: pdg1 integer :: i, n_flv if (allocated (data%flv_out)) then n_flv = size (data%flv_out) else n_flv = 0 end if allocate (pdg1 (n_flv)) do i = 1, n_flv pdg1(i) = data%flv_out(i)%get_pdg () end do pdg_out(1) = pdg1 end subroutine ewa_data_get_pdg_out @ %def ewa_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => ewa_data_allocate_sf_int <>= subroutine ewa_data_allocate_sf_int (data, sf_int) class(ewa_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (ewa_t :: sf_int) end subroutine ewa_data_allocate_sf_int @ %def ewa_data_allocate_sf_int @ \subsection{The EWA object} The [[ewa_t]] data type is a $1\to 2$ interaction. We should be able to handle several flavors in parallel, since EWA is not necessarily applied immediately after beam collision: $W/Z$ bosons may be radiated from quarks. In that case, the partons are massless and $q_{\rm min}$ applies instead, so we do not need to generate several kinematical configurations in parallel. The particles are ordered as (incoming, radiated, W/Z), where the W/Z initiates the hard interaction. In the case of EPA, we generated an unpolarized photon and transferred initial polarization to the radiated parton. Color is transferred in the same way. I do not know whether the same can/should be done for EWA, as the structure functions depend on the W/Z polarization. If we are having $Z$ bosons, both up- and down-type fermions can participate. Otherwise, with a $W^+$ an up-type fermion is transferred to a down-type fermion, and the other way round. <>= type, extends (sf_int_t) :: ewa_t type(ewa_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: xb = 0 integer :: n_me = 0 real(default), dimension(:), allocatable :: cv real(default), dimension(:), allocatable :: ca contains <> end type ewa_t @ %def ewa_t @ Type string: has to be here, but there is no string variable on which EWA depends. Hence, a dummy routine. <>= procedure :: type_string => ewa_type_string <>= function ewa_type_string (object) result (string) class(ewa_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "EWA: equivalent W/Z approx." else string = "EWA: [undefined]" end if end function ewa_type_string @ %def ewa_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => ewa_write <>= subroutine ewa_write (object, unit, testflag) class(ewa_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x write (u, "(3x,A," // FMT_17 // ")") "xb=", object%xb end if call object%base_write (u, testflag) else write (u, "(1x,A)") "EWA data: [undefined]" end if end subroutine ewa_write @ %def ewa_write @ The current implementation requires uniform isospin for all incoming particles, therefore we need to probe only the first one. <>= procedure :: init => ewa_init <>= subroutine ewa_init (sf_int, data) class(ewa_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask integer, dimension(3) :: hel_lock type(polarization_t), target :: pol type(quantum_numbers_t), dimension(1) :: qn_fc, qn_fc_fin type(flavor_t) :: flv_z, flv_wp, flv_wm type(color_t) :: col0 type(quantum_numbers_t) :: qn_hel, qn_z, qn_wp, qn_wm, qn, qn_rad, qn_w type(polarization_iterator_t) :: it_hel integer :: i, isospin select type (data) type is (ewa_data_t) mask = quantum_numbers_mask (.false., .false., & mask_h = [.false., .false., .true.]) hel_lock = [2, 1, 0] call col0%init () select case (data%id) case (23) !!! Z boson, flavor is not changing call sf_int%base_init (mask, [data%mass**2], [data%mass**2], & [data%mZ**2], hel_lock = hel_lock) sf_int%data => data call flv_z%init (Z_BOSON, data%model) call qn_z%init (flv_z, col0) do i = 1, size (data%flv_in) call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) qn_rad = qn call qn_rad%tag_radiated () call sf_int%add_state ([qn, qn_rad, qn_z]) call it_hel%advance () end do ! call pol%final () end do case (24) call sf_int%base_init (mask, [data%mass**2], [data%m_out**2], & [data%mW**2], hel_lock = hel_lock) sf_int%data => data call flv_wp%init (W_BOSON, data%model) call flv_wm%init (- W_BOSON, data%model) call qn_wp%init (flv_wp, col0) call qn_wm%init (flv_wm, col0) do i = 1, size (data%flv_in) isospin = data%flv_in(i)%get_isospin_type () if (isospin > 0) then !!! up-type quark or neutrinos if (data%flv_in(i)%is_antiparticle ()) then qn_w = qn_wm else qn_w = qn_wp end if else !!! down-type quark or lepton if (data%flv_in(i)%is_antiparticle ()) then qn_w = qn_wp else qn_w = qn_wm end if end if call pol%init_generic (data%flv_in(i)) call qn_fc(1)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i), 1)) call qn_fc_fin(1)%init ( & flv = data%flv_out(i), & col = color_from_flavor (data%flv_out(i), 1)) call it_hel%init (pol) do while (it_hel%is_valid ()) qn_hel = it_hel%get_quantum_numbers () qn = qn_hel .merge. qn_fc(1) qn_rad = qn_hel .merge. qn_fc_fin(1) call qn_rad%tag_radiated () call sf_int%add_state ([qn, qn_rad, qn_w]) call it_hel%advance () end do ! call pol%final () end do case default call msg_fatal ("EWA initialization failed: wrong particle type.") end select call sf_int%freeze () if (data%keep_energy) then sf_int%on_shell_mode = KEEP_ENERGY else sf_int%on_shell_mode = KEEP_MOMENTUM end if call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) end select end subroutine ewa_init @ %def ewa_init @ Prepare the coupling arrays. This is separate from the previous routine since the state matrix may be helicity-contracted. <>= procedure :: setup_constants => ewa_setup_constants <>= subroutine ewa_setup_constants (sf_int) class(ewa_t), intent(inout), target :: sf_int type(state_iterator_t) :: it type(flavor_t) :: flv real(default) :: q, t3 integer :: i sf_int%n_me = sf_int%get_n_matrix_elements () allocate (sf_int%cv (sf_int%n_me)) allocate (sf_int%ca (sf_int%n_me)) associate (data => sf_int%data) select case (data%id) case (23) call it%init (sf_int%interaction_t%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () flv = it%get_flavor (1) q = flv%get_charge () t3 = flv%get_isospin () if (flv%is_antiparticle ()) then sf_int%cv(i) = - data%cv & * (t3 - 2._default * q * data%sinthw**2) / data%costhw sf_int%ca(i) = data%ca * t3 / data%costhw else sf_int%cv(i) = data%cv & * (t3 - 2._default * q * data%sinthw**2) / data%costhw sf_int%ca(i) = data%ca * t3 / data%costhw end if call it%advance () end do case (24) call it%init (sf_int%interaction_t%get_state_matrix_ptr ()) do while (it%is_valid ()) i = it%get_me_index () flv = it%get_flavor (1) if (flv%is_antiparticle ()) then sf_int%cv(i) = data%cv / sqrt(2._default) sf_int%ca(i) = - data%ca / sqrt(2._default) else sf_int%cv(i) = data%cv / sqrt(2._default) sf_int%ca(i) = data%ca / sqrt(2._default) end if call it%advance () end do end select end associate sf_int%status = SF_INITIAL end subroutine ewa_setup_constants @ %def ewa_setup_constants @ \subsection{Kinematics} Set kinematics. The EWA structure function allows for a straightforward mapping of the unit interval. So, to leading order, the structure function value is unity, but the $x$ value is transformed. Higher orders affect the function value. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, the exponential mapping for the $1/x$ singularity discussed above is applied. <>= procedure :: complete_kinematics => ewa_complete_kinematics <>= subroutine ewa_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map real(default) :: e_1 real(default) :: x0, x1, lx0, lx1, lx e_1 = energy (sf_int%get_momentum (1)) if (sf_int%data%recoil) then select case (sf_int%data%id) case (23) x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1) case (24) x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1) end select else x0 = sf_int%data%x_min end if x1 = sf_int%data%x_max if ( x0 >= x1) then f = 0 sf_int%status = SF_FAILED_KINEMATICS return end if if (map) then lx0 = log (x0) lx1 = log (x1) lx = lx1 * r(1) + lx0 * rb(1) x(1) = exp(lx) f = x(1) * (lx1 - lx0) else x(1) = r(1) if (x0 < x(1) .and. x(1) < x1) then f = 1 else sf_int%status = SF_FAILED_KINEMATICS f = 0 return end if end if xb(1) = 1 - x(1) if (size(x) == 3) then x(2:3) = r(2:3) xb(2:3) = rb(2:3) end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) sf_int%xb = xb(1) case (SF_FAILED_KINEMATICS) sf_int%x = 0 sf_int%xb = 0 f = 0 end select end subroutine ewa_complete_kinematics @ %def ewa_complete_kinematics @ Overriding the default method: we compute the [[x]] array from the momentum configuration. In the specific case of EWA, we also set the internally stored $x$ and $\bar x$ values, so they can be used in the following routine. <>= procedure :: recover_x => sf_ewa_recover_x <>= subroutine sf_ewa_recover_x (sf_int, x, xb, x_free) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) sf_int%xb = xb(1) end subroutine sf_ewa_recover_x @ %def sf_ewa_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => ewa_inverse_kinematics <>= subroutine ewa_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(ewa_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: x0, x1, lx0, lx1, lx, e_1 logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta e_1 = energy (sf_int%get_momentum (1)) if (sf_int%data%recoil) then select case (sf_int%data%id) case (23) x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1) case (24) x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1) end select else x0 = sf_int%data%x_min end if x1 = sf_int%data%x_max if (map) then lx0 = log (x0) lx1 = log (x1) lx = log (x(1)) r(1) = (lx - lx0) / (lx1 - lx0) rb(1) = (lx1 - lx) / (lx1 - lx0) f = x(1) * (lx1 - lx0) else r (1) = x(1) rb(1) = 1 - x(1) if (x0 < x(1) .and. x(1) < x1) then f = 1 else f = 0 end if end if if (size(r) == 3) then r (2:3) = x(2:3) rb(2:3) = xb(2:3) end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine ewa_inverse_kinematics @ %def ewa_inverse_kinematics @ \subsection{EWA application} For EWA, we can compute kinematics and function value in a single step. This function works on a single beam, assuming that the input momentum has been set. We need four random numbers as input: one for $x$, one for $Q^2$, and two for the polar and azimuthal angles. Alternatively, we can skip $p_T$ generation; in this case, we only need one. For obtaining splitting kinematics, we rely on the assumption that all in-particles are mass-degenerate (or there is only one), so the generated $x$ values are identical. <>= procedure :: apply => ewa_apply <>= subroutine ewa_apply (sf_int, scale, rescale, i_sub) class(ewa_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: x, xb, pt2, c1, c2 real(default) :: cv, ca real(default) :: f, fm, fp, fL integer :: i associate (data => sf_int%data) x = sf_int%x xb = sf_int%xb pt2 = min ((data%pt_max)**2, (xb * data%sqrts / 2)**2) select case (data%id) case (23) !!! Z boson structure function c1 = log (1 + pt2 / (xb * (data%mZ)**2)) c2 = 1 / (1 + (xb * (data%mZ)**2) / pt2) case (24) !!! W boson structure function c1 = log (1 + pt2 / (xb * (data%mW)**2)) c2 = 1 / (1 + (xb * (data%mW)**2) / pt2) end select do i = 1, sf_int%n_me cv = sf_int%cv(i) ca = sf_int%ca(i) fm = data%coeff * & ((cv + ca)**2 + ((cv - ca) * xb)**2) * (c1 - c2) / (2 * x) fp = data%coeff * & ((cv - ca)**2 + ((cv + ca) * xb)**2) * (c1 - c2) / (2 * x) fL = data%coeff * & (cv**2 + ca**2) * (2 * xb / x) * c2 f = fp + fm + fL if (.not. vanishes (f)) then fp = fp / f fm = fm / f fL = fL / f end if call sf_int%set_matrix_element (i, cmplx (f, kind=default)) end do end associate sf_int%status = SF_EVALUATED end subroutine ewa_apply @ %def ewa_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_ewa_ut.f90]]>>= <> module sf_ewa_ut use unit_tests use sf_ewa_uti <> <> contains <> end module sf_ewa_ut @ %def sf_ewa_ut @ <<[[sf_ewa_uti.f90]]>>= <> module sf_ewa_uti <> use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use interactions, only: interaction_pacify_momenta use model_data use sf_aux use sf_base use sf_ewa <> <> contains <> end module sf_ewa_uti @ %def sf_ewa_ut @ API: driver for the unit tests below. <>= public :: sf_ewa_test <>= subroutine sf_ewa_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_ewa_test @ %def sf_ewa_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_ewa_1, "sf_ewa_1", & "structure function configuration", & u, results) <>= public :: sf_ewa_1 <>= subroutine sf_ewa_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t) :: pdg_in type(pdg_array_t), dimension(1) :: pdg_out integer, dimension(:), allocatable :: pdg1 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_ewa_1" write (u, "(A)") "* Purpose: initialize and display & &test structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_sm_test () pdg_in = 2 allocate (ewa_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize for Z boson" write (u, "(A)") select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 5000._default, .false., .false.) call data%set_id (23) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 write (u, "(A)") write (u, "(A)") "* Initialize for W boson" write (u, "(A)") deallocate (data) allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 5000._default, .false., .false.) call data%set_id (24) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) write (u, "(2x,99(1x,I0))") pdg1 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_1" end subroutine sf_ewa_1 @ %def sf_ewa_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the EWA structure function. <>= call test (sf_ewa_2, "sf_ewa_2", & "structure function instance", & u, results) <>= public :: sf_ewa_2 <>= subroutine sf_ewa_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_2" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (2, model) pdg_in = 2 call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000._default, .false., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EWA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_2" end subroutine sf_ewa_2 @ %def sf_ewa_2 @ \subsubsection{Standard mapping} Construct and display a structure function object based on the EWA structure function, applying the standard single-particle mapping. <>= call test (sf_ewa_3, "sf_ewa_3", & "apply mapping", & u, results) <>= public :: sf_ewa_3 <>= subroutine sf_ewa_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_3" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (2, model) pdg_in = 2 call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000._default, .false., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, with EWA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_3" end subroutine sf_ewa_3 @ %def sf_ewa_3 @ \subsubsection{Non-collinear case} Construct and display a structure function object based on the EPA structure function. <>= call test (sf_ewa_4, "sf_ewa_4", & "non-collinear", & u, results) <>= public :: sf_ewa_4 <>= subroutine sf_ewa_4 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k type(vector4_t), dimension(2) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_4" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call modeL%init_sm_test () call flv%init (2, model) pdg_in = 2 call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000.0_default, .true., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.5/0.5/0.25, with EWA mapping, " write (u, "(A)") " non-coll., keeping energy" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.5_default, 0.5_default, 0.25_default] rb = 1 - r sf_int%on_shell_mode = KEEP_ENERGY call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x and r from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%seed_kinematics ([k]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., & set_momenta=.true.) call interaction_pacify_momenta (sf_int%interaction_t, 1e-10_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 1500._default) call sf_int%write (u, testflag = .true.) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_4" end subroutine sf_ewa_4 @ %def sf_ewa_4 @ \subsubsection{Structure function for multiple flavors} Construct and display a structure function object based on the EWA structure function. The incoming state has multiple particles with non-uniform quantum numbers. <>= call test (sf_ewa_5, "sf_ewa_5", & "structure function instance", & u, results) <>= public :: sf_ewa_5 <>= subroutine sf_ewa_5 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t) :: flv type(pdg_array_t) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_ewa_5" write (u, "(A)") "* Purpose: initialize and fill & &test structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_sm_test () call flv%init (2, model) pdg_in = [1, 2, -1, -2] call reset_interaction_counter () allocate (ewa_data_t :: data) select type (data) type is (ewa_data_t) call data%init (model, pdg_in, 0.01_default, & 500._default, 3000._default, .false., .true.) call data%set_id (24) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1]) call sf_int%setup_constants () call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=1500" write (u, "(A)") E = 1500 k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3) call pacify (k, 1e-10_default) call vector4_write (k, u) call sf_int%seed_kinematics ([k]) write (u, "(A)") write (u, "(A)") "* Set kinematics for r=0.4, no EWA mapping, collinear" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.4_default rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Evaluate EWA structure function" write (u, "(A)") call sf_int%apply (scale = 100._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_ewa_5" end subroutine sf_ewa_5 @ %def sf_ewa_5 @ \clearpage %------------------------------------------------------------------------ \section{Energy-scan spectrum} This spectrum is actually a trick that allows us to plot the c.m.\ energy dependence of a cross section without scanning the input energy. We start with the observation that a spectrum $f(x)$, applied to one of the incoming beams only, results in a cross section \begin{equation} \sigma = \int dx\,f(x)\,\hat\sigma(xs). \end{equation} We want to compute the distribution of $E=\sqrt{\hat s}=\sqrt{xs}$, i.e., \begin{equation} \frac{d\sigma}{dE} = \frac{2\sqrt{x}}{\sqrt{s}}\,\frac{d\sigma}{dx} = \frac{2\sqrt{x}}{\sqrt{s}}\,f(x)\,\hat\sigma(xs), \end{equation} so if we set \begin{equation} f(x) = \frac{\sqrt{s}}{2\sqrt{x}}, \end{equation} we get the distribution \begin{equation} \frac{d\sigma}{dE} = \hat\sigma(\hat s=E^2). \end{equation} We implement this as a spectrum with a single parameter $x$. The parameters for the individual beams are computed as $x_i=\sqrt{x}$, so they are equal and the kinematics is always symmetric. <<[[sf_escan.f90]]>>= <> module sf_escan <> <> use io_units use format_defs, only: FMT_12 use numeric_utils use diagnostics use lorentz use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use sf_base <> <> <> contains <> end module sf_escan @ %def sf_escan @ \subsection{Data type} The [[norm]] is unity if the total cross section should be normalized to one, and $\sqrt{s}$ if it should be normalized to the total energy. In the latter case, the differential distribution $d\sigma/d\sqrt{\hat s}$ coincides with the partonic cross section $\hat\sigma$ as a function of $\sqrt{\hat s}$. <>= public :: escan_data_t <>= type, extends(sf_data_t) :: escan_data_t private type(flavor_t), dimension(:,:), allocatable :: flv_in integer, dimension(2) :: n_flv = 0 real(default) :: norm = 1 contains <> end type escan_data_t @ %def escan_data_t <>= procedure :: init => escan_data_init <>= subroutine escan_data_init (data, model, pdg_in, norm) class(escan_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in), optional :: norm real(default), dimension(2) :: m2 integer :: i, j data%n_flv = pdg_array_get_length (pdg_in) allocate (data%flv_in (maxval (data%n_flv), 2)) do i = 1, 2 do j = 1, data%n_flv(i) call data%flv_in(j, i)%init (pdg_array_get (pdg_in(i), j), model) end do end do m2 = data%flv_in(1,:)%get_mass () do i = 1, 2 if (.not. any (nearly_equal (data%flv_in(1:data%n_flv(i),i)%get_mass (), m2(i)))) then call msg_fatal ("Energy scan: incoming particle mass must be uniform") end if end do if (present (norm)) data%norm = norm end subroutine escan_data_init @ %def escan_data_init @ Output <>= procedure :: write => escan_data_write <>= subroutine escan_data_write (data, unit, verbose) class(escan_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, i, j u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Energy-scan data:" write (u, "(3x,A)", advance="no") "prt_in = " do i = 1, 2 if (i > 1) write (u, "(',',1x)", advance="no") do j = 1, data%n_flv(i) if (j > 1) write (u, "(':')", advance="no") write (u, "(A)", advance="no") char (data%flv_in(j,i)%get_name ()) end do end do write (u, *) write (u, "(3x,A," // FMT_12 // ")") "norm =", data%norm end subroutine escan_data_write @ %def escan_data_write @ Kinematics is completely collinear, hence there is only one parameter for a pair spectrum. <>= procedure :: get_n_par => escan_data_get_n_par <>= function escan_data_get_n_par (data) result (n) class(escan_data_t), intent(in) :: data integer :: n n = 1 end function escan_data_get_n_par @ %def escan_data_get_n_par @ Return the outgoing particles PDG codes. This is always the same as the incoming particle, where we use two indices for the two beams. <>= procedure :: get_pdg_out => escan_data_get_pdg_out <>= subroutine escan_data_get_pdg_out (data, pdg_out) class(escan_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%flv_in(1:data%n_flv(i),i)%get_pdg () end do end subroutine escan_data_get_pdg_out @ %def escan_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => escan_data_allocate_sf_int <>= subroutine escan_data_allocate_sf_int (data, sf_int) class(escan_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (escan_t :: sf_int) end subroutine escan_data_allocate_sf_int @ %def escan_data_allocate_sf_int @ \subsection{The Energy-scan object} This is a spectrum, not a radiation. We create an interaction with two incoming and two outgoing particles, flavor, color, and helicity being carried through. $x$ nevertheless is only one-dimensional, as we are always using only one beam parameter. <>= type, extends (sf_int_t) :: escan_t type(escan_data_t), pointer :: data => null () contains <> end type escan_t @ %def escan_t @ Type string: for the energy scan this is just a dummy function. <>= procedure :: type_string => escan_type_string <>= function escan_type_string (object) result (string) class(escan_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "Escan: energy scan" else string = "Escan: [undefined]" end if end function escan_type_string @ %def escan_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => escan_write <>= subroutine escan_write (object, unit, testflag) class(escan_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "Energy scan data: [undefined]" end if end subroutine escan_write @ %def escan_write @ <>= procedure :: init => escan_init <>= subroutine escan_init (sf_int, data) class(escan_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(4) :: mask integer, dimension(4) :: hel_lock real(default), dimension(2) :: m2 real(default), dimension(0) :: mr2 type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn type(polarization_t), target :: pol1, pol2 type(polarization_iterator_t) :: it_hel1, it_hel2 integer :: j1, j2 select type (data) type is (escan_data_t) hel_lock = [3, 4, 1, 2] m2 = data%flv_in(1,:)%get_mass () call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock) sf_int%data => data do j1 = 1, data%n_flv(1) call qn_fc(1)%init ( & flv = data%flv_in(j1,1), & col = color_from_flavor (data%flv_in(j1,1))) call qn_fc(3)%init ( & flv = data%flv_in(j1,1), & col = color_from_flavor (data%flv_in(j1,1))) call pol1%init_generic (data%flv_in(j1,1)) do j2 = 1, data%n_flv(2) call qn_fc(2)%init ( & flv = data%flv_in(j2,2), & col = color_from_flavor (data%flv_in(j2,2))) call qn_fc(4)%init ( & flv = data%flv_in(j2,2), & col = color_from_flavor (data%flv_in(j2,2))) call pol2%init_generic (data%flv_in(j2,2)) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel(1) = it_hel1%get_quantum_numbers () qn_hel(3) = it_hel1%get_quantum_numbers () call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel(2) = it_hel2%get_quantum_numbers () qn_hel(4) = it_hel2%get_quantum_numbers () qn = qn_hel .merge. qn_fc call sf_int%add_state (qn) call it_hel2%advance () end do call it_hel1%advance () end do ! call pol2%final () end do ! call pol1%final () end do call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%freeze () sf_int%status = SF_INITIAL end select end subroutine escan_init @ %def escan_init @ \subsection{Kinematics} Set kinematics. We have a single parameter, but reduce both beams. The [[map]] flag is ignored. <>= procedure :: complete_kinematics => escan_complete_kinematics <>= subroutine escan_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default) :: sqrt_x real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map x = r xb= rb sqrt_x = sqrt (x(1)) if (sqrt_x > 0) then f = 1 / (2 * sqrt_x) else f = 0 sf_int%status = SF_FAILED_KINEMATICS return end if call sf_int%reduce_momenta ([sqrt_x, sqrt_x]) end subroutine escan_complete_kinematics @ %def escan_complete_kinematics @ Recover $x$. The base procedure should return two momentum fractions for the two beams, while we have only one parameter. This is the product of the extracted momentum fractions. <>= procedure :: recover_x => escan_recover_x <>= subroutine escan_recover_x (sf_int, x, xb, x_free) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free real(default), dimension(2) :: xi, xib call sf_int%base_recover_x (xi, xib, x_free) x = product (xi) xb= 1 - x end subroutine escan_recover_x @ %def escan_recover_x @ Compute inverse kinematics. <>= procedure :: inverse_kinematics => escan_inverse_kinematics <>= subroutine escan_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(escan_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta real(default) :: sqrt_x logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta sqrt_x = sqrt (x(1)) if (sqrt_x > 0) then f = 1 / (2 * sqrt_x) else f = 0 sf_int%status = SF_FAILED_KINEMATICS return end if r = x rb = xb if (set_mom) then call sf_int%reduce_momenta ([sqrt_x, sqrt_x]) end if end subroutine escan_inverse_kinematics @ %def escan_inverse_kinematics @ \subsection{Energy scan application} Here, we insert the predefined norm. <>= procedure :: apply => escan_apply <>= subroutine escan_apply (sf_int, scale, rescale, i_sub) class(escan_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f associate (data => sf_int%data) f = data%norm end associate call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine escan_apply @ %def escan_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_escan_ut.f90]]>>= <> module sf_escan_ut use unit_tests use sf_escan_uti <> <> contains <> end module sf_escan_ut @ %def sf_escan_ut @ <<[[sf_escan_uti.f90]]>>= <> module sf_escan_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_aux use sf_base use sf_escan <> <> contains <> end module sf_escan_uti @ %def sf_escan_ut @ API: driver for the unit tests below. <>= public :: sf_escan_test <>= subroutine sf_escan_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_escan_test @ %def sf_escan_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_escan_1, "sf_escan_1", & "structure function configuration", & u, results) <>= public :: sf_escan_1 <>= subroutine sf_escan_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_escan_1" write (u, "(A)") "* Purpose: initialize and display & &energy-scan structure function data" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (escan_data_t :: data) select type (data) type is (escan_data_t) call data%init (model, pdg_in, norm = 2._default) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_escan_1" end subroutine sf_escan_1 @ %def sf_escan_1 g@ \subsubsection{Probe the structure-function object} Active the beam event reader, generate an event. <>= call test (sf_escan_2, "sf_escan_2", & "generate event", & u, results) <>= public :: sf_escan_2 <>= subroutine sf_escan_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: x_free, f write (u, "(A)") "* Test output: sf_escan_2" write (u, "(A)") "* Purpose: initialize and display & &beam-events structure function data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (escan_data_t :: data) select type (data) type is (escan_data_t) call data%init (model, pdg_in) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set dummy parameters and generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0.8 rb = 1 - r x_free = 1 call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Inverse kinematics" write (u, "(A)") call sf_int%recover_x (x, xb, x_free) call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_escan_2" end subroutine sf_escan_2 @ %def sf_escan_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Gaussian beam spread} Instead of an analytic beam description, beam data may be provided in form of an event file. In its most simple form, the event file contains pairs of $x$ values, relative to nominal beam energies. More advanced formats may include polarization, etc. The current implementation carries beam polarization through, if specified. The code is very similar to the energy scan described above. However, we must include a file-handle manager for the beam-event files. Two different processes may access a given beam-event file at the same time (i.e., serially but alternating). Accessing an open file from two different units is non-standard and not supported by all compilers. Therefore, we keep a global registry of open files, associated units, and reference counts. The [[gaussian_t]] objects act as proxies to this registry. <<[[sf_gaussian.f90]]>>= <> module sf_gaussian <> <> use io_units use format_defs, only: FMT_12 use file_registries use diagnostics use lorentz use rng_base use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use sf_base <> <> <> contains <> end module sf_gaussian @ %def sf_gaussian @ \subsection{The beam-data file registry} We manage data files via the [[file_registries]] module. To this end, we keep the registry as a private module variable here. <>= type(file_registry_t), save :: beam_file_registry @ %def beam_file_registry @ \subsection{Data type} We store the spread for each beam, as a relative number related to the beam energy. For the actual generation, we include an (abstract) random-number generator factory. <>= public :: gaussian_data_t <>= type, extends(sf_data_t) :: gaussian_data_t private type(flavor_t), dimension(2) :: flv_in real(default), dimension(2) :: spread class(rng_factory_t), allocatable :: rng_factory contains <> end type gaussian_data_t @ %def gaussian_data_t <>= procedure :: init => gaussian_data_init <>= subroutine gaussian_data_init (data, model, pdg_in, spread, rng_factory) class(gaussian_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), dimension(2), intent(in) :: spread class(rng_factory_t), intent(inout), allocatable :: rng_factory if (any (spread < 0)) then call msg_fatal ("Gaussian beam spread: must not be negative") end if call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model) call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model) data%spread = spread call move_alloc (from = rng_factory, to = data%rng_factory) end subroutine gaussian_data_init @ %def gaussian_data_init @ Return true since this spectrum is always in generator mode. <>= procedure :: is_generator => gaussian_data_is_generator <>= function gaussian_data_is_generator (data) result (flag) class(gaussian_data_t), intent(in) :: data logical :: flag flag = .true. end function gaussian_data_is_generator @ %def gaussian_data_is_generator @ The number of parameters is two. They are free parameters. <>= procedure :: get_n_par => gaussian_data_get_n_par <>= function gaussian_data_get_n_par (data) result (n) class(gaussian_data_t), intent(in) :: data integer :: n n = 2 end function gaussian_data_get_n_par @ %def gaussian_data_get_n_par <>= procedure :: get_pdg_out => gaussian_data_get_pdg_out <>= subroutine gaussian_data_get_pdg_out (data, pdg_out) class(gaussian_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%flv_in(i)%get_pdg () end do end subroutine gaussian_data_get_pdg_out @ %def gaussian_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => gaussian_data_allocate_sf_int <>= subroutine gaussian_data_allocate_sf_int (data, sf_int) class(gaussian_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (gaussian_t :: sf_int) end subroutine gaussian_data_allocate_sf_int @ %def gaussian_data_allocate_sf_int @ Output <>= procedure :: write => gaussian_data_write <>= subroutine gaussian_data_write (data, unit, verbose) class(gaussian_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Gaussian beam spread data:" write (u, "(3x,A,A,A,A)") "prt_in = ", & char (data%flv_in(1)%get_name ()), & ", ", char (data%flv_in(2)%get_name ()) write (u, "(3x,A,2(1x," // FMT_12 // "))") "spread =", data%spread call data%rng_factory%write (u) end subroutine gaussian_data_write @ %def gaussian_data_write @ \subsection{The gaussian object} Flavor and polarization carried through, no radiated particles. The generator needs a random-number generator, obviously. <>= public :: gaussian_t <>= type, extends (sf_int_t) :: gaussian_t type(gaussian_data_t), pointer :: data => null () class(rng_t), allocatable :: rng contains <> end type gaussian_t @ %def gaussian_t @ Type string: show gaussian file. <>= procedure :: type_string => gaussian_type_string <>= function gaussian_type_string (object) result (string) class(gaussian_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "Gaussian: gaussian beam-energy spread" else string = "Gaussian: [undefined]" end if end function gaussian_type_string @ %def gaussian_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => gaussian_write <>= subroutine gaussian_write (object, unit, testflag) class(gaussian_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%rng%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "gaussian data: [undefined]" end if end subroutine gaussian_write @ %def gaussian_write @ <>= procedure :: init => gaussian_init <>= subroutine gaussian_init (sf_int, data) class(gaussian_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data real(default), dimension(2) :: m2 real(default), dimension(0) :: mr2 type(quantum_numbers_mask_t), dimension(4) :: mask integer, dimension(4) :: hel_lock type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn type(polarization_t), target :: pol1, pol2 type(polarization_iterator_t) :: it_hel1, it_hel2 integer :: i select type (data) type is (gaussian_data_t) m2 = data%flv_in%get_mass () ** 2 hel_lock = [3, 4, 1, 2] mask = quantum_numbers_mask (.false., .false., .false.) call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock) sf_int%data => data do i = 1, 2 call qn_fc(i)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) call qn_fc(i+2)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) end do call pol1%init_generic (data%flv_in(1)) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel(1) = it_hel1%get_quantum_numbers () qn_hel(3) = it_hel1%get_quantum_numbers () call pol2%init_generic (data%flv_in(2)) call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel(2) = it_hel2%get_quantum_numbers () qn_hel(4) = it_hel2%get_quantum_numbers () qn = qn_hel .merge. qn_fc call sf_int%add_state (qn) call it_hel2%advance () end do ! call pol2%final () call it_hel1%advance () end do ! call pol1%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) sf_int%status = SF_INITIAL end select call sf_int%data%rng_factory%make (sf_int%rng) end subroutine gaussian_init @ %def gaussian_init @ This spectrum type needs a finalizer, which closes the data file. <>= procedure :: final => sf_gaussian_final <>= subroutine sf_gaussian_final (object) class(gaussian_t), intent(inout) :: object call object%interaction_t%final () end subroutine sf_gaussian_final @ %def sf_gaussian_final @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => gaussian_is_generator <>= function gaussian_is_generator (sf_int) result (flag) class(gaussian_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function gaussian_is_generator @ %def gaussian_is_generator @ Generate free parameters. The $x$ value should be distributed with mean $1$ and $\sigma$ given by the spread. We reject negative $x$ values. (This cut slightly biases the distribution, but for reasonable (small) spreads negative $r$ should not occur. <>= procedure :: generate_free => gaussian_generate_free <>= subroutine gaussian_generate_free (sf_int, r, rb, x_free) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free real(default), dimension(size(r)) :: z associate (data => sf_int%data) do call sf_int%rng%generate_gaussian (z) rb = z * data%spread r = 1 - rb x_free = x_free * product (r) if (all (r > 0)) exit end do end associate end subroutine gaussian_generate_free @ %def gaussian_generate_free @ Set kinematics. Trivial transfer since this is a pure generator. The [[map]] flag doesn't apply. <>= procedure :: complete_kinematics => gaussian_complete_kinematics <>= subroutine gaussian_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("gaussian: map flag not supported") else x = r xb= rb f = 1 end if call sf_int%reduce_momenta (x) end subroutine gaussian_complete_kinematics @ %def gaussian_complete_kinematics @ Compute inverse kinematics. Trivial in this case. <>= procedure :: inverse_kinematics => gaussian_inverse_kinematics <>= subroutine gaussian_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(gaussian_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("gaussian: map flag not supported") else r = x rb= xb f = 1 end if if (set_mom) then call sf_int%reduce_momenta (x) end if end subroutine gaussian_inverse_kinematics @ %def gaussian_inverse_kinematics @ \subsection{gaussian application} Trivial, just set the unit weight. <>= procedure :: apply => gaussian_apply <>= subroutine gaussian_apply (sf_int, scale, rescale, i_sub) class(gaussian_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f f = 1 call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine gaussian_apply @ %def gaussian_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_gaussian_ut.f90]]>>= <> module sf_gaussian_ut use unit_tests use sf_gaussian_uti <> <> contains <> end module sf_gaussian_ut @ %def sf_gaussian_ut @ <<[[sf_gaussian_uti.f90]]>>= <> module sf_gaussian_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use rng_base use sf_aux use sf_base use sf_gaussian use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module sf_gaussian_uti @ %def sf_gaussian_ut @ API: driver for the unit tests below. <>= public :: sf_gaussian_test <>= subroutine sf_gaussian_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_gaussian_test @ %def sf_gaussian_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_gaussian_1, "sf_gaussian_1", & "structure function configuration", & u, results) <>= public :: sf_gaussian_1 <>= subroutine sf_gaussian_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data class(rng_factory_t), allocatable :: rng_factory write (u, "(A)") "* Test output: sf_gaussian_1" write (u, "(A)") "* Purpose: initialize and display & &gaussian-spread structure function data" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (gaussian_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (gaussian_data_t) call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_gaussian_1" end subroutine sf_gaussian_1 @ %def sf_gaussian_1 @ \subsubsection{Probe the structure-function object} Active the beam event reader, generate an event. <>= call test (sf_gaussian_2, "sf_gaussian_2", & "generate event", & u, results) <>= public :: sf_gaussian_2 <>= subroutine sf_gaussian_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: x_free, f integer :: i write (u, "(A)") "* Test output: sf_gaussian_2" write (u, "(A)") "* Purpose: initialize and display & &gaussian-spread structure function data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (gaussian_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (gaussian_data_t) call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set dummy parameters and generate x." write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call pacify (rb, 1.e-8_default) call pacify (xb, 1.e-8_default) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Generate more events" write (u, "(A)") select type (sf_int) type is (gaussian_t) do i = 1, 3 call sf_int%generate_free (r, rb, x_free) write (u, "(A,9(1x,F10.7))") "r =", r end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_gaussian_2" end subroutine sf_gaussian_2 @ %def sf_gaussian_2 @ \clearpage @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Using beam event data} Instead of an analytic beam description, beam data may be provided in form of an event file. In its most simple form, the event file contains pairs of $x$ values, relative to nominal beam energies. More advanced formats may include polarization, etc. The current implementation carries beam polarization through, if specified. The code is very similar to the energy scan described above. However, we must include a file-handle manager for the beam-event files. Two different processes may access a given beam-event file at the same time (i.e., serially but alternating). Accessing an open file from two different units is non-standard and not supported by all compilers. Therefore, we keep a global registry of open files, associated units, and reference counts. The [[beam_events_t]] objects act as proxies to this registry. <<[[sf_beam_events.f90]]>>= <> module sf_beam_events <> <> use io_units use file_registries use diagnostics use lorentz use pdg_arrays use model_data use flavors use quantum_numbers use state_matrices use polarizations use sf_base <> <> <> <> contains <> end module sf_beam_events @ %def sf_beam_events @ \subsection{The beam-data file registry} We manage data files via the [[file_registries]] module. To this end, we keep the registry as a private module variable here. This is public only for the unit tests. <>= public :: beam_file_registry <>= type(file_registry_t), save :: beam_file_registry @ %def beam_file_registry @ \subsection{Data type} <>= public :: beam_events_data_t <>= type, extends(sf_data_t) :: beam_events_data_t private type(flavor_t), dimension(2) :: flv_in type(string_t) :: dir type(string_t) :: file type(string_t) :: fqn integer :: unit = 0 logical :: warn_eof = .true. contains <> end type beam_events_data_t @ %def beam_events_data_t <>= procedure :: init => beam_events_data_init <>= subroutine beam_events_data_init (data, model, pdg_in, dir, file, warn_eof) class(beam_events_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in type(string_t), intent(in) :: dir type(string_t), intent(in) :: file logical, intent(in), optional :: warn_eof if (any (pdg_array_get_length (pdg_in) /= 1)) then call msg_fatal ("Beam events: incoming beam particles must be unique") end if call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model) call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model) data%dir = dir data%file = file if (present (warn_eof)) data%warn_eof = warn_eof end subroutine beam_events_data_init @ %def beam_events_data_init @ Return true since this spectrum is always in generator mode. <>= procedure :: is_generator => beam_events_data_is_generator <>= function beam_events_data_is_generator (data) result (flag) class(beam_events_data_t), intent(in) :: data logical :: flag flag = .true. end function beam_events_data_is_generator @ %def beam_events_data_is_generator @ The number of parameters is two. They are free parameters. <>= procedure :: get_n_par => beam_events_data_get_n_par <>= function beam_events_data_get_n_par (data) result (n) class(beam_events_data_t), intent(in) :: data integer :: n n = 2 end function beam_events_data_get_n_par @ %def beam_events_data_get_n_par <>= procedure :: get_pdg_out => beam_events_data_get_pdg_out <>= subroutine beam_events_data_get_pdg_out (data, pdg_out) class(beam_events_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer :: i, n n = 2 do i = 1, n pdg_out(i) = data%flv_in(i)%get_pdg () end do end subroutine beam_events_data_get_pdg_out @ %def beam_events_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => beam_events_data_allocate_sf_int <>= subroutine beam_events_data_allocate_sf_int (data, sf_int) class(beam_events_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (beam_events_t :: sf_int) end subroutine beam_events_data_allocate_sf_int @ %def beam_events_data_allocate_sf_int @ Output <>= procedure :: write => beam_events_data_write <>= subroutine beam_events_data_write (data, unit, verbose) class(beam_events_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Beam-event file data:" write (u, "(3x,A,A,A,A)") "prt_in = ", & char (data%flv_in(1)%get_name ()), & ", ", char (data%flv_in(2)%get_name ()) write (u, "(3x,A,A,A)") "file = '", char (data%file), "'" write (u, "(3x,A,I0)") "unit = ", data%unit write (u, "(3x,A,L1)") "warn = ", data%warn_eof end subroutine beam_events_data_write @ %def beam_events_data_write @ The data file needs to be opened and closed explicitly. The open/close message is communicated to the file handle registry, which does the actual work. We determine first whether to look in the local directory or in the given system directory. <>= procedure :: open => beam_events_data_open procedure :: close => beam_events_data_close <>= subroutine beam_events_data_open (data) class(beam_events_data_t), intent(inout) :: data logical :: exist if (data%unit == 0) then data%fqn = data%file if (data%fqn == "") & call msg_fatal ("Beam events: $beam_events_file is not set") inquire (file = char (data%fqn), exist = exist) if (.not. exist) then data%fqn = data%dir // "/" // data%file inquire (file = char (data%fqn), exist = exist) if (.not. exist) then data%fqn = "" call msg_fatal ("Beam events: file '" & // char (data%file) // "' not found") return end if end if call msg_message ("Beam events: reading from file '" & // char (data%file) // "'") call beam_file_registry%open (data%fqn, data%unit) else call msg_bug ("Beam events: file '" & // char (data%file) // "' is already open") end if end subroutine beam_events_data_open subroutine beam_events_data_close (data) class(beam_events_data_t), intent(inout) :: data if (data%unit /= 0) then call beam_file_registry%close (data%fqn) call msg_message ("Beam events: closed file '" & // char (data%file) // "'") data%unit = 0 end if end subroutine beam_events_data_close @ %def beam_events_data_close @ Return the beam event file. <>= procedure :: get_beam_file => beam_events_data_get_beam_file <>= function beam_events_data_get_beam_file (data) result (file) class(beam_events_data_t), intent(in) :: data type(string_t) :: file file = "Beam events: " // data%file end function beam_events_data_get_beam_file @ %def beam_events_data_get_beam_file @ \subsection{The beam events object} Flavor and polarization carried through, no radiated particles. <>= public :: beam_events_t <>= type, extends (sf_int_t) :: beam_events_t type(beam_events_data_t), pointer :: data => null () integer :: count = 0 contains <> end type beam_events_t @ %def beam_events_t @ Type string: show beam events file. <>= procedure :: type_string => beam_events_type_string <>= function beam_events_type_string (object) result (string) class(beam_events_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "Beam events: " // object%data%file else string = "Beam events: [undefined]" end if end function beam_events_type_string @ %def beam_events_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => beam_events_write <>= subroutine beam_events_write (object, unit, testflag) class(beam_events_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) call object%base_write (u, testflag) else write (u, "(1x,A)") "Beam events data: [undefined]" end if end subroutine beam_events_write @ %def beam_events_write @ <>= procedure :: init => beam_events_init <>= subroutine beam_events_init (sf_int, data) class(beam_events_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data real(default), dimension(2) :: m2 real(default), dimension(0) :: mr2 type(quantum_numbers_mask_t), dimension(4) :: mask integer, dimension(4) :: hel_lock type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn type(polarization_t), target :: pol1, pol2 type(polarization_iterator_t) :: it_hel1, it_hel2 integer :: i select type (data) type is (beam_events_data_t) m2 = data%flv_in%get_mass () ** 2 hel_lock = [3, 4, 1, 2] mask = quantum_numbers_mask (.false., .false., .false.) call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock) sf_int%data => data do i = 1, 2 call qn_fc(i)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) call qn_fc(i+2)%init ( & flv = data%flv_in(i), & col = color_from_flavor (data%flv_in(i))) end do call pol1%init_generic (data%flv_in(1)) call it_hel1%init (pol1) do while (it_hel1%is_valid ()) qn_hel(1) = it_hel1%get_quantum_numbers () qn_hel(3) = it_hel1%get_quantum_numbers () call pol2%init_generic (data%flv_in(2)) call it_hel2%init (pol2) do while (it_hel2%is_valid ()) qn_hel(2) = it_hel2%get_quantum_numbers () qn_hel(4) = it_hel2%get_quantum_numbers () qn = qn_hel .merge. qn_fc call sf_int%add_state (qn) call it_hel2%advance () end do ! call pol2%final () call it_hel1%advance () end do ! call pol1%final () call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%data%open () sf_int%status = SF_INITIAL end select end subroutine beam_events_init @ %def beam_events_init @ This spectrum type needs a finalizer, which closes the data file. <>= procedure :: final => sf_beam_events_final <>= subroutine sf_beam_events_final (object) class(beam_events_t), intent(inout) :: object call object%data%close () call object%interaction_t%final () end subroutine sf_beam_events_final @ %def sf_beam_events_final @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => beam_events_is_generator <>= function beam_events_is_generator (sf_int) result (flag) class(beam_events_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function beam_events_is_generator @ %def beam_events_is_generator @ Generate free parameters. We read them from file. <>= procedure :: generate_free => beam_events_generate_free <>= recursive subroutine beam_events_generate_free (sf_int, r, rb, x_free) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free integer :: iostat associate (data => sf_int%data) if (data%unit /= 0) then read (data%unit, fmt=*, iostat=iostat) r if (iostat > 0) then write (msg_buffer, "(A,I0,A)") & "Beam events: I/O error after reading ", sf_int%count, & " events" call msg_fatal () else if (iostat < 0) then if (sf_int%count == 0) then call msg_fatal ("Beam events: file is empty") else if (sf_int%data%warn_eof) then write (msg_buffer, "(A,I0,A)") & "Beam events: End of file after reading ", sf_int%count, & " events, rewinding" call msg_warning () end if rewind (data%unit) sf_int%count = 0 call sf_int%generate_free (r, rb, x_free) else sf_int%count = sf_int%count + 1 rb = 1 - r x_free = x_free * product (r) end if else call msg_bug ("Beam events: file is not open for reading") end if end associate end subroutine beam_events_generate_free @ %def beam_events_generate_free @ Set kinematics. Trivial transfer since this is a pure generator. The [[map]] flag doesn't apply. <>= procedure :: complete_kinematics => beam_events_complete_kinematics <>= subroutine beam_events_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("Beam events: map flag not supported") else x = r xb= rb f = 1 end if call sf_int%reduce_momenta (x) end subroutine beam_events_complete_kinematics @ %def beam_events_complete_kinematics @ Compute inverse kinematics. Trivial in this case. <>= procedure :: inverse_kinematics => beam_events_inverse_kinematics <>= subroutine beam_events_inverse_kinematics & (sf_int, x, xb, f, r, rb, map, set_momenta) class(beam_events_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("Beam events: map flag not supported") else r = x rb= xb f = 1 end if if (set_mom) then call sf_int%reduce_momenta (x) end if end subroutine beam_events_inverse_kinematics @ %def beam_events_inverse_kinematics @ \subsection{Beam events application} Trivial, just set the unit weight. <>= procedure :: apply => beam_events_apply <>= subroutine beam_events_apply (sf_int, scale, rescale, i_sub) class(beam_events_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default) :: f f = 1 call sf_int%set_matrix_element (cmplx (f, kind=default)) sf_int%status = SF_EVALUATED end subroutine beam_events_apply @ %def beam_events_apply @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_beam_events_ut.f90]]>>= <> module sf_beam_events_ut use unit_tests use sf_beam_events_uti <> <> contains <> end module sf_beam_events_ut @ %def sf_beam_events_ut @ <<[[sf_beam_events_uti.f90]]>>= <> module sf_beam_events_uti <> <> use io_units use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use sf_aux use sf_base use sf_beam_events <> <> contains <> end module sf_beam_events_uti @ %def sf_beam_events_ut @ API: driver for the unit tests below. <>= public :: sf_beam_events_test <>= subroutine sf_beam_events_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_beam_events_test @ %def sf_beam_events_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_beam_events_1, "sf_beam_events_1", & "structure function configuration", & u, results) <>= public :: sf_beam_events_1 <>= subroutine sf_beam_events_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_beam_events_1" write (u, "(A)") "* Purpose: initialize and display & &beam-events structure function data" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (beam_events_data_t :: data) select type (data) type is (beam_events_data_t) call data%init (model, pdg_in, var_str (""), var_str ("beam_events.dat")) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_beam_events_1" end subroutine sf_beam_events_1 @ %def sf_beam_events_1 @ \subsubsection{Probe the structure-function object} Active the beam event reader, generate an event. <>= call test (sf_beam_events_2, "sf_beam_events_2", & "generate event", & u, results) <>= public :: sf_beam_events_2 <>= subroutine sf_beam_events_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: x_free, f integer :: i write (u, "(A)") "* Test output: sf_beam_events_2" write (u, "(A)") "* Purpose: initialize and display & &beam-events structure function data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (beam_events_data_t :: data) select type (data) type is (beam_events_data_t) call data%init (model, pdg_in, & var_str (""), var_str ("test_beam_events.dat")) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set dummy parameters and generate x." write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,9(1x,F10.7))") "rb=", rb write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free select type (sf_int) type is (beam_events_t) write (u, "(A,1x,I0)") "count =", sf_int%count end select write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Generate more events, rewind" write (u, "(A)") select type (sf_int) type is (beam_events_t) do i = 1, 3 call sf_int%generate_free (r, rb, x_free) write (u, "(A,9(1x,F10.7))") "r =", r write (u, "(A,1x,I0)") "count =", sf_int%count end do end select write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_beam_events_2" end subroutine sf_beam_events_2 @ %def sf_beam_events_2 @ \subsubsection{Check the file handle registry} Open and close some files, checking the registry contents. <>= call test (sf_beam_events_3, "sf_beam_events_3", & "check registry", & u, results) <>= public :: sf_beam_events_3 <>= subroutine sf_beam_events_3 (u) integer, intent(in) :: u integer :: u1 write (u, "(A)") "* Test output: sf_beam_events_2" write (u, "(A)") "* Purpose: check file handle registry" write (u, "(A)") write (u, "(A)") "* Create some empty files" write (u, "(A)") u1 = free_unit () open (u1, file = "sf_beam_events_f1.tmp", action="write", status="new") close (u1) open (u1, file = "sf_beam_events_f2.tmp", action="write", status="new") close (u1) open (u1, file = "sf_beam_events_f3.tmp", action="write", status="new") close (u1) write (u, "(A)") "* Empty registry" write (u, "(A)") call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Insert three entries" write (u, "(A)") call beam_file_registry%open (var_str ("sf_beam_events_f3.tmp")) call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%open (var_str ("sf_beam_events_f1.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Open a second channel" write (u, "(A)") call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Close second entry twice" write (u, "(A)") call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Close last entry" write (u, "(A)") call beam_file_registry%close (var_str ("sf_beam_events_f3.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Close remaining entry" write (u, "(A)") call beam_file_registry%close (var_str ("sf_beam_events_f1.tmp")) call beam_file_registry%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" open (u1, file = "sf_beam_events_f1.tmp", action="write") close (u1, status = "delete") open (u1, file = "sf_beam_events_f2.tmp", action="write") close (u1, status = "delete") open (u1, file = "sf_beam_events_f3.tmp", action="write") close (u1, status = "delete") write (u, "(A)") write (u, "(A)") "* Test output end: sf_beam_events_3" end subroutine sf_beam_events_3 @ %def sf_beam_events_3 @ \clearpage %------------------------------------------------------------------------ \section{Lepton collider beamstrahlung: CIRCE1} <<[[sf_circe1.f90]]>>= <> module sf_circe1 <> use kinds, only: double <> use io_units use format_defs, only: FMT_17, FMT_19 use diagnostics use physics_defs, only: ELECTRON, PHOTON use lorentz use rng_base use pdg_arrays use model_data use flavors use colors use quantum_numbers use state_matrices use polarizations use sf_mappings use sf_base use circe1, circe1_rng_t => rng_type !NODEP! <> <> <> contains <> end module sf_circe1 @ %def sf_circe1 @ \subsection{Physics} Beamstrahlung is applied before ISR. The [[CIRCE1]] implementation has a single structure function for both beams (which makes sense since it has to be switched on or off for both beams simultaneously). Nevertheless it is factorized: The functional form in the [[CIRCE1]] parameterization is defined for electrons or photons \begin{equation} f(x) = \alpha\,x^\beta\,(1-x)^\gamma \end{equation} for $x<1-\epsilon$ (resp.\ $x>\epsilon$ in the photon case). In the remaining interval, the standard form is zero, with a delta singularity at $x=1$ (resp.\ $x=0$). Equivalently, the delta part may be distributed uniformly among this interval. This latter form is implemented in the [[kirke]] version of the [[CIRCE1]] subroutines, and is used here. The parameter [[circe1\_eps]] sets the peak mapping of the [[CIRCE1]] structure function. Its default value is $10^{-5}$. The other parameters are the parameterization version and revision number, the accelerator type, and the $\sqrt{s}$ value used by [[CIRCE1]]. The chattiness can also be set. Since the energy is distributed in a narrow region around unity (for electrons) or zero (for photons), it is advantageous to map the interval first. The mapping is controlled by the parameter [[circe1\_epsilon]] which is taken from the [[CIRCE1]] internal data structure. The $\sqrt{s}$ value, if not explicitly set, is taken from the process data. Note that interpolating $\sqrt{s}$ is not recommended; one should rather choose one of the distinct values known to [[CIRCE1]]. \subsection{The CIRCE1 data block} The CIRCE1 parameters are: The incoming flavors, the flags whether the photon or the lepton is the parton in the hard interaction, the flags for the generation mode (generator/mapping/no mapping), the mapping parameter $\epsilon$, $\sqrt{s}$ and several steering parameters: [[ver]], [[rev]], [[acc]], [[chat]]. In generator mode, the $x$ values are actually discarded and a random number generator is used instead. <>= public :: circe1_data_t <>= type, extends (sf_data_t) :: circe1_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(2) :: flv_in integer, dimension(2) :: pdg_in real(default), dimension(2) :: m_in = 0 logical, dimension(2) :: photon = .false. logical :: generate = .false. class(rng_factory_t), allocatable :: rng_factory real(default) :: sqrts = 0 real(default) :: eps = 0 integer :: ver = 0 integer :: rev = 0 character(6) :: acc = "?" integer :: chat = 0 logical :: with_radiation = .false. contains <> end type circe1_data_t @ %def circe1_data_t @ <>= procedure :: init => circe1_data_init <>= subroutine circe1_data_init & (data, model, pdg_in, sqrts, eps, out_photon, & ver, rev, acc, chat, with_radiation) class(circe1_data_t), intent(out) :: data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in) :: sqrts real(default), intent(in) :: eps logical, dimension(2), intent(in) :: out_photon character(*), intent(in) :: acc integer, intent(in) :: ver, rev, chat logical, intent(in) :: with_radiation data%model => model if (any (pdg_array_get_length (pdg_in) /= 1)) then call msg_fatal ("CIRCE1: incoming beam particles must be unique") end if call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model) call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model) data%pdg_in = data%flv_in%get_pdg () data%m_in = data%flv_in%get_mass () data%sqrts = sqrts data%eps = eps data%photon = out_photon data%ver = ver data%rev = rev data%acc = acc data%chat = chat data%with_radiation = with_radiation call data%check () call circex (0.d0, 0.d0, dble (data%sqrts), & data%acc, data%ver, data%rev, data%chat) end subroutine circe1_data_init @ %def circe1_data_init @ Activate the generator mode. We import a RNG factory into the data type, which can then spawn RNG generator objects. <>= procedure :: set_generator_mode => circe1_data_set_generator_mode <>= subroutine circe1_data_set_generator_mode (data, rng_factory) class(circe1_data_t), intent(inout) :: data class(rng_factory_t), intent(inout), allocatable :: rng_factory data%generate = .true. call move_alloc (from = rng_factory, to = data%rng_factory) end subroutine circe1_data_set_generator_mode @ %def circe1_data_set_generator_mode @ Handle error conditions. <>= procedure :: check => circe1_data_check <>= subroutine circe1_data_check (data) class(circe1_data_t), intent(in) :: data type(flavor_t) :: flv_electron, flv_photon call flv_electron%init (ELECTRON, data%model) call flv_photon%init (PHOTON, data%model) if (.not. flv_electron%is_defined () & .or. .not. flv_photon%is_defined ()) then call msg_fatal ("CIRCE1: model must contain photon and electron") end if if (any (abs (data%pdg_in) /= ELECTRON) & .or. (data%pdg_in(1) /= - data%pdg_in(2))) then call msg_fatal ("CIRCE1: applicable only for e+e- or e-e+ collisions") end if if (data%eps <= 0) then call msg_error ("CIRCE1: circe1_eps = 0: integration will & &miss x=1 peak") end if end subroutine circe1_data_check @ %def circe1_data_check @ Output <>= procedure :: write => circe1_data_write <>= subroutine circe1_data_write (data, unit, verbose) class(circe1_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u + 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) call data%rng_factory%write (u) + 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, rescale, i_sub) class(circe1_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub real(default), dimension(2) :: xb real(double), dimension(2) :: xc real(double), parameter :: one = 1 associate (data => sf_int%data) xc = sf_int%x xb = sf_int%xb if (data%generate) then sf_int%f = 1 else sf_int%f = 0 if (all (sf_int%continuum)) then sf_int%f = circe (xc(1), xc(2), data%pdg_in(1), data%pdg_in(2)) end if if (sf_int%continuum(2) .and. sf_int%peak(1)) then sf_int%f = sf_int%f & + circe (one, xc(2), data%pdg_in(1), data%pdg_in(2)) & * peak (xb(1), data%eps) end if if (sf_int%continuum(1) .and. sf_int%peak(2)) then sf_int%f = sf_int%f & + circe (xc(1), one, data%pdg_in(1), data%pdg_in(2)) & * peak (xb(2), data%eps) end if if (all (sf_int%peak)) then sf_int%f = sf_int%f & + circe (one, one, data%pdg_in(1), data%pdg_in(2)) & * peak (xb(1), data%eps) * peak (xb(2), data%eps) end if end if end associate call sf_int%set_matrix_element (cmplx (sf_int%f, kind=default)) sf_int%status = SF_EVALUATED end subroutine circe1_apply @ %def circe1_apply @ This is a smeared delta peak at zero, as an endpoint singularity. We choose an exponentially decreasing function, starting at zero, with integral (from $0$ to $1$) $1-e^{-1/\epsilon}$. For small $\epsilon$, this reduces to one. <>= function peak (x, eps) result (f) real(default), intent(in) :: x, eps real(default) :: f f = exp (-x / eps) / eps end function peak @ %def peak @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[sf_circe1_ut.f90]]>>= <> module sf_circe1_ut use unit_tests use sf_circe1_uti <> <> contains <> end module sf_circe1_ut @ %def sf_circe1_ut @ <<[[sf_circe1_uti.f90]]>>= <> module sf_circe1_uti <> use physics_defs, only: ELECTRON use lorentz use pdg_arrays use flavors use interactions, only: reset_interaction_counter use model_data use rng_base use sf_aux use sf_base use sf_circe1 use rng_base_ut, only: rng_test_factory_t <> <> contains <> end module sf_circe1_uti @ %def sf_circe1_ut @ API: driver for the unit tests below. <>= public :: sf_circe1_test <>= subroutine sf_circe1_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine sf_circe1_test @ %def sf_circe1_test @ \subsubsection{Test structure function data} Construct and display a test structure function data object. <>= call test (sf_circe1_1, "sf_circe1_1", & "structure function configuration", & u, results) <>= public :: sf_circe1_1 <>= subroutine sf_circe1_1 (u) integer, intent(in) :: u type(model_data_t), target :: model type(pdg_array_t), dimension(2) :: pdg_in type(pdg_array_t), dimension(2) :: pdg_out integer, dimension(:), allocatable :: pdg1, pdg2 class(sf_data_t), allocatable :: data write (u, "(A)") "* Test output: sf_circe1_1" write (u, "(A)") "* Purpose: initialize and display & &CIRCE structure function data" write (u, "(A)") write (u, "(A)") "* Create empty data object" write (u, "(A)") call model%init_qed_test () pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON allocate (circe1_data_t :: data) call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") select type (data) type is (circe1_data_t) call data%init (model, pdg_in, & sqrts = 500._default, & eps = 1e-6_default, & out_photon = [.false., .false.], & ver = 0, & rev = 0, & acc = "SBAND", & chat = 0, & with_radiation = .true.) end select call data%write (u) write (u, "(A)") write (u, "(1x,A)") "Outgoing particle codes:" call data%get_pdg_out (pdg_out) pdg1 = pdg_out(1) pdg2 = pdg_out(2) write (u, "(2x,99(1x,I0))") pdg1, pdg2 call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe1_1" end subroutine sf_circe1_1 @ %def sf_circe1_1 @ \subsubsection{Test and probe structure function} Construct and display a structure function object based on the PDF builtin structure function. <>= call test (sf_circe1_2, "sf_circe1_2", & "structure function instance", & u, results) <>= public :: sf_circe1_2 <>= subroutine sf_circe1_2 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 type(vector4_t), dimension(4) :: q real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f write (u, "(A)") "* Test output: sf_circe1_2" write (u, "(A)") "* Purpose: initialize and fill & &circe1 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (circe1_data_t :: data) select type (data) type is (circe1_data_t) call data%init (model, pdg_in, & sqrts = 500._default, & eps = 1e-6_default, & out_photon = [.false., .false.], & ver = 0, & rev = 0, & acc = "SBAND", & chat = 0, & with_radiation = .true.) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Set kinematics for x=0.95,0.85." write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = [0.9_default, 0.8_default] rb = 1 - r call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%write (u) write (u, "(A)") write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A)") write (u, "(A)") "* Recover x from momenta" write (u, "(A)") q = sf_int%get_momenta (outgoing=.true.) call sf_int%final () deallocate (sf_int) call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1, 2]) call sf_int%seed_kinematics ([k1, k2]) call sf_int%set_momenta (q, outgoing=.true.) call sf_int%recover_x (x, xb) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe1_2" end subroutine sf_circe1_2 @ %def sf_circe1_2 @ \subsubsection{Generator mode} Construct and evaluate a structure function object in generator mode. <>= call test (sf_circe1_3, "sf_circe1_3", & "generator mode", & u, results) <>= public :: sf_circe1_3 <>= subroutine sf_circe1_3 (u) integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(2) :: flv type(pdg_array_t), dimension(2) :: pdg_in class(sf_data_t), allocatable, target :: data class(rng_factory_t), allocatable :: rng_factory class(sf_int_t), allocatable :: sf_int type(vector4_t) :: k1, k2 real(default) :: E real(default), dimension(:), allocatable :: r, rb, x, xb real(default) :: f, x_free write (u, "(A)") "* Test output: sf_circe1_3" write (u, "(A)") "* Purpose: initialize and fill & &circe1 structure function object" write (u, "(A)") write (u, "(A)") "* Initialize configuration data" write (u, "(A)") call model%init_qed_test () call flv(1)%init (ELECTRON, model) call flv(2)%init (-ELECTRON, model) pdg_in(1) = ELECTRON pdg_in(2) = -ELECTRON call reset_interaction_counter () allocate (circe1_data_t :: data) allocate (rng_test_factory_t :: rng_factory) select type (data) type is (circe1_data_t) call data%init (model, pdg_in, & sqrts = 500._default, & eps = 1e-6_default, & out_photon = [.false., .false.], & ver = 0, & rev = 0, & acc = "SBAND", & chat = 0, & with_radiation = .true.) call data%set_generator_mode (rng_factory) end select write (u, "(A)") "* Initialize structure-function object" write (u, "(A)") call data%allocate_sf_int (sf_int) call sf_int%init (data) call sf_int%set_beam_index ([1,2]) select type (sf_int) type is (circe1_t) call sf_int%rng_obj%rng%init (3) end select write (u, "(A)") "* Initialize incoming momentum with E=500" write (u, "(A)") E = 250 k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3) k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3) call vector4_write (k1, u) call vector4_write (k2, u) call sf_int%seed_kinematics ([k1, k2]) write (u, "(A)") write (u, "(A)") "* Generate x" write (u, "(A)") allocate (r (data%get_n_par ())) allocate (rb(size (r))) allocate (x (size (r))) allocate (xb(size (r))) r = 0 rb = 0 x_free = 1 call sf_int%generate_free (r, rb, x_free) call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.) write (u, "(A,9(1x,F10.7))") "x =", x write (u, "(A,9(1x,F10.7))") "xb=", xb write (u, "(A,9(1x,F10.7))") "f =", f write (u, "(A,9(1x,F10.7))") "xf=", x_free write (u, "(A)") write (u, "(A)") "* Evaluate" write (u, "(A)") call sf_int%apply (scale = 0._default) call sf_int%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call sf_int%final () call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: sf_circe1_3" end subroutine sf_circe1_3 @ %def sf_circe1_3 @ \clearpage %------------------------------------------------------------------------ \section{Lepton Collider Beamstrahlung and Photon collider: CIRCE2} <<[[sf_circe2.f90]]>>= <> module sf_circe2 <> <> use io_units use format_defs, only: FMT_19 use numeric_utils use diagnostics use os_interface use physics_defs, only: PHOTON, ELECTRON use lorentz use rng_base use selectors use pdg_arrays use model_data use flavors use colors use helicities use quantum_numbers use state_matrices use polarizations use sf_base use circe2, circe2_rng_t => rng_type !NODEP! <> <> <> contains <> end module sf_circe2 @ %def sf_circe2 @ \subsection{Physics} [[CIRCE2]] describes photon spectra Beamstrahlung is applied before ISR. The [[CIRCE2]] implementation has a single structure function for both beams (which makes sense since it has to be switched on or off for both beams simultaneously). \subsection{The CIRCE2 data block} The CIRCE2 parameters are: file and collider specification, incoming (= outgoing) particles. The luminosity is returned by [[circe2_luminosity]]. <>= public :: circe2_data_t <>= type, extends (sf_data_t) :: circe2_data_t private class(model_data_t), pointer :: model => null () type(flavor_t), dimension(2) :: flv_in integer, dimension(2) :: pdg_in real(default) :: sqrts = 0 logical :: polarized = .false. logical :: beams_polarized = .false. class(rng_factory_t), allocatable :: rng_factory type(string_t) :: filename type(string_t) :: file type(string_t) :: design real(default) :: lumi = 0 real(default), dimension(4) :: lumi_hel_frac = 0 integer, dimension(0:4) :: h1 = [0, -1, -1, 1, 1] integer, dimension(0:4) :: h2 = [0, -1, 1,-1, 1] integer :: error = 1 contains <> end type circe2_data_t @ %def circe2_data_t <>= type(circe2_state) :: circe2_global_state @ <>= procedure :: init => circe2_data_init <>= subroutine circe2_data_init (data, os_data, model, pdg_in, & sqrts, polarized, beam_pol, file, design) class(circe2_data_t), intent(out) :: data type(os_data_t), intent(in) :: os_data class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(2), intent(in) :: pdg_in real(default), intent(in) :: sqrts logical, intent(in) :: polarized, beam_pol type(string_t), intent(in) :: file, design integer :: h data%model => model if (any (pdg_array_get_length (pdg_in) /= 1)) then call msg_fatal ("CIRCE2: incoming beam particles must be unique") end if call data%flv_in(1)%init (pdg_array_get (pdg_in(1), 1), model) call data%flv_in(2)%init (pdg_array_get (pdg_in(2), 1), model) data%pdg_in = data%flv_in%get_pdg () data%sqrts = sqrts data%polarized = polarized data%beams_polarized = beam_pol data%filename = file data%design = design call data%check_file (os_data) call circe2_load (circe2_global_state, trim (char(data%file)), & trim (char(data%design)), data%sqrts, data%error) call data%check () data%lumi = circe2_luminosity (circe2_global_state, data%pdg_in, [0, 0]) if (vanishes (data%lumi)) then call msg_fatal ("CIRCE2: luminosity vanishes for specified beams.") end if if (data%polarized) then do h = 1, 4 data%lumi_hel_frac(h) = & circe2_luminosity (circe2_global_state, data%pdg_in, & [data%h1(h), data%h2(h)]) & / data%lumi end do end if end subroutine circe2_data_init @ %def circe2_data_init @ Activate the generator mode. We import a RNG factory into the data type, which can then spawn RNG generator objects. <>= procedure :: set_generator_mode => circe2_data_set_generator_mode <>= subroutine circe2_data_set_generator_mode (data, rng_factory) class(circe2_data_t), intent(inout) :: data class(rng_factory_t), intent(inout), allocatable :: rng_factory call move_alloc (from = rng_factory, to = data%rng_factory) end subroutine circe2_data_set_generator_mode @ %def circe2_data_set_generator_mode @ Check whether the requested data file is in the system directory or in the current directory. <>= procedure :: check_file => circe2_check_file <>= subroutine circe2_check_file (data, os_data) class(circe2_data_t), intent(inout) :: data type(os_data_t), intent(in) :: os_data logical :: exist type(string_t) :: file file = data%filename if (file == "") & call msg_fatal ("CIRCE2: $circe2_file is not set") inquire (file = char (file), exist = exist) if (exist) then data%file = file else file = os_data%whizard_circe2path // "/" // data%filename inquire (file = char (file), exist = exist) if (exist) then data%file = file else call msg_fatal ("CIRCE2: data file '" // char (data%filename) & // "' not found") end if end if end subroutine circe2_check_file @ %def circe2_check_file @ Handle error conditions. <>= procedure :: check => circe2_data_check <>= subroutine circe2_data_check (data) class(circe2_data_t), intent(in) :: data type(flavor_t) :: flv_photon, flv_electron call flv_photon%init (PHOTON, data%model) if (.not. flv_photon%is_defined ()) then call msg_fatal ("CIRCE2: model must contain photon") end if call flv_electron%init (ELECTRON, data%model) if (.not. flv_electron%is_defined ()) then call msg_fatal ("CIRCE2: model must contain electron") end if if (any (abs (data%pdg_in) /= PHOTON .and. abs (data%pdg_in) /= ELECTRON)) & then call msg_fatal ("CIRCE2: applicable only for e+e- or photon collisions") end if select case (data%error) case (-1) call msg_fatal ("CIRCE2: data file not found.") case (-2) call msg_fatal ("CIRCE2: beam setup does not match data file.") case (-3) call msg_fatal ("CIRCE2: invalid format of data file.") case (-4) call msg_fatal ("CIRCE2: data file too large.") end select end subroutine circe2_data_check @ %def circe2_data_check @ Output <>= procedure :: write => circe2_data_write <>= subroutine circe2_data_write (data, unit, verbose) class(circe2_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u, h + 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 - call data%rng_factory%write (u) + 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(0) :: null_array type(quantum_numbers_mask_t), dimension(4) :: mask type(quantum_numbers_t), dimension(4) :: qn type(helicity_t) :: hel type(color_t) :: col0 integer :: h select type (data) type is (circe2_data_t) if (data%polarized .and. data%beams_polarized) then call msg_fatal ("CIRCE2: Beam polarization can't be set & &for polarized data file") else if (data%beams_polarized) then call msg_warning ("CIRCE2: User-defined beam polarization set & &for unpolarized CIRCE2 data file") end if mask_h(1:2) = .not. data%beams_polarized mask_h(3:4) = .not. (data%polarized .or. data%beams_polarized) mask = quantum_numbers_mask (.false., .false., mask_h) call sf_int%base_init (mask, [0._default, 0._default], & null_array, [0._default, 0._default]) sf_int%data => data if (data%polarized) then if (vanishes (sum (data%lumi_hel_frac)) .or. & any (data%lumi_hel_frac < 0)) then call msg_fatal ("CIRCE2: Helicity-dependent lumi " & // "fractions all vanish or", & [var_str ("are negative: Please inspect the " & // "CIRCE2 file or "), & var_str ("switch off the polarized" // & " option for CIRCE2.")]) else call sf_int%selector%init (data%lumi_hel_frac) end if end if call col0%init () if (data%beams_polarized) then do h = 1, 4 call hel%init (data%h1(h)) call qn(1)%init & (flv = data%flv_in(1), col = col0, hel = hel) call qn(3)%init & (flv = data%flv_in(1), col = col0, hel = hel) call hel%init (data%h2(h)) call qn(2)%init & (flv = data%flv_in(2), col = col0, hel = hel) call qn(4)%init & (flv = data%flv_in(2), col = col0, hel = hel) call sf_int%add_state (qn) end do else if (data%polarized) then call qn(1)%init (flv = data%flv_in(1), col = col0) call qn(2)%init (flv = data%flv_in(2), col = col0) do h = 1, 4 call hel%init (data%h1(h)) call qn(3)%init & (flv = data%flv_in(1), col = col0, hel = hel) call hel%init (data%h2(h)) call qn(4)%init & (flv = data%flv_in(2), col = col0, hel = hel) call sf_int%add_state (qn) end do else call qn(1)%init (flv = data%flv_in(1), col = col0) call qn(2)%init (flv = data%flv_in(2), col = col0) call qn(3)%init (flv = data%flv_in(1), col = col0) call qn(4)%init (flv = data%flv_in(2), col = col0) call sf_int%add_state (qn) end if call sf_int%freeze () call sf_int%set_incoming ([1,2]) call sf_int%set_outgoing ([3,4]) call sf_int%data%rng_factory%make (sf_int%rng_obj%rng) sf_int%status = SF_INITIAL end select end subroutine circe2_init @ %def circe2_init @ \subsection{Kinematics} Refer to the [[data]] component. <>= procedure :: is_generator => circe2_is_generator <>= function circe2_is_generator (sf_int) result (flag) class(circe2_t), intent(in) :: sf_int logical :: flag flag = sf_int%data%is_generator () end function circe2_is_generator @ %def circe2_is_generator @ Generate free parameters. We first select a helicity, which we have to store, then generate $x$ values for that helicity. <>= procedure :: generate_free => circe2_generate_whizard_free <>= subroutine circe2_generate_whizard_free (sf_int, r, rb, x_free) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: r, rb real(default), intent(inout) :: x_free integer :: h_sel if (sf_int%data%polarized) then call sf_int%selector%generate (sf_int%rng_obj%rng, h_sel) else h_sel = 0 end if sf_int%h_sel = h_sel call circe2_generate_whizard (r, sf_int%data%pdg_in, & [sf_int%data%h1(h_sel), sf_int%data%h2(h_sel)], & sf_int%rng_obj) rb = 1 - r x_free = x_free * product (r) end subroutine circe2_generate_whizard_free @ %def circe2_generate_whizard_free @ Generator mode: call the CIRCE2 generator for the given particles and helicities. (For unpolarized generation, helicities are zero.) <>= subroutine circe2_generate_whizard (x, pdg, hel, rng_obj) real(default), dimension(2), intent(out) :: x integer, dimension(2), intent(in) :: pdg integer, dimension(2), intent(in) :: hel class(rng_obj_t), intent(inout) :: rng_obj call circe2_generate (circe2_global_state, rng_obj, x, pdg, hel) end subroutine circe2_generate_whizard @ %def circe2_generate_whizard @ Set kinematics. Trivial here. <>= procedure :: complete_kinematics => circe2_complete_kinematics <>= subroutine circe2_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("CIRCE2: map flag not supported") else x = r xb= rb f = 1 end if call sf_int%reduce_momenta (x) end subroutine circe2_complete_kinematics @ %def circe2_complete_kinematics @ Compute inverse kinematics. <>= procedure :: inverse_kinematics => circe2_inverse_kinematics <>= subroutine circe2_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(circe2_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("CIRCE2: map flag not supported") else r = x rb= xb f = 1 end if if (set_mom) then call sf_int%reduce_momenta (x) end if end subroutine circe2_inverse_kinematics @ %def circe2_inverse_kinematics @ \subsection{CIRCE2 application} This function works on both beams. In polarized mode, we set only the selected helicity. In unpolarized mode, the interaction has only one entry, and the factor is unity. <>= procedure :: apply => circe2_apply <>= subroutine circe2_apply (sf_int, scale, rescale, i_sub) class(circe2_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub 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) + 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) + 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_array_get_length (pdg_in) /= 1) & call msg_fatal ("PDF: incoming particle must be unique") call data%flv_in%init (pdg_array_get (pdg_in, 1), model) data%mask = .true. data%mask_photon = .true. select case (pdg_array_get (pdg_in, 1)) case (PROTON) data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON) data%invert = .false. data%photon = .false. case (-PROTON) data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON) data%invert = .true. data%photon = .false. ! case (PIPLUS) ! data%name = var_str (PDF_BUILTIN_DEFAULT_PION) ! data%invert = .false. ! data%photon = .false. ! case (-PIPLUS) ! data%name = var_str (PDF_BUILTIN_DEFAULT_PION) ! data%invert = .true. ! data%photon = .false. ! case (PHOTON) ! data%name = var_str (PDF_BUILTIN_DEFAULT_PHOTON) ! data%invert = .false. ! data%photon = .true. case default call msg_fatal ("PDF: " & // "incoming particle must either proton or antiproton.") return end select data%name = name data%id = pdf_get_id (data%name) if (data%id < 0) call msg_fatal ("unknown PDF set " // char (data%name)) data%has_photon = pdf_provides_photon (data%id) if (present (hoppet_b_matching)) data%hoppet_b_matching = hoppet_b_matching call pdf_init (data%id, path) if (data%hoppet_b_matching) call hoppet_init (.true., pdf_id = data%id) end subroutine pdf_builtin_data_init @ %def pdf_builtin_data_init @ Enable/disable partons explicitly. If a mask entry is true, applying the PDF will generate the corresponding flavor on output. <>= procedure :: set_mask => pdf_builtin_data_set_mask <>= subroutine pdf_builtin_data_set_mask (data, mask) class(pdf_builtin_data_t), intent(inout) :: data logical, dimension(-6:6), intent(in) :: mask data%mask = mask end subroutine pdf_builtin_data_set_mask @ %def pdf_builtin_data_set_mask @ Output. <>= procedure :: write => pdf_builtin_data_write <>= subroutine pdf_builtin_data_write (data, unit, verbose) class(pdf_builtin_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "PDF builtin data:" if (data%id < 0) then write (u, "(3x,A)") "[undefined]" return end if write (u, "(3x,A)", advance="no") "flavor = " call data%flv_in%write (u); write (u, *) write (u, "(3x,A,A)") "name = ", char (data%name) write (u, "(3x,A,L1)") "invert = ", data%invert write (u, "(3x,A,L1)") "has photon = ", data%has_photon write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") & "mask =", & data%mask(-6:-1), "*", data%mask(0), "*", data%mask(1:6) write (u, "(3x,A,L1)") "photon mask = ", data%mask_photon write (u, "(3x,A,L1)") "hoppet_b = ", data%hoppet_b_matching end subroutine pdf_builtin_data_write @ %def pdf_builtin_data_write @ The number of parameters is one. We do not generate transverse momentum. <>= procedure :: get_n_par => pdf_builtin_data_get_n_par <>= function pdf_builtin_data_get_n_par (data) result (n) class(pdf_builtin_data_t), intent(in) :: data integer :: n n = 1 end function pdf_builtin_data_get_n_par @ %def pdf_builtin_data_get_n_par @ Return the outgoing particle PDG codes. This is based on the mask. <>= procedure :: get_pdg_out => pdf_builtin_data_get_pdg_out <>= subroutine pdf_builtin_data_get_pdg_out (data, pdg_out) class(pdf_builtin_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer, dimension(:), allocatable :: pdg1 integer :: n, np, i n = count (data%mask) np = 0; if (data%has_photon .and. data%mask_photon) np = 1 allocate (pdg1 (n + np)) pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask) if (np == 1) pdg1(n+np) = PHOTON pdg_out(1) = pdg1 end subroutine pdf_builtin_data_get_pdg_out @ %def pdf_builtin_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => pdf_builtin_data_allocate_sf_int <>= subroutine pdf_builtin_data_allocate_sf_int (data, sf_int) class(pdf_builtin_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (pdf_builtin_t :: sf_int) end subroutine pdf_builtin_data_allocate_sf_int @ %def pdf_builtin_data_allocate_sf_int @ Return the numerical PDF set index. <>= procedure :: get_pdf_set => pdf_builtin_data_get_pdf_set <>= elemental function pdf_builtin_data_get_pdf_set (data) result (pdf_set) class(pdf_builtin_data_t), intent(in) :: data integer :: pdf_set pdf_set = data%id end function pdf_builtin_data_get_pdf_set @ %def pdf_builtin_data_get_pdf_set @ \subsection{The PDF object} The PDF $1\to 2$ interaction which describes the splitting of an (anti)proton into a parton and a beam remnant. We stay in the strict forward-splitting limit, but allow some invariant mass for the beam remnant such that the outgoing parton is exactly massless. For a real event, we would replace this by a parton cascade, where the outgoing partons have virtuality as dictated by parton-shower kinematics, and transverse momentum is generated. The PDF application is a $1\to 2$ splitting process, where the particles are ordered as (hadron, remnant, parton). Polarization is ignored completely. The beam particle is colorless, while partons and beam remnant carry color. The remnant gets a special flavor code. <>= public :: pdf_builtin_t <>= type, extends (sf_int_t) :: pdf_builtin_t type(pdf_builtin_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: q = 0 contains <> end type pdf_builtin_t @ %def pdf_builtin_t @ Type string: display the chosen PDF set. <>= procedure :: type_string => pdf_builtin_type_string <>= function pdf_builtin_type_string (object) result (string) class(pdf_builtin_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "PDF builtin: " // object%data%name else string = "PDF builtin: [undefined]" end if end function pdf_builtin_type_string @ %def pdf_builtin_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => pdf_builtin_write <>= subroutine pdf_builtin_write (object, unit, testflag) class(pdf_builtin_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A," // FMT_17 // ")") "Q =", object%q end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "PDF builtin data: [undefined]" end if end subroutine pdf_builtin_write @ %def pdf_builtin_write @ Initialize. We know that [[data]] will be of concrete type [[sf_test_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. Optionally, we can provide minimum and maximum values for the momentum transfer. <>= procedure :: init => pdf_builtin_init <>= subroutine pdf_builtin_init (sf_int, data) class(pdf_builtin_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask type(flavor_t) :: flv, flv_remnant type(color_t) :: col0 type(quantum_numbers_t), dimension(3) :: qn integer :: i select type (data) type is (pdf_builtin_data_t) mask = quantum_numbers_mask (.false., .false., .true.) call col0%init () call sf_int%base_init (mask, [0._default], [0._default], [0._default]) sf_int%data => data do i = -6, 6 if (data%mask(i)) then call qn(1)%init (data%flv_in, col = col0) if (i == 0) then call flv%init (GLUON, data%model) call flv_remnant%init (HADRON_REMNANT_OCTET, data%model) else call flv%init (i, data%model) call flv_remnant%init & (sign (HADRON_REMNANT_TRIPLET, -i), data%model) end if call qn(2)%init ( & flv = flv_remnant, col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init ( & flv = flv, col = color_from_flavor (flv, 1, reverse=.true.)) call sf_int%add_state (qn) end if end do if (data%has_photon .and. data%mask_photon) then call flv%init (PHOTON, data%model) call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model) call qn(2)%init (flv = flv_remnant, & col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init (flv = flv, & col = color_from_flavor (flv, 1, reverse = .true.)) call sf_int%add_state (qn) end if call sf_int%freeze () call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) sf_int%status = SF_INITIAL end select end subroutine pdf_builtin_init @ %def pdf_builtin_init @ \subsection{Kinematics} Set kinematics. If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian $f(r)$ is trivial. If [[map]] is set, we are asked to provide an efficient mapping. For the test case, we set $x=r^2$ and consequently $f(r)=2r$. <>= procedure :: complete_kinematics => pdf_builtin_complete_kinematics <>= subroutine pdf_builtin_complete_kinematics (sf_int, x, xb, f, r, rb, map) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(in) :: r real(default), dimension(:), intent(in) :: rb logical, intent(in) :: map if (map) then call msg_fatal ("PDF builtin: map flag not supported") else x(1) = r(1) xb(1)= rb(1) f = 1 end if call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_DONE_KINEMATICS) sf_int%x = x(1) case (SF_FAILED_KINEMATICS) sf_int%x = 0 f = 0 end select end subroutine pdf_builtin_complete_kinematics @ %def pdf_builtin_complete_kinematics @ Overriding the default method: we compute the [[x]] value from the momentum configuration. In this specific case, we also set the internally stored $x$ value, so it can be used in the following routine. <>= procedure :: recover_x => pdf_builtin_recover_x <>= subroutine pdf_builtin_recover_x (sf_int, x, xb, x_free) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(out) :: x real(default), dimension(:), intent(out) :: xb real(default), intent(inout), optional :: x_free call sf_int%base_recover_x (x, xb, x_free) sf_int%x = x(1) end subroutine pdf_builtin_recover_x @ %def sf_pdf_builtin_recover_x @ Compute inverse kinematics. Here, we start with the $x$ array and compute the ``input'' $r$ values and the Jacobian $f$. After this, we can set momenta by the same formula as for normal kinematics. <>= procedure :: inverse_kinematics => pdf_builtin_inverse_kinematics <>= subroutine pdf_builtin_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta) class(pdf_builtin_t), intent(inout) :: sf_int real(default), dimension(:), intent(in) :: x real(default), dimension(:), intent(in) :: xb real(default), intent(out) :: f real(default), dimension(:), intent(out) :: r real(default), dimension(:), intent(out) :: rb logical, intent(in) :: map logical, intent(in), optional :: set_momenta logical :: set_mom set_mom = .false.; if (present (set_momenta)) set_mom = set_momenta if (map) then call msg_fatal ("PDF builtin: map flag not supported") else r(1) = x(1) rb(1)= xb(1) f = 1 end if if (set_mom) then call sf_int%split_momentum (x, xb) select case (sf_int%status) case (SF_FAILED_KINEMATICS); f = 0 end select end if end subroutine pdf_builtin_inverse_kinematics @ %def pdf_builtin_inverse_kinematics @ \subsection{Structure function} Once the scale is also known, we can actually call the PDF and set the values. Contrary to LHAPDF, the wrapper already takes care of adjusting to the $x$ and $Q$ bounds. Account for the Jacobian. 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, rescale, i_sub) class(pdf_builtin_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub 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 i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub 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]))) fc = max (pack ([ff, fph], & [data%mask, data%mask_photon]), 0._default) else allocate (fc (count (data%mask))) fc = max (pack (ff, data%mask), 0._default) end if end associate if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc) 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_array_get_length (pdg_in) /= 1) & call msg_fatal ("PDF: incoming particle must be unique") call data%flv_in%init (pdg_array_get (pdg_in, 1), model) select case (pdg_array_get (pdg_in, 1)) case (PROTON) data%set = 1 case (-PROTON) data%set = 1 data%invert = .true. case (PIPLUS) data%set = 2 case (-PIPLUS) data%set = 2 data%invert = .true. case (PHOTON) data%set = 3 data%photon = .true. if (present (photon_scheme)) data%photon_scheme = photon_scheme case default call msg_fatal (" LHAPDF: " & // "incoming particle must be (anti)proton, pion, or photon.") return end select if (present (prefix)) then data%prefix = prefix else data%prefix = "" end if if (present (file)) then data%file = file else data%file = "" end if if (present (hoppet_b_matching)) data%hoppet_b_matching = hoppet_b_matching if (LHAPDF5_AVAILABLE) then call lhapdf_initialize (data%set, & data%prefix, data%file, data%member, & b_match = data%hoppet_b_matching) call GetXminM (data%set, data%member, xmin) call GetXmaxM (data%set, data%member, xmax) call GetQ2minM (data%set, data%member, q2min) call GetQ2maxM (data%set, data%member, q2max) data%xmin = xmin data%xmax = xmax data%qmin = sqrt (q2min) data%qmax = sqrt (q2max) data%has_photon = has_photon () else if (LHAPDF6_AVAILABLE) then call lhapdf_initialize (data%set, & data%prefix, data%file, data%member, & data%pdf, data%hoppet_b_matching) data%xmin = data%pdf%getxmin () data%xmax = data%pdf%getxmax () data%qmin = sqrt(data%pdf%getq2min ()) data%qmax = sqrt(data%pdf%getq2max ()) data%has_photon = data%pdf%has_photon () end if end subroutine lhapdf_data_init @ %def lhapdf_data_init @ Enable/disable partons explicitly. If a mask entry is true, applying the PDF will generate the corresponding flavor on output. <>= procedure :: set_mask => lhapdf_data_set_mask <>= subroutine lhapdf_data_set_mask (data, mask) class(lhapdf_data_t), intent(inout) :: data logical, dimension(-6:6), intent(in) :: mask data%mask = mask end subroutine lhapdf_data_set_mask @ %def lhapdf_data_set_mask @ Return the public part of the data set. <>= public :: lhapdf_data_get_public_info <>= subroutine lhapdf_data_get_public_info & (data, lhapdf_dir, lhapdf_file, lhapdf_member) type(lhapdf_data_t), intent(in) :: data type(string_t), intent(out) :: lhapdf_dir, lhapdf_file integer, intent(out) :: lhapdf_member lhapdf_dir = data%prefix lhapdf_file = data%file lhapdf_member = data%member end subroutine lhapdf_data_get_public_info @ %def lhapdf_data_get_public_info @ Return the number of the member of the data set. <>= public :: lhapdf_data_get_set <>= function lhapdf_data_get_set(data) result(set) type(lhapdf_data_t), intent(in) :: data integer :: set set = data%set end function lhapdf_data_get_set @ %def lhapdf_data_get_set @ Output <>= procedure :: write => lhapdf_data_write <>= subroutine lhapdf_data_write (data, unit, verbose) class(lhapdf_data_t), intent(in) :: data integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical :: verb integer :: u if (present (verbose)) then verb = verbose else verb = .false. end if u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "LHAPDF data:" if (data%set /= 0) then write (u, "(3x,A)", advance="no") "flavor = " call data%flv_in%write (u); write (u, *) if (verb) then write (u, "(3x,A,A)") " prefix = ", char (data%prefix) else write (u, "(3x,A,A)") " prefix = ", & " " end if write (u, "(3x,A,A)") " file = ", char (data%file) write (u, "(3x,A,I3)") " member = ", data%member write (u, "(3x,A," // FMT_19 // ")") " x(min) = ", data%xmin write (u, "(3x,A," // FMT_19 // ")") " x(max) = ", data%xmax write (u, "(3x,A," // FMT_19 // ")") " Q(min) = ", data%qmin write (u, "(3x,A," // FMT_19 // ")") " Q(max) = ", data%qmax write (u, "(3x,A,L1)") " invert = ", data%invert if (data%photon) write (u, "(3x,A,I3)") & " IP2 (scheme) = ", data%photon_scheme write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") & " mask = ", & data%mask(-6:-1), "*", data%mask(0), "*", data%mask(1:6) write (u, "(3x,A,L1)") " photon mask = ", data%mask_photon if (data%set == 1) write (u, "(3x,A,L1)") & " hoppet_b = ", data%hoppet_b_matching else write (u, "(3x,A)") "[undefined]" end if end subroutine lhapdf_data_write @ %def lhapdf_data_write @ The number of parameters is one. We do not generate transverse momentum. <>= procedure :: get_n_par => lhapdf_data_get_n_par <>= function lhapdf_data_get_n_par (data) result (n) class(lhapdf_data_t), intent(in) :: data integer :: n n = 1 end function lhapdf_data_get_n_par @ %def lhapdf_data_get_n_par @ Return the outgoing particle PDG codes. This is based on the mask. <>= procedure :: get_pdg_out => lhapdf_data_get_pdg_out <>= subroutine lhapdf_data_get_pdg_out (data, pdg_out) class(lhapdf_data_t), intent(in) :: data type(pdg_array_t), dimension(:), intent(inout) :: pdg_out integer, dimension(:), allocatable :: pdg1 integer :: n, np, i n = count (data%mask) np = 0; if (data%has_photon .and. data%mask_photon) np = 1 allocate (pdg1 (n + np)) pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask) if (np == 1) pdg1(n+np) = PHOTON pdg_out(1) = pdg1 end subroutine lhapdf_data_get_pdg_out @ %def lhapdf_data_get_pdg_out @ Allocate the interaction record. <>= procedure :: allocate_sf_int => lhapdf_data_allocate_sf_int <>= subroutine lhapdf_data_allocate_sf_int (data, sf_int) class(lhapdf_data_t), intent(in) :: data class(sf_int_t), intent(inout), allocatable :: sf_int allocate (lhapdf_t :: sf_int) end subroutine lhapdf_data_allocate_sf_int @ %def lhapdf_data_allocate_sf_int @ Return the numerical PDF set index. <>= procedure :: get_pdf_set => lhapdf_data_get_pdf_set <>= elemental function lhapdf_data_get_pdf_set (data) result (pdf_set) class(lhapdf_data_t), intent(in) :: data integer :: pdf_set pdf_set = data%set end function lhapdf_data_get_pdf_set @ %def lhapdf_data_get_pdf_set @ \subsection{The LHAPDF object} The [[lhapdf_t]] data type is a $1\to 2$ interaction which describes the splitting of an (anti)proton into a parton and a beam remnant. We stay in the strict forward-splitting limit, but allow some invariant mass for the beam remnant such that the outgoing parton is exactly massless. For a real event, we would replace this by a parton cascade, where the outgoing partons have virtuality as dictated by parton-shower kinematics, and transverse momentum is generated. This is the LHAPDF object which holds input data together with the interaction. We also store the $x$ momentum fraction and the scale, since kinematics and function value are requested at different times. The PDF application is a $1\to 2$ splitting process, where the particles are ordered as (hadron, remnant, parton). Polarization is ignored completely. The beam particle is colorless, while partons and beam remnant carry color. The remnant gets a special flavor code. <>= public :: lhapdf_t <>= type, extends (sf_int_t) :: lhapdf_t type(lhapdf_data_t), pointer :: data => null () real(default) :: x = 0 real(default) :: q = 0 real(default) :: s = 0 contains <> end type lhapdf_t @ %def lhapdf_t @ Type string: display the chosen PDF set. <>= procedure :: type_string => lhapdf_type_string <>= function lhapdf_type_string (object) result (string) class(lhapdf_t), intent(in) :: object type(string_t) :: string if (associated (object%data)) then string = "LHAPDF: " // object%data%file else string = "LHAPDF: [undefined]" end if end function lhapdf_type_string @ %def lhapdf_type_string @ Output. Call the interaction routine after displaying the configuration. <>= procedure :: write => lhapdf_write <>= subroutine lhapdf_write (object, unit, testflag) class(lhapdf_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: testflag integer :: u u = given_output_unit (unit) if (associated (object%data)) then call object%data%write (u) if (object%status >= SF_DONE_KINEMATICS) then write (u, "(1x,A)") "SF parameters:" write (u, "(3x,A," // FMT_17 // ")") "x =", object%x if (object%status >= SF_FAILED_EVALUATION) then write (u, "(3x,A," // FMT_17 // ")") "Q =", object%q end if end if call object%base_write (u, testflag) else write (u, "(1x,A)") "LHAPDF data: [undefined]" end if end subroutine lhapdf_write @ %def lhapdf_write @ Initialize. We know that [[data]] will be of concrete type [[sf_lhapdf_data_t]], but we have to cast this explicitly. For this implementation, we set the incoming and outgoing masses equal to the physical particle mass, but keep the radiated mass zero. <>= procedure :: init => lhapdf_init <>= subroutine lhapdf_init (sf_int, data) class(lhapdf_t), intent(out) :: sf_int class(sf_data_t), intent(in), target :: data type(quantum_numbers_mask_t), dimension(3) :: mask type(flavor_t) :: flv, flv_remnant type(color_t) :: col0 type(quantum_numbers_t), dimension(3) :: qn integer :: i select type (data) type is (lhapdf_data_t) mask = quantum_numbers_mask (.false., .false., .true.) call col0%init () call sf_int%base_init (mask, [0._default], [0._default], [0._default]) sf_int%data => data do i = -6, 6 if (data%mask(i)) then call qn(1)%init (data%flv_in, col = col0) if (i == 0) then call flv%init (GLUON, data%model) call flv_remnant%init (HADRON_REMNANT_OCTET, data%model) else call flv%init (i, data%model) call flv_remnant%init & (sign (HADRON_REMNANT_TRIPLET, -i), data%model) end if call qn(2)%init ( & flv = flv_remnant, col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init ( & flv = flv, col = color_from_flavor (flv, 1, reverse=.true.)) call sf_int%add_state (qn) end if end do if (data%has_photon .and. data%mask_photon) then call flv%init (PHOTON, data%model) call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model) call qn(2)%init (flv = flv_remnant, & col = color_from_flavor (flv_remnant, 1)) call qn(2)%tag_radiated () call qn(3)%init (flv = flv, & col = color_from_flavor (flv, 1, reverse=.true.)) call sf_int%add_state (qn) end if call sf_int%freeze () call sf_int%set_incoming ([1]) call sf_int%set_radiated ([2]) call sf_int%set_outgoing ([3]) sf_int%status = SF_INITIAL end select end subroutine lhapdf_init @ %def lhapdf_init @ \subsection{Structure function} We have to cast the LHAPDF arguments to/from double precision (possibly from/to extended/quadruple precision), if necessary. Furthermore, some structure functions can yield negative results (sea quarks close to $x=1$). We set these unphysical values to zero. <>= procedure :: apply => lhapdf_apply <>= subroutine lhapdf_apply (sf_int, scale, rescale, i_sub) class(lhapdf_t), intent(inout) :: sf_int real(default), intent(in) :: scale class(sf_rescale_t), intent(in), optional :: rescale integer, intent(in), optional :: i_sub 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 external :: evolvePDFM, evolvePDFpM i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub 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]))) fc = max (pack ([ff, fphot] / x, & [data%mask, data%mask_photon]), 0._default) else allocate (fc (count (data%mask))) fc = max (pack (ff / x, data%mask), 0._default) end if end associate if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc) 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 use numeric_utils, only: vanishes use physics_defs, only: PHOTON use rng_base, only: rng_factory_t use pdg_arrays use model_data, only: model_data_t use dispatch_rng, only: dispatch_rng_factory use dispatch_rng, only: update_rng_seed_in_var_list use flavors, only: flavor_t use sm_qcd, only: qcd_t, alpha_qcd_fixed_t, alpha_qcd_from_scale_t use sm_qcd, only: alpha_qcd_from_lambda_t use physics_defs, only: MZ_REF, ALPHA_QCD_MZ_REF use beam_structures use sf_base use sf_mappings use sf_isr use sf_epa use sf_ewa use sf_escan use sf_gaussian use sf_beam_events use sf_circe1 use sf_circe2 use sf_pdf_builtin use sf_lhapdf <> <> <> <> contains <> end module dispatch_beams @ %def dispatch_beams @ This data type is a container for transferring structure-function specific data from the [[dispatch_sf_data]] to the [[dispatch_sf_channels]] subroutine. <>= public :: sf_prop_t <>= type :: sf_prop_t real(default), dimension(2) :: isr_eps = 1 end type sf_prop_t @ %def sf_prop_t @ Allocate a structure-function configuration object according to the [[sf_method]] string. The [[sf_prop]] object can be used to transfer structure-function specific data up and to the [[dispatch_sf_channels]] subroutine below, so they can be used for particular mappings. The [[var_list_global]] object is used for the RNG generator seed. It is intent(inout) because the RNG generator seed may change during initialization. The [[pdg_in]] array is the array of incoming flavors, corresponding to the upstream structure function or the beam array. This will be checked for the structure function in question and replaced by the outgoing flavors. The [[pdg_prc]] array is the array of incoming flavors (beam index, component index) for the hard process. <>= public :: dispatch_sf_data <>= subroutine dispatch_sf_data (data, sf_method, i_beam, sf_prop, & var_list, var_list_global, model, & os_data, sqrts, pdg_in, pdg_prc, polarized) class(sf_data_t), allocatable, intent(inout) :: data type(string_t), intent(in) :: sf_method integer, dimension(:), intent(in) :: i_beam type(pdg_array_t), dimension(:), intent(inout) :: pdg_in type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc type(sf_prop_t), intent(inout) :: sf_prop type(var_list_t), intent(in) :: var_list type(var_list_t), intent(inout) :: var_list_global integer :: next_rng_seed class(model_data_t), target, intent(in) :: model type(os_data_t), intent(in) :: os_data real(default), intent(in) :: sqrts logical, intent(in) :: polarized type(pdg_array_t), dimension(:), allocatable :: pdg_out real(default) :: isr_alpha, isr_q_max, isr_mass integer :: isr_order logical :: isr_recoil, isr_keep_energy real(default) :: epa_alpha, epa_x_min, epa_q_min, epa_e_max, epa_mass logical :: epa_recoil, epa_keep_energy real(default) :: ewa_x_min, ewa_pt_max, ewa_mass logical :: ewa_recoil, ewa_keep_energy type(pdg_array_t), dimension(:), allocatable :: pdg_prc1 integer :: ewa_id type(string_t) :: pdf_name type(string_t) :: lhapdf_dir, lhapdf_file type(string_t), dimension(13) :: lhapdf_photon_sets integer :: lhapdf_member, lhapdf_photon_scheme logical :: hoppet_b_matching class(rng_factory_t), allocatable :: rng_factory logical :: circe1_photon1, circe1_photon2, circe1_generate, & circe1_with_radiation real(default) :: circe1_sqrts, circe1_eps integer :: circe1_version, circe1_chattiness, & circe1_revision character(6) :: circe1_accelerator logical :: circe2_polarized type(string_t) :: circe2_design, circe2_file real(default), dimension(2) :: gaussian_spread logical :: beam_events_warn_eof type(string_t) :: beam_events_dir, beam_events_file logical :: escan_normalize integer :: i lhapdf_photon_sets = [var_str ("DOG0.LHgrid"), var_str ("DOG1.LHgrid"), & var_str ("DGG.LHgrid"), var_str ("LACG.LHgrid"), & var_str ("GSG0.LHgrid"), var_str ("GSG1.LHgrid"), & var_str ("GSG960.LHgrid"), var_str ("GSG961.LHgrid"), & var_str ("GRVG0.LHgrid"), var_str ("GRVG1.LHgrid"), & var_str ("ACFGPG.LHgrid"), var_str ("WHITG.LHgrid"), & var_str ("SASG.LHgrid")] select case (char (sf_method)) case ("pdf_builtin") allocate (pdf_builtin_data_t :: data) select type (data) type is (pdf_builtin_data_t) pdf_name = & var_list%get_sval (var_str ("$pdf_builtin_set")) hoppet_b_matching = & var_list%get_lval (var_str ("?hoppet_b_matching")) call data%init ( & model, pdg_in(i_beam(1)), & name = pdf_name, & path = os_data%pdf_builtin_datapath, & hoppet_b_matching = hoppet_b_matching) end select case ("pdf_builtin_photon") call msg_fatal ("Currently, there are no photon PDFs built into WHIZARD,", & [var_str ("for the photon content inside a proton or neutron use"), & var_str ("the 'lhapdf_photon' structure function.")]) case ("lhapdf") allocate (lhapdf_data_t :: data) if (pdg_array_get (pdg_in(i_beam(1)), 1) == PHOTON) then call msg_fatal ("The 'lhapdf' structure is intended only for protons and", & [var_str ("pions, please use 'lhapdf_photon' for photon beams.")]) end if lhapdf_dir = & var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = & var_list%get_sval (var_str ("$lhapdf_file")) lhapdf_member = & var_list%get_ival (var_str ("lhapdf_member")) lhapdf_photon_scheme = & var_list%get_ival (var_str ("lhapdf_photon_scheme")) hoppet_b_matching = & var_list%get_lval (var_str ("?hoppet_b_matching")) select type (data) type is (lhapdf_data_t) call data%init & (model, pdg_in(i_beam(1)), & lhapdf_dir, lhapdf_file, lhapdf_member, & lhapdf_photon_scheme, hoppet_b_matching) end select case ("lhapdf_photon") allocate (lhapdf_data_t :: data) if (pdg_array_get_length (pdg_in(i_beam(1))) /= 1 .or. & pdg_array_get (pdg_in(i_beam(1)), 1) /= PHOTON) then call msg_fatal ("The 'lhapdf_photon' structure function is exclusively for", & [var_str ("photon PDFs, i.e. for photons as beam particles")]) end if lhapdf_dir = & var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = & var_list%get_sval (var_str ("$lhapdf_photon_file")) lhapdf_member = & var_list%get_ival (var_str ("lhapdf_member")) lhapdf_photon_scheme = & var_list%get_ival (var_str ("lhapdf_photon_scheme")) if (.not. any (lhapdf_photon_sets == lhapdf_file)) then call msg_fatal ("This PDF set is not supported or not " // & "intended for photon beams.") end if select type (data) type is (lhapdf_data_t) call data%init & (model, pdg_in(i_beam(1)), & lhapdf_dir, lhapdf_file, lhapdf_member, & lhapdf_photon_scheme) end select case ("isr") allocate (isr_data_t :: data) isr_alpha = & var_list%get_rval (var_str ("isr_alpha")) if (vanishes (isr_alpha)) then isr_alpha = (var_list%get_rval (var_str ("ee"))) & ** 2 / (4 * PI) end if isr_q_max = & var_list%get_rval (var_str ("isr_q_max")) if (vanishes (isr_q_max)) then isr_q_max = sqrts end if isr_mass = var_list%get_rval (var_str ("isr_mass")) isr_order = var_list%get_ival (var_str ("isr_order")) isr_recoil = var_list%get_lval (var_str ("?isr_recoil")) isr_keep_energy = var_list%get_lval (var_str ("?isr_keep_energy")) select type (data) type is (isr_data_t) call data%init & (model, pdg_in (i_beam(1)), isr_alpha, isr_q_max, & isr_mass, isr_order, recoil = isr_recoil, keep_energy = & isr_keep_energy) call data%check () sf_prop%isr_eps(i_beam(1)) = data%get_eps () end select case ("epa") allocate (epa_data_t :: data) epa_alpha = var_list%get_rval (var_str ("epa_alpha")) if (vanishes (epa_alpha)) then epa_alpha = (var_list%get_rval (var_str ("ee"))) & ** 2 / (4 * PI) end if epa_x_min = var_list%get_rval (var_str ("epa_x_min")) epa_q_min = var_list%get_rval (var_str ("epa_q_min")) epa_e_max = var_list%get_rval (var_str ("epa_e_max")) if (vanishes (epa_e_max)) then epa_e_max = sqrts end if epa_mass = var_list%get_rval (var_str ("epa_mass")) epa_recoil = var_list%get_lval (var_str ("?epa_recoil")) epa_keep_energy = var_list%get_lval (var_str ("?epa_keep_energy")) select type (data) type is (epa_data_t) call data%init & (model, pdg_in (i_beam(1)), epa_alpha, epa_x_min, & epa_q_min, epa_e_max, epa_mass, recoil = epa_recoil, & keep_energy = epa_keep_energy) call data%check () end select case ("ewa") allocate (ewa_data_t :: data) allocate (pdg_prc1 (size (pdg_prc, 2))) pdg_prc1 = pdg_prc(i_beam(1),:) if (any (pdg_array_get_length (pdg_prc1) /= 1) & .or. any (pdg_prc1 /= pdg_prc1(1))) then call msg_fatal & ("EWA: process incoming particle (W/Z) must be unique") end if ewa_id = abs (pdg_array_get (pdg_prc1(1), 1)) ewa_x_min = var_list%get_rval (var_str ("ewa_x_min")) ewa_pt_max = var_list%get_rval (var_str ("ewa_pt_max")) if (vanishes (ewa_pt_max)) then ewa_pt_max = sqrts end if ewa_mass = var_list%get_rval (var_str ("ewa_mass")) ewa_recoil = var_list%get_lval (& var_str ("?ewa_recoil")) ewa_keep_energy = var_list%get_lval (& var_str ("?ewa_keep_energy")) select type (data) type is (ewa_data_t) call data%init & (model, pdg_in (i_beam(1)), ewa_x_min, & ewa_pt_max, sqrts, ewa_recoil, & ewa_keep_energy, ewa_mass) call data%set_id (ewa_id) call data%check () end select case ("circe1") allocate (circe1_data_t :: data) select type (data) type is (circe1_data_t) circe1_photon1 = & var_list%get_lval (var_str ("?circe1_photon1")) circe1_photon2 = & var_list%get_lval (var_str ("?circe1_photon2")) circe1_sqrts = & var_list%get_rval (var_str ("circe1_sqrts")) circe1_eps = & var_list%get_rval (var_str ("circe1_eps")) if (circe1_sqrts <= 0) circe1_sqrts = sqrts circe1_generate = & var_list%get_lval (var_str ("?circe1_generate")) circe1_version = & var_list%get_ival (var_str ("circe1_ver")) circe1_revision = & var_list%get_ival (var_str ("circe1_rev")) circe1_accelerator = & char (var_list%get_sval (var_str ("$circe1_acc"))) circe1_chattiness = & var_list%get_ival (var_str ("circe1_chat")) circe1_with_radiation = & var_list%get_lval (var_str ("?circe1_with_radiation")) call data%init (model, pdg_in, circe1_sqrts, circe1_eps, & [circe1_photon1, circe1_photon2], & circe1_version, circe1_revision, circe1_accelerator, & circe1_chattiness, circe1_with_radiation) if (circe1_generate) then call msg_message ("CIRCE1: activating generator mode") call dispatch_rng_factory & (rng_factory, var_list_global, next_rng_seed) call update_rng_seed_in_var_list (var_list_global, next_rng_seed) call data%set_generator_mode (rng_factory) end if end select case ("circe2") allocate (circe2_data_t :: data) select type (data) type is (circe2_data_t) circe2_polarized = & var_list%get_lval (var_str ("?circe2_polarized")) circe2_file = & var_list%get_sval (var_str ("$circe2_file")) circe2_design = & var_list%get_sval (var_str ("$circe2_design")) call data%init (os_data, model, pdg_in, sqrts, & circe2_polarized, polarized, circe2_file, circe2_design) call msg_message ("CIRCE2: activating generator mode") call dispatch_rng_factory & (rng_factory, var_list_global, next_rng_seed) call update_rng_seed_in_var_list (var_list_global, next_rng_seed) call data%set_generator_mode (rng_factory) end select case ("gaussian") allocate (gaussian_data_t :: data) select type (data) type is (gaussian_data_t) gaussian_spread = & [var_list%get_rval (var_str ("gaussian_spread1")), & var_list%get_rval (var_str ("gaussian_spread2"))] call dispatch_rng_factory & (rng_factory, var_list_global, next_rng_seed) call update_rng_seed_in_var_list (var_list_global, next_rng_seed) call data%init (model, pdg_in, gaussian_spread, rng_factory) end select case ("beam_events") allocate (beam_events_data_t :: data) select type (data) type is (beam_events_data_t) beam_events_dir = os_data%whizard_beamsimpath beam_events_file = var_list%get_sval (& var_str ("$beam_events_file")) beam_events_warn_eof = var_list%get_lval (& var_str ("?beam_events_warn_eof")) call data%init (model, pdg_in, & beam_events_dir, beam_events_file, beam_events_warn_eof) end select case ("energy_scan") escan_normalize = & var_list%get_lval (var_str ("?energy_scan_normalize")) allocate (escan_data_t :: data) select type (data) type is (escan_data_t) if (escan_normalize) then call data%init (model, pdg_in) else call data%init (model, pdg_in, sqrts) end if end select case default if (associated (dispatch_sf_data_extra)) then call dispatch_sf_data_extra (data, sf_method, i_beam, & sf_prop, var_list, var_list_global, model, os_data, sqrts, pdg_in, & pdg_prc, polarized) end if if (.not. allocated (data)) then call msg_fatal ("Structure function '" & // char (sf_method) // "' not implemented") end if end select if (allocated (data)) then allocate (pdg_out (size (pdg_prc, 1))) call data%get_pdg_out (pdg_out) do i = 1, size (i_beam) pdg_in(i_beam(i)) = pdg_out(i) end do end if end subroutine dispatch_sf_data @ %def dispatch_sf_data @ This is a hook that allows us to inject further handlers for structure-function objects, in particular a test structure function. <>= public :: dispatch_sf_data_extra <>= procedure (dispatch_sf_data), pointer :: & dispatch_sf_data_extra => null () @ %def dispatch_sf_data_extra @ This is an auxiliary procedure, used by the beam-structure expansion: tell for a given structure function name, whether it corresponds to a pair spectrum ($n=2$), a single-particle structure function ($n=1$), or nothing ($n=0$). Though [[energy_scan]] can in principle also be a pair spectrum, it always has only one parameter. <>= public :: strfun_mode <>= function strfun_mode (name) result (n) type(string_t), intent(in) :: name integer :: n select case (char (name)) case ("none") n = 0 case ("sf_test_0", "sf_test_1") n = 1 case ("pdf_builtin","pdf_builtin_photon", & "lhapdf","lhapdf_photon") n = 1 case ("isr","epa","ewa") n = 1 case ("circe1", "circe2") n = 2 case ("gaussian") n = 2 case ("beam_events") n = 2 case ("energy_scan") n = 2 case default n = -1 call msg_bug ("Structure function '" // char (name) & // "' not supported yet") end select end function strfun_mode @ %def strfun_mode @ Dispatch a whole structure-function chain, given beam data and beam structure data. This could be done generically, but we should look at the specific combination of structure functions in order to select appropriate mappings. The [[beam_structure]] argument gets copied because we want to expand it to canonical form (one valid structure-function entry per record) before proceeding further. The [[pdg_prc]] argument is the array of incoming flavors. The first index is the beam index, the second one the process component index. Each element is itself a PDG array, notrivial if there is a flavor sum for the incoming state of this component. The dispatcher is divided in two parts. The first part configures the structure function data themselves. After this, we can configure the phase space for the elementary process. <>= public :: dispatch_sf_config <>= subroutine dispatch_sf_config (sf_config, sf_prop, beam_structure, & var_list, var_list_global, model, os_data, sqrts, pdg_prc) type(sf_config_t), dimension(:), allocatable, intent(out) :: sf_config type(sf_prop_t), intent(out) :: sf_prop type(beam_structure_t), intent(inout) :: beam_structure type(var_list_t), intent(in) :: var_list type(var_list_t), intent(inout) :: var_list_global class(model_data_t), target, intent(in) :: model type(os_data_t), intent(in) :: os_data real(default), intent(in) :: sqrts class(sf_data_t), allocatable :: sf_data type(beam_structure_t) :: beam_structure_tmp type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc type(string_t), dimension(:), allocatable :: prt_in type(pdg_array_t), dimension(:), allocatable :: pdg_in type(flavor_t) :: flv_in integer :: n_beam, n_record, i beam_structure_tmp = beam_structure call beam_structure_tmp%expand (strfun_mode) n_record = beam_structure_tmp%get_n_record () allocate (sf_config (n_record)) n_beam = beam_structure_tmp%get_n_beam () if (n_beam > 0) then allocate (prt_in (n_beam), pdg_in (n_beam)) prt_in = beam_structure_tmp%get_prt () do i = 1, n_beam call flv_in%init (prt_in(i), model) pdg_in(i) = flv_in%get_pdg () end do else n_beam = size (pdg_prc, 1) allocate (pdg_in (n_beam)) pdg_in = pdg_prc(:,1) end if do i = 1, n_record call dispatch_sf_data (sf_data, & beam_structure_tmp%get_name (i), & beam_structure_tmp%get_i_entry (i), & sf_prop, var_list, var_list_global, model, os_data, sqrts, & pdg_in, pdg_prc, & beam_structure_tmp%polarized ()) call sf_config(i)%init (beam_structure_tmp%get_i_entry (i), sf_data) deallocate (sf_data) end do end subroutine dispatch_sf_config @ %def dispatch_sf_config @ \subsection{QCD coupling} Allocate the [[alpha]] (running coupling) component of the [[qcd]] block with a concrete implementation, depending on the variable settings in the [[global]] record. If a fixed $\alpha_s$ is requested, we do not allocate the [[qcd%alpha]] object. In this case, the matrix element code will just take the model parameter as-is, which implies fixed $\alpha_s$. If the object is allocated, the $\alpha_s$ value is computed and updated for each matrix-element call. Also fetch the [[alphas_nf]] variable from the list and store it in the QCD record. This is not used in the $\alpha_s$ calculation, but the QCD record thus becomes a messenger for this user parameter. <>= public :: dispatch_qcd <>= subroutine dispatch_qcd (qcd, var_list, os_data) type(qcd_t), intent(inout) :: qcd type(var_list_t), intent(in) :: var_list type(os_data_t), intent(in) :: os_data logical :: fixed, from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd real(default) :: mz, alpha_val, lambda integer :: nf, order, lhapdf_member type(string_t) :: pdfset, lhapdf_dir, lhapdf_file call unpack_variables () if (allocated (qcd%alpha)) deallocate (qcd%alpha) if (from_lhapdf .and. from_pdf_builtin) then call msg_fatal (" Mixing alphas evolution", & [var_str (" from LHAPDF and builtin PDF is not permitted")]) end if select case (count ([from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd])) case (0) if (fixed) then allocate (alpha_qcd_fixed_t :: qcd%alpha) else call msg_fatal ("QCD alpha: no calculation mode set") end if case (2:) call msg_fatal ("QCD alpha: calculation mode is ambiguous") case (1) if (fixed) then call msg_fatal ("QCD alpha: use '?alphas_is_fixed = false' for " // & "running alphas") else if (from_mz) then allocate (alpha_qcd_from_scale_t :: qcd%alpha) else if (from_pdf_builtin) then allocate (alpha_qcd_pdf_builtin_t :: qcd%alpha) else if (from_lhapdf) then allocate (alpha_qcd_lhapdf_t :: qcd%alpha) else if (from_lambda_qcd) then allocate (alpha_qcd_from_lambda_t :: qcd%alpha) end if call msg_message ("QCD alpha: using a running strong coupling") end select call init_alpha () qcd%n_f = var_list%get_ival (var_str ("alphas_nf")) contains <> end subroutine dispatch_qcd @ %def dispatch_qcd @ <>= subroutine unpack_variables () fixed = var_list%get_lval (var_str ("?alphas_is_fixed")) from_mz = var_list%get_lval (var_str ("?alphas_from_mz")) from_pdf_builtin = & var_list%get_lval (var_str ("?alphas_from_pdf_builtin")) from_lhapdf = & var_list%get_lval (var_str ("?alphas_from_lhapdf")) from_lambda_qcd = & var_list%get_lval (var_str ("?alphas_from_lambda_qcd")) pdfset = var_list%get_sval (var_str ("$pdf_builtin_set")) lambda = var_list%get_rval (var_str ("lambda_qcd")) nf = var_list%get_ival (var_str ("alphas_nf")) order = var_list%get_ival (var_str ("alphas_order")) lhapdf_dir = var_list%get_sval (var_str ("$lhapdf_dir")) lhapdf_file = var_list%get_sval (var_str ("$lhapdf_file")) lhapdf_member = var_list%get_ival (var_str ("lhapdf_member")) if (var_list%contains (var_str ("mZ"))) then mz = var_list%get_rval (var_str ("mZ")) else mz = MZ_REF end if if (var_list%contains (var_str ("alphas"))) then alpha_val = var_list%get_rval (var_str ("alphas")) else alpha_val = ALPHA_QCD_MZ_REF end if end subroutine unpack_variables @ <>= subroutine init_alpha () select type (alpha => qcd%alpha) type is (alpha_qcd_fixed_t) alpha%val = alpha_val type is (alpha_qcd_from_scale_t) alpha%mu_ref = mz alpha%ref = alpha_val alpha%order = order alpha%nf = nf type is (alpha_qcd_from_lambda_t) alpha%lambda = lambda alpha%order = order alpha%nf = nf type is (alpha_qcd_pdf_builtin_t) call alpha%init (pdfset, & os_data%pdf_builtin_datapath) type is (alpha_qcd_lhapdf_t) call alpha%init (lhapdf_file, lhapdf_member, lhapdf_dir) end select end subroutine init_alpha @ Index: trunk/share/tests/unit_tests/ref-output/sf_circe1_3.ref =================================================================== --- trunk/share/tests/unit_tests/ref-output/sf_circe1_3.ref (revision 8334) +++ trunk/share/tests/unit_tests/ref-output/sf_circe1_3.ref (revision 8335) @@ -1,171 +1,170 @@ * Test output: sf_circe1_3 * Purpose: initialize and fill circe1 structure function object * Initialize configuration data * Initialize structure-function object * Initialize incoming momentum with E=500 E = 2.500000000000E+02 P = 0.000000000000E+00 0.000000000000E+00 2.499999999995E+02 E = 2.500000000000E+02 P = 0.000000000000E+00 0.000000000000E+00 -2.499999999995E+02 * Generate x x = 1.0000000 0.9997418 xb= 0.0000000 0.0002582 f = 1.0000000 xf= 0.9997418 * Evaluate CIRCE1 data: prt_in = e- e+ photon = F F generate = T m_in = 5.109970000000E-04 5.109970000000E-04 sqrts = 5.000000000000E+02 eps = 1.000000000000E-06 ver = 0 rev = 0 acc = SBAND chat = 0 with rad.= T - RNG factory: test (1) Random-number generator: test (state = 5) x = 1.0000000000E+00 9.9974182319E-01 xb= 0.0000000000E+00 2.5817681304E-04 f = 1.0000000000E+00 SF instance: [evaluated] beam = 1 2 incoming = 1 2 radiated = 3 4 outgoing = 5 6 Interaction: 1 Incoming: Particle 1 E = 2.500000000000E+02 P = 0.000000000000E+00 0.000000000000E+00 2.499999999995E+02 mask [fch] = [FFgF] internal links: X => 3 4 5 6 helicity lock: 5 Particle 2 E = 2.500000000000E+02 P = 0.000000000000E+00 0.000000000000E+00 -2.499999999995E+02 mask [fch] = [FFgF] internal links: X => 3 4 5 6 helicity lock: 6 Outgoing: Particle 3 E = 0.000000000000E+00 P = 0.000000000000E+00 0.000000000000E+00 0.000000000000E+00 mask [fch] = [FFgT] internal links: 1 2 => X Particle 4 E = 6.454420325971E-02 P = 0.000000000000E+00 0.000000000000E+00 -6.454420325971E-02 mask [fch] = [FFgT] internal links: 1 2 => X Particle 5 E = 2.500000000000E+02 P = 0.000000000000E+00 0.000000000000E+00 2.499999999995E+02 mask [fch] = [FFgF] internal links: 1 2 => X helicity lock: 1 Particle 6 E = 2.499354557967E+02 P = 0.000000000000E+00 0.000000000000E+00 -2.499354557962E+02 mask [fch] = [FFgF] internal links: 1 2 => X helicity lock: 2 State matrix: norm = 1.000000000000E+00 [f(11) h(-1)] [f(-11) h(-1)] [f(22*)] [f(22*)] [f(11) h(-1)] [f(-11) h(-1)] => ME(1) = ( 1.000000000000E+00, 0.000000000000E+00) [f(-11) h(-1|1)] [f(22*)] [f(22*)] [f(11) h(-1)] [f(-11) h(-1|1)] => ME(2) = ( 1.000000000000E+00, 0.000000000000E+00) [f(-11) h(1|-1)] [f(22*)] [f(22*)] [f(11) h(-1)] [f(-11) h(1|-1)] => ME(3) = ( 1.000000000000E+00, 0.000000000000E+00) [f(-11) h(1)] [f(22*)] [f(22*)] [f(11) h(-1)] [f(-11) h(1)] => ME(4) = ( 1.000000000000E+00, 0.000000000000E+00) [f(11) h(-1|1)] [f(-11) h(-1)] [f(22*)] [f(22*)] [f(11) h(-1|1)] [f(-11) h(-1)] => ME(5) = ( 1.000000000000E+00, 0.000000000000E+00) [f(-11) h(-1|1)] [f(22*)] [f(22*)] [f(11) h(-1|1)] [f(-11) h(-1|1)] => ME(6) = ( 1.000000000000E+00, 0.000000000000E+00) [f(-11) h(1|-1)] [f(22*)] [f(22*)] [f(11) h(-1|1)] [f(-11) h(1|-1)] => ME(7) = ( 1.000000000000E+00, 0.000000000000E+00) [f(-11) h(1)] [f(22*)] [f(22*)] [f(11) h(-1|1)] [f(-11) h(1)] => ME(8) = ( 1.000000000000E+00, 0.000000000000E+00) [f(11) h(1|-1)] [f(-11) h(-1)] [f(22*)] [f(22*)] [f(11) h(1|-1)] [f(-11) h(-1)] => ME(9) = ( 1.000000000000E+00, 0.000000000000E+00) [f(-11) h(-1|1)] [f(22*)] [f(22*)] [f(11) h(1|-1)] [f(-11) h(-1|1)] => ME(10) = ( 1.000000000000E+00, 0.000000000000E+00) [f(-11) h(1|-1)] [f(22*)] [f(22*)] [f(11) h(1|-1)] [f(-11) h(1|-1)] => ME(11) = ( 1.000000000000E+00, 0.000000000000E+00) [f(-11) h(1)] [f(22*)] [f(22*)] [f(11) h(1|-1)] [f(-11) h(1)] => ME(12) = ( 1.000000000000E+00, 0.000000000000E+00) [f(11) h(1)] [f(-11) h(-1)] [f(22*)] [f(22*)] [f(11) h(1)] [f(-11) h(-1)] => ME(13) = ( 1.000000000000E+00, 0.000000000000E+00) [f(-11) h(-1|1)] [f(22*)] [f(22*)] [f(11) h(1)] [f(-11) h(-1|1)] => ME(14) = ( 1.000000000000E+00, 0.000000000000E+00) [f(-11) h(1|-1)] [f(22*)] [f(22*)] [f(11) h(1)] [f(-11) h(1|-1)] => ME(15) = ( 1.000000000000E+00, 0.000000000000E+00) [f(-11) h(1)] [f(22*)] [f(22*)] [f(11) h(1)] [f(-11) h(1)] => ME(16) = ( 1.000000000000E+00, 0.000000000000E+00) * Cleanup * Test output end: sf_circe1_3 Index: trunk/share/tests/unit_tests/ref-output/sf_circe2_2.ref =================================================================== --- trunk/share/tests/unit_tests/ref-output/sf_circe2_2.ref (revision 8334) +++ trunk/share/tests/unit_tests/ref-output/sf_circe2_2.ref (revision 8335) @@ -1,68 +1,67 @@ * Test output: sf_circe2_2 * Purpose: initialize and fill circe2 structure function object * Initialize configuration data * Initialize structure-function object * Initialize incoming momentum with E=500 E = 2.500000000000E+02 P = 0.000000000000E+00 0.000000000000E+00 2.500000000000E+02 E = 2.500000000000E+02 P = 0.000000000000E+00 0.000000000000E+00 -2.500000000000E+02 * Generate x x = 0.7548532 0.0361119 xb= 0.2451468 0.9638881 f = 1.0000000 xf= 0.0272592 * Evaluate CIRCE2 data: file = teslagg_500_polavg.circe design = TESLA/GG sqrts = 5.000000000000E+02 prt_in = A, A polarized = F beams pol. = F luminosity = 1.006190000000E+03 - RNG factory: test (1) SF instance: [evaluated] beam = 1 2 incoming = 1 2 outgoing = 3 4 Interaction: 1 Incoming: Particle 1 E = 2.500000000000E+02 P = 0.000000000000E+00 0.000000000000E+00 2.500000000000E+02 mask [fch] = [FFgT] internal links: X => 3 4 Particle 2 E = 2.500000000000E+02 P = 0.000000000000E+00 0.000000000000E+00 -2.500000000000E+02 mask [fch] = [FFgT] internal links: X => 3 4 Outgoing: Particle 3 E = 1.887132931540E+02 P = 0.000000000000E+00 0.000000000000E+00 1.887132931540E+02 mask [fch] = [FFgT] internal links: 1 2 => X Particle 4 E = 9.027980596406E+00 P = 0.000000000000E+00 0.000000000000E+00 -9.027980596406E+00 mask [fch] = [FFgT] internal links: 1 2 => X State matrix: norm = 1.000000000000E+00 [f(22)] [f(22)] [f(22)] [f(22)] => ME(1) = ( 1.000000000000E+00, 0.000000000000E+00) * Cleanup * Test output end: sf_circe2_2 Index: trunk/share/tests/unit_tests/ref-output/sf_circe2_3.ref =================================================================== --- trunk/share/tests/unit_tests/ref-output/sf_circe2_3.ref (revision 8334) +++ trunk/share/tests/unit_tests/ref-output/sf_circe2_3.ref (revision 8335) @@ -1,76 +1,75 @@ * Test output: sf_circe2_3 * Purpose: initialize and fill circe2 structure function object * Initialize configuration data * Initialize structure-function object * Initialize incoming momentum with E=500 E = 2.500000000000E+02 P = 0.000000000000E+00 0.000000000000E+00 2.500000000000E+02 E = 2.500000000000E+02 P = 0.000000000000E+00 0.000000000000E+00 -2.500000000000E+02 * Generate x x = 0.1359217 0.3908304 xb= 0.8640783 0.6091696 f = 1.0000000 xf= 0.0531223 * Evaluate CIRCE2 data: file = teslagg_500.circe design = TESLA/GG sqrts = 5.000000000000E+02 prt_in = A, A polarized = T beams pol. = F luminosity = 1.006187000000E+03 (-1 -1) = 1.901773725958E-01 (-1 1) = 2.326545661989E-01 ( 1 -1) = 2.365643762044E-01 ( 1 1) = 3.406036850009E-01 - RNG factory: test (1) SF instance: [evaluated] beam = 1 2 incoming = 1 2 outgoing = 3 4 Interaction: 1 Incoming: Particle 1 E = 2.500000000000E+02 P = 0.000000000000E+00 0.000000000000E+00 2.500000000000E+02 mask [fch] = [FFgT] internal links: X => 3 4 Particle 2 E = 2.500000000000E+02 P = 0.000000000000E+00 0.000000000000E+00 -2.500000000000E+02 mask [fch] = [FFgT] internal links: X => 3 4 Outgoing: Particle 3 E = 3.398041619218E+01 P = 0.000000000000E+00 0.000000000000E+00 3.398041619218E+01 mask [fch] = [FFgF] internal links: 1 2 => X Particle 4 E = 9.770759821797E+01 P = 0.000000000000E+00 0.000000000000E+00 -9.770759821797E+01 mask [fch] = [FFgF] internal links: 1 2 => X State matrix: norm = 1.000000000000E+00 [f(22)] [f(22)] [f(22) h(-1)] [f(22) h(-1)] => ME(1) = ( 0.000000000000E+00, 0.000000000000E+00) [f(22) h(1)] => ME(2) = ( 1.000000000000E+00, 0.000000000000E+00) [f(22) h(1)] [f(22) h(-1)] => ME(3) = ( 0.000000000000E+00, 0.000000000000E+00) [f(22) h(1)] => ME(4) = ( 0.000000000000E+00, 0.000000000000E+00) * Cleanup * Test output end: sf_circe2_3