Index: trunk/src/fks/fks.nw =================================================================== --- trunk/src/fks/fks.nw (revision 8792) +++ trunk/src/fks/fks.nw (revision 8793) @@ -1,10248 +1,10252 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: matrix elements and process libraries %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{FKS Subtraction Scheme} \includemodulegraph{fks} The code in this chapter implements the FKS subtraction scheme for use with \whizard. These are the modules: \begin{description} \item[fks\_regions] Given a process definition, identify singular regions in the associated phase space. \item[virtual] Handle the virtual correction matrix element. \item[real\_subtraction] Handle the real-subtraction matrix element. \item[nlo\_data] Manage the subtraction objects. \end{description} This chapter deals with next-to-leading order contributions to cross sections. Basically, there are three major issues to be adressed: The creation of the $N+1$-particle flavor structure, the construction of the $N+1$-particle phase space and the actual calculation of the real- and virtual-subtracted matrix elements. The first is dealt with using the [[auto_components]] class, and it will be shown that the second and third issue are connected in FKS subtraction. \section{Brief outline of FKS subtraction} {\em In the current state, this discussion is only concerned with lepton collisions. For hadron collisions, renormalization of parton distributions has to be taken into account. Further, for QCD corrections, initial-state radiation is necessarily present.} The aim is to calculate the next-to-leading order cross section according to \begin{equation*} d\sigma_{\rm{NLO}} = \mathcal{B} + \mathcal{V} + \mathcal{R}d\Phi_{\rm{rad}}. \end{equation*} Analytically, the divergences, in terms of poles in the complex quantity $\varepsilon = 2-d/2$, cancel. However, this is in general only valid in an arbitrary, complex number of dimensions. This is, roughly, the content of the KLN-theorem. \whizard, as any other numerical program, is confined to four dimensions. We will assume that the KLN-theorem is valid and that there exist subtraction terms $\mathcal{C}$ such that \begin{equation*} d\sigma_{\rm{NLO}} = \mathcal{B} + \underbrace{\mathcal{V} + \mathcal{C}}_{\text{finite}} + \underbrace{\mathcal{R} - \mathcal{C}}_{\text{finite}}, \end{equation*} i.e. the subtraction terms correspond to the divergent limits of the real and virtual matrix element. Because $\mathcal{C}$ subtracts the divergences of $\mathcal{R}$ as well as those of $\mathcal{V}$, it suffices to consider one of them, so we focus on $\mathcal{R}$. For this purpose, $\mathcal{R}$ is rewritten as \begin{equation*} \mathcal{R} = \frac{1}{\xi^2}\frac{1}{1-y} \left(\xi^2 (1-y)\mathcal{R}\right) = \frac{1}{\xi^2}\frac{1}{1-y}\tilde{\mathcal{R}}, \end{equation*} with $\xi = \left(2k_{\rm{rad}}^0\right)/\sqrt{s}$ and $y = \cos\theta$, where $k_{\rm{rad}}^0$ denotes the energy of the radiated parton and $\theta$ is the angle between emitter and radiated parton. $\tilde{\mathcal{R}}$ is finite, therefore the whole singularity structure is contained in the prefactor $\xi^{-2}(1-y)^{-1}$. Combined with the $d$-dimensional phase space element, \begin{equation*} \frac{d^{d-1}k}{2k^0(2\pi)^{d-1}} = \frac{s^{1-\varepsilon}}{(4\pi)^{d-1}}\xi^{1-2\varepsilon}\left(1-y^2\right)^{-\varepsilon} d\xi dy d\Omega^{d-2}, \end{equation*} this yields \begin{equation*} d\Phi_{\rm{rad}} \mathcal{R} = dy (1-y)^{-1-\varepsilon} d\xi \xi^{-1-2\varepsilon} \tilde{R}. \end{equation*} This can further be rewritten in terms of plus-distributions, \begin{align*} \xi^{-1-2\varepsilon} &= -\frac{1}{2\varepsilon}\delta(\xi) + \left(\frac{1}{\xi}\right)_+ - 2\varepsilon\left(\frac{\log\xi}{\xi}\right)_+ + \mathcal{O}(\varepsilon^2),\\ (1-y)^{-1-\varepsilon} &= -\frac{2^{-\varepsilon}}{\varepsilon} \delta(1-y) + \left(\frac{1}{1-y}\right)_+ - \varepsilon \left(\frac{1}{1-y}\right)_+\log(1-y) + \mathcal{O}(\varepsilon^2), \end{align*} (imagine that all this is written inside of integrals, which are spared for ease of notation) such that \begin{align*} d\Phi_{\rm{rad}} \mathcal{R} &= -\frac{1}{2\varepsilon} dy (1-y)^{-1-\varepsilon}\tilde{R} (0,y) - d\xi\left[\frac{2^{-\varepsilon}}{\varepsilon}\left(\frac{1}{\xi}\right)_+ - 2\left(\frac{\log\xi}{\xi}\right)_+\right] \tilde{R}(\xi,1) \\ &+ dy d\xi \left(\frac{1}{\xi}\right)_+ \left(\frac{1}{1-y}\right)_+ \tilde{R}(\xi, y) + \mathcal{O}(\varepsilon).\\ \end{align*} The summand in the second line is of order $\mathcal{O}(1)$ and is the only one to reproduce $\mathcal{R}(\xi,y)$. It thus constitutes the sum of the real matrix element and the corresponding counterterms. The first summand consequently consists of the subtraction terms to the virtual matrix elements. Above formula thus allows to calculate all quantities to render the matrix elements finite. \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Identifying singular regions} In the FKS subtraction scheme, the phase space is decomposed into disjoint singular regions, such that \begin{equation} \label{eq:S_complete} \sum_i \mathcal{S}_i + \sum_{ij}\mathcal{S}_{ij} = 1. \end{equation} The quantities $\mathcal{S}_i$ and $\mathcal{S}_{ij}$ are functions of phase space corresponding to a pair of particles indices which can make up a divergent phase space region. We call such an index pair a fundamental tuple. For example, the process $e^+ \, e^- \rightarrow u \, \bar{u} \, g$ has two singular regions, $(3,5)$ and $(4,5)$, indicating that the gluon can be soft or collinear with respect to either the quark or the anti-quark. Therefore, the functions $S_{ij}$ have to be chosen in such a way that their contribution makes up most of \eqref{eq:S_complete} in phase-space configurations where (final-state) particle $j$ is collinear to particle $i$ or/and particle $j$ is soft. The functions $S_i$ is the corresponding quantity for initial-state divergences. As a singular region we understand the collection of real flavor structures associated with an emitter and a list of all possible fundamental tuples. As an example, consider the process $e^+ \, e^- \rightarrow u \, \bar{u} \, g$. At next-to-leading order, processes with an additionally radiated particle have to be considered. In this case, these are $e^+ \, e^- \rightarrow u \, \bar{u}, \, g \, g$, and $e^+ \, e^- \rightarrow u \, \bar{u} \, u \, \bar{u}$ (or the same process with any other quark). Table \ref{table:singular regions} sums up all possible singular regions for this problem. \begin{table} \begin{tabular}{|c|c|c|c|} \hline \texttt{alr} & \texttt{flst\_alr} & \texttt{emitter} & \texttt{ftuple\_list}\\ \hline 1 & [-11,11,2,-2,21,21] & 3 & {(3,5), (3,6), (4,5), (4,6), (5,6)} \\ \hline 2 & [-11,11,2,-2,21,21] & 4 & {(3,5), (3,6), (4,5), (4,6), (5,6)} \\ \hline 3 & [-11,11,2,-2,21,21] & 5 & {(3,5), (3,6), (4,5), (4,6), (5,6)} \\ \hline 4 & [-11,11,2,-2,2,-2] & 5 & {(3,4), (3,6), (4,5), (5,6)} \\ \hline \end{tabular} \caption{List of singular regions. The particles are represented by their PDG codes. The third column contains the emitter for the specific singular region. For the process involving an additional gluon, the gluon can either be emitted from one of the quarks or from the first gluon. Each emitter yields the same list of fundamental tuples, five in total. The last singular region corresponds to the process where the gluon splits up into two quarks. As the matrix element for this process has no information on which quarks originate from a gluon splitting, there are ftuples for all the quark pairs and not just those involving the emitter.} \label{table:singular regions} \end{table} \\ \begin{table} \begin{tabular}{|c|c|c|c|} \hline \texttt{alr} & \texttt{ftuple} & \texttt{emitter} & \texttt{flst\_alr} \\ \hline 1 & $(3,5)$ & 5 & [-11,11,-2,21,2,21] \\ \hline 2 & $(4,5)$ & 5 & [-11,11,2,21,-2,21] \\ \hline 3 & $(3,6)$ & 5 & [-11,11,-2,21,2,21] \\ \hline 4 & $(4,6)$ & 5 & [-11,11,2,21,-2,21] \\ \hline 5 & $(5,6)$ & 5 & [-11,11,2,-2,21,21] \\ \hline 6 & $(5,6)$ & 5 & [-11,11,2,-2,2,-2] \\ \hline \end{tabular} \caption{Initial list of singular regions} \label{table:ftuples and flavors} \end{table} Thus, during the preparation of a NLO-calculation, the possible singular regions have to be identified. [[fks_regions.f90]] deals with this issue. \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{FKS Regions} <<[[fks_regions.f90]]>>= <> module fks_regions <> use format_utils, only: write_separator use numeric_utils use string_utils, only: str use io_units use os_interface <> <> use constants use permutations use diagnostics use flavors use process_constants use lorentz use pdg_arrays use models use physics_defs use resonances, only: resonance_contributors_t, resonance_history_t use phs_fks, only: phs_identifier_t, check_for_phs_identifier use nlo_data <> <> <> <> <> contains <> end module fks_regions @ %def fks_regions @ There are three fundamental splitting types: $q \rightarrow qg$, $g \rightarrow gg$ and $g \rightarrow qq$ for FSR and additionally $q \rightarrow gq$ for ISR which is different from $q \rightarrow qg$ by which particle enters the hard process. <>= integer, parameter :: UNDEFINED_SPLITTING = 0 integer, parameter :: F_TO_FV = 1 integer, parameter :: V_TO_VV = 2 integer, parameter :: V_TO_FF = 3 integer, parameter :: F_TO_VF = 4 @ @ We group the indices of the emitting and the radiated particle in the [[ftuple]]-object. <>= public :: ftuple_t <>= type :: ftuple_t integer, dimension(2) :: ireg = [-1,-1] integer :: i_res = 0 integer :: splitting_type logical :: pseudo_isr = .false. logical :: qcd_split = .false. contains <> end type ftuple_t @ %def ftuple_t @ <>= interface assignment(=) module procedure ftuple_assign end interface interface operator(==) module procedure ftuple_equal end interface interface operator(>) module procedure ftuple_greater end interface interface operator(<) module procedure ftuple_less end interface <>= pure subroutine ftuple_assign (ftuple_out, ftuple_in) type(ftuple_t), intent(out) :: ftuple_out type(ftuple_t), intent(in) :: ftuple_in ftuple_out%ireg = ftuple_in%ireg ftuple_out%i_res = ftuple_in%i_res ftuple_out%splitting_type = ftuple_in%splitting_type ftuple_out%pseudo_isr = ftuple_in%pseudo_isr ftuple_out%qcd_split = ftuple_in%qcd_split end subroutine ftuple_assign @ %def ftuple_assign @ <>= elemental function ftuple_equal (f1, f2) result (value) logical :: value type(ftuple_t), intent(in) :: f1, f2 value = all (f1%ireg == f2%ireg) .and. f1%i_res == f2%i_res & .and. f1%splitting_type == f2%splitting_type & .and. (f1%pseudo_isr .eqv. f2%pseudo_isr) & .and. (f1%qcd_split .eqv. f2%qcd_split) end function ftuple_equal @ %def ftuple_equal @ <>= elemental function ftuple_equal_ireg (f1, f2) result (value) logical :: value type(ftuple_t), intent(in) :: f1, f2 value = all (f1%ireg == f2%ireg) end function ftuple_equal_ireg @ %def ftuple_equal_ireg @ <>= elemental function ftuple_greater (f1, f2) result (greater) logical :: greater type(ftuple_t), intent(in) :: f1, f2 if (f1%ireg(1) == f2%ireg(1)) then greater = f1%ireg(2) > f2%ireg(2) else greater = f1%ireg(1) > f2%ireg(1) end if end function ftuple_greater @ %def ftuple_greater @ <>= elemental function ftuple_less (f1, f2) result (less) logical :: less type(ftuple_t), intent(in) :: f1, f2 if (f1%ireg(1) == f2%ireg(1)) then less = f1%ireg(2) < f2%ireg(2) else less = f1%ireg(1) < f2%ireg(1) end if end function ftuple_less @ %def ftuple_less <>= subroutine ftuple_sort_array (ftuple_array, equivalences) type(ftuple_t), intent(inout), dimension(:), allocatable :: ftuple_array logical, intent(inout), dimension(:,:), allocatable :: equivalences type(ftuple_t) :: ftuple_tmp logical, dimension(:), allocatable :: eq_tmp integer :: i1, i2, n n = size (ftuple_array) allocate (eq_tmp (n)) do i1 = 2, n i2 = i1 do while (ftuple_array(i2 - 1) > ftuple_array(i2)) ftuple_tmp = ftuple_array(i2 - 1) eq_tmp = equivalences(i2, :) ftuple_array(i2 - 1) = ftuple_array(i2) ftuple_array(i2) = ftuple_tmp equivalences(i2 - 1, :) = equivalences(i2, :) equivalences(i2, :) = eq_tmp i2 = i2 - 1 if (i2 == 1) exit end do end do end subroutine ftuple_sort_array @ %def ftuple_sort_array @ <>= procedure :: write => ftuple_write <>= subroutine ftuple_write (ftuple, unit, newline) class(ftuple_t), intent(in) :: ftuple integer, intent(in), optional :: unit logical, intent(in), optional :: newline integer :: u logical :: nl u = given_output_unit (unit); if (u < 0) return nl = .true.; if (present(newline)) nl = newline if (all (ftuple%ireg > -1)) then if (ftuple%i_res > 0) then if (nl) then write (u, "(A1,I1,A1,I1,A1,I1,A1)") & '(', ftuple%ireg(1), ',', ftuple%ireg(2), ';', ftuple%i_res, ')' else write (u, "(A1,I1,A1,I1,A1,I1,A1)", advance = "no") & '(', ftuple%ireg(1), ',', ftuple%ireg(2), ';', ftuple%i_res, ')' end if else if (nl) then write (u, "(A1,I1,A1,I1,A1)") & '(', ftuple%ireg(1), ',', ftuple%ireg(2), ')' else write (u, "(A1,I1,A1,I1,A1)", advance = "no") & '(', ftuple%ireg(1), ',', ftuple%ireg(2), ')' end if end if else write (u, "(A)") "(Empty)" end if end subroutine ftuple_write @ %def ftuple_write @ <>= function ftuple_string (ftuples, latex) type(string_t) :: ftuple_string type(ftuple_t), intent(in), dimension(:) :: ftuples logical, intent(in) :: latex integer :: i, nreg if (latex) then ftuple_string = var_str ("$\left\{") else ftuple_string = var_str ("{") end if nreg = size(ftuples) do i = 1, nreg if (ftuples(i)%i_res == 0) then ftuple_string = ftuple_string // var_str ("(") // & str (ftuples(i)%ireg(1)) // var_str (",") // & str (ftuples(i)%ireg(2)) // var_str (")") else ftuple_string = ftuple_string // var_str ("(") // & str (ftuples(i)%ireg(1)) // var_str (",") // & str (ftuples(i)%ireg(2)) // var_str (";") // & str (ftuples(i)%i_res) // var_str (")") end if if (ftuples(i)%pseudo_isr) ftuple_string = ftuple_string // var_str ("*") if (i < nreg) ftuple_string = ftuple_string // var_str (",") end do if (latex) then ftuple_string = ftuple_string // var_str ("\right\}$") else ftuple_string = ftuple_string // var_str ("}") end if end function ftuple_string @ %def ftuple_string @ <>= procedure :: get => ftuple_get <>= subroutine ftuple_get (ftuple, pos1, pos2) class(ftuple_t), intent(in) :: ftuple integer, intent(out) :: pos1, pos2 pos1 = ftuple%ireg(1) pos2 = ftuple%ireg(2) end subroutine ftuple_get @ %def ftuple_get @ <>= procedure :: set => ftuple_set <>= subroutine ftuple_set (ftuple, pos1, pos2) class(ftuple_t), intent(inout) :: ftuple integer, intent(in) :: pos1, pos2 ftuple%ireg(1) = pos1 ftuple%ireg(2) = pos2 end subroutine ftuple_set @ %def ftuple_set @ Determines the splitting type for FSR. There are three different types of splittings relevant here: $g \to gg$ tagged [[V_TO_VV]], $g \to qq$ tagged [[V_TO_FF]] and $q \to qg$ tagged [[F_TO_FV]]. For FSR, there is no need to differentiate between $q \to qg$ and $q \to gq$ splittings. <>= procedure :: determine_splitting_type_fsr => ftuple_determine_splitting_type_fsr <>= subroutine ftuple_determine_splitting_type_fsr (ftuple, flv, i, j) class(ftuple_t), intent(inout) :: ftuple type(flv_structure_t), intent(in) :: flv integer, intent(in) :: i, j associate (flst => flv%flst) if (is_vector (flst(i)) .and. is_vector (flst(j))) then ftuple%splitting_type = V_TO_VV else if (flst(i)+flst(j) == 0 & .and. is_fermion (flst(i))) then ftuple%splitting_type = V_TO_FF else if (is_fermion(flst(i)) .and. is_massless_vector (flst(j)) & .or. is_fermion(flst(j)) .and. is_massless_vector (flst(i))) then ftuple%splitting_type = F_TO_FV else ftuple%splitting_type = UNDEFINED_SPLITTING end if end associate end subroutine ftuple_determine_splitting_type_fsr @ %def ftuple_determine_splitting_type_fsr @ Determines the splitting type for ISR. There are four different types of splittings relevant here: $g \to gg$ tagged [[V_TO_VV]], $g \to qq$ tagged [[V_TO_FF]], $q \to qg$ tagged [[F_TO_FV]] and $q \to gq$ tagged [[F_TO_VF]]. The latter two need to be considered separately for ISR as they differ with respect to which particle enters the hard process. A splitting [[F_TO_FV]] may lead to soft divergences while [[F_TO_VF]] does not.\\ We also want to emphasize that the splitting type naming convention for ISR names the splittings considering backwards evolution. So in the splitting [[V_TO_FF]], it is the \textit{gluon} that enteres the hard process!\\ Special treatment here is required if emitter $0$ is assigned. This is the case only when a gluon was radiated from any of the IS particles. In this case, both splittings are soft divergent so we can equivalently choose $1$ or $2$ as the emitter here even if both have different flavors. <>= procedure :: determine_splitting_type_isr => ftuple_determine_splitting_type_isr <>= subroutine ftuple_determine_splitting_type_isr (ftuple, flv, i, j) class(ftuple_t), intent(inout) :: ftuple type(flv_structure_t), intent(in) :: flv integer, intent(in) :: i, j integer :: em em = i; if (i == 0) em = 1 associate (flst => flv%flst) if (is_vector (flst(em)) .and. is_vector (flst(j))) then ftuple%splitting_type = V_TO_VV else if (is_massless_vector(flst(em)) .and. is_fermion(flst(j))) then ftuple%splitting_type = F_TO_VF else if (is_fermion(flst(em)) .and. is_massless_vector(flst(j))) then ftuple%splitting_type = F_TO_FV else if (is_fermion(flst(em)) .and. is_fermion(flst(j))) then ftuple%splitting_type = V_TO_FF else ftuple%splitting_type = UNDEFINED_SPLITTING end if end associate end subroutine ftuple_determine_splitting_type_isr @ %def ftuple_determine_splitting_type_isr <>= procedure :: determine_sub_correction_type => ftuple_determine_sub_correction_type <>= subroutine ftuple_determine_sub_correction_type (ftuple, flv_born, flv_real, i, j) class(ftuple_t), intent(inout) :: ftuple type(flv_structure_t), intent(in) :: flv_born, flv_real type(flv_structure_t) :: flv_test_qcd integer, intent(in) :: i, j integer :: em em = i; if (i == 0) em = 1 select case (ftuple%splitting_type) case (V_TO_VV) ftuple%qcd_split = is_gluon (flv_real%flst(em)) .and. is_gluon (flv_real%flst(j)) case (F_TO_VF) ftuple%qcd_split = is_gluon (flv_real%flst(em)) case (F_TO_FV) if (i == 0) then ftuple%qcd_split = is_gluon (flv_real%flst(j)) else ftuple%qcd_split = is_gluon (flv_real%flst(i)) .or. is_gluon (flv_real%flst(j)) end if case (V_TO_FF) if (any ([i, j] <= flv_real%n_in)) then flv_test_qcd = flv_real%insert_particle_isr (i, j, GLUON) else flv_test_qcd = flv_real%insert_particle_fsr (i, j, GLUON) end if ftuple%qcd_split = flv_test_qcd .equiv. flv_born case (UNDEFINED_SPLITTING) ftuple%qcd_split = .false. end select end subroutine ftuple_determine_sub_correction_type @ %def ftuple_determine_sub_correction_type @ Two debug functions to check the consistency of [[ftuples]] <>= procedure :: has_negative_elements => ftuple_has_negative_elements procedure :: has_identical_elements => ftuple_has_identical_elements <>= elemental function ftuple_has_negative_elements (ftuple) result (value) logical :: value class(ftuple_t), intent(in) :: ftuple value = any (ftuple%ireg < 0) end function ftuple_has_negative_elements elemental function ftuple_has_identical_elements (ftuple) result (value) logical :: value class(ftuple_t), intent(in) :: ftuple value = ftuple%ireg(1) == ftuple%ireg(2) end function ftuple_has_identical_elements @ %def ftuple_has_negative_elements, ftuple_has_identical_elements @ Each singular region can have a different number of emitter-radiation pairs. This is coped with using the linked list [[ftuple_list]]. <>= type :: ftuple_list_t integer :: index = 0 type(ftuple_t) :: ftuple type(ftuple_list_t), pointer :: next => null () type(ftuple_list_t), pointer :: prev => null () type(ftuple_list_t), pointer :: equiv => null () contains <> end type ftuple_list_t @ %def ftuple_list_t @ <>= procedure :: write => ftuple_list_write <>= subroutine ftuple_list_write (list, unit, verbose) class(ftuple_list_t), intent(in), target :: list integer, intent(in), optional :: unit logical, intent(in), optional :: verbose type(ftuple_list_t), pointer :: current logical :: verb integer :: u u = given_output_unit (unit); if (u < 0) return verb = .false.; if (present (verbose)) verb = verbose select type (list) type is (ftuple_list_t) current => list do call current%ftuple%write (unit = u, newline = .false.) if (verb .and. associated (current%equiv)) write (u, '(A)', advance = "no") "'" if (associated (current%next)) then current => current%next else exit end if end do write (u, *) "" end select end subroutine ftuple_list_write @ %def ftuple_list_write @ <>= procedure :: append => ftuple_list_append <>= subroutine ftuple_list_append (list, ftuple) class(ftuple_list_t), intent(inout), target :: list type(ftuple_t), intent(in) :: ftuple type(ftuple_list_t), pointer :: current select type (list) type is (ftuple_list_t) if (list%index == 0) then nullify (list%next) list%index = 1 list%ftuple = ftuple else current => list do if (associated (current%next)) then current => current%next else allocate (current%next) nullify (current%next%next) nullify (current%next%equiv) current%next%prev => current current%next%index = current%index + 1 current%next%ftuple = ftuple exit end if end do end if end select end subroutine ftuple_list_append @ %def ftuple_list_append @ <>= procedure :: get_n_tuples => ftuple_list_get_n_tuples <>= impure elemental function ftuple_list_get_n_tuples (list) result(n_tuples) integer :: n_tuples class(ftuple_list_t), intent(in), target :: list type(ftuple_list_t), pointer :: current n_tuples = 0 select type (list) type is (ftuple_list_t) current => list if (current%index > 0) then n_tuples = 1 do if (associated (current%next)) then current => current%next n_tuples = n_tuples + 1 else exit end if end do end if end select end function ftuple_list_get_n_tuples @ %def ftuple_list_get_n_tuples @ <>= procedure :: get_entry => ftuple_list_get_entry <>= function ftuple_list_get_entry (list, index) result (entry) type(ftuple_list_t), pointer :: entry class(ftuple_list_t), intent(in), target :: list integer, intent(in) :: index type(ftuple_list_t), pointer :: current integer :: i entry => null() select type (list) type is (ftuple_list_t) current => list if (index == 1) then entry => current else do i = 1, index - 1 current => current%next end do entry => current end if end select end function ftuple_list_get_entry @ %def ftuple_list_get_entry @ <>= procedure :: get_ftuple => ftuple_list_get_ftuple <>= function ftuple_list_get_ftuple (list, index) result (ftuple) type(ftuple_t) :: ftuple class(ftuple_list_t), intent(in), target :: list integer, intent(in) :: index type(ftuple_list_t), pointer :: entry entry => list%get_entry (index) ftuple = entry%ftuple end function ftuple_list_get_ftuple @ %def ftuple_list_get_ftuple @ <>= procedure :: set_equiv => ftuple_list_set_equiv <>= subroutine ftuple_list_set_equiv (list, i1, i2) class(ftuple_list_t), intent(in) :: list integer, intent(in) :: i1, i2 type(ftuple_list_t), pointer :: list1, list2 => null () select type (list) type is (ftuple_list_t) if (list%get_ftuple (i1) > list%get_ftuple (i2)) then list1 => list%get_entry (i2) list2 => list%get_entry (i1) else list1 => list%get_entry (i1) list2 => list%get_entry (i2) end if do if (associated (list1%equiv)) then list1 => list1%equiv else exit end if end do list1%equiv => list2 end select end subroutine ftuple_list_set_equiv @ %def ftuple_list_set_equiv @ <>= procedure :: check_equiv => ftuple_list_check_equiv <>= function ftuple_list_check_equiv(list, i1, i2) result(eq) class(ftuple_list_t), intent(in) :: list integer, intent(in) :: i1, i2 logical :: eq type(ftuple_list_t), pointer :: current eq = .false. select type (list) type is (ftuple_list_t) current => list%get_entry (i1) do if (associated (current%equiv)) then current => current%equiv if (current%index == i2) then eq = .true. exit end if else exit end if end do end select end function ftuple_list_check_equiv @ %def ftuple_list_sort @ <>= procedure :: to_array => ftuple_list_to_array <>= subroutine ftuple_list_to_array (ftuple_list, ftuple_array, equivalences, ordered) class(ftuple_list_t), intent(in), target :: ftuple_list type(ftuple_t), intent(out), dimension(:), allocatable :: ftuple_array logical, intent(out), dimension(:,:), allocatable :: equivalences logical, intent(in) :: ordered integer :: i_tuple, n type(ftuple_list_t), pointer :: current => null () integer :: i1, i2 type(ftuple_t) :: ftuple_tmp logical, dimension(:), allocatable :: eq_tmp n = ftuple_list%get_n_tuples () allocate (ftuple_array (n), equivalences (n, n)) equivalences = .false. select type (ftuple_list) type is (ftuple_list_t) current => ftuple_list i_tuple = 1 do ftuple_array(i_tuple) = current%ftuple if (associated (current%equiv)) then i1 = current%index i2 = current%equiv%index equivalences (i1, i2) = .true. end if if (associated (current%next)) then current => current%next i_tuple = i_tuple + 1 else exit end if end do end select if (ordered) call ftuple_sort_array (ftuple_array, equivalences) end subroutine ftuple_list_to_array @ %def ftuple_list_to_array @ <>= subroutine print_equivalence_matrix (ftuple_array, equivalences) type(ftuple_t), intent(in), dimension(:) :: ftuple_array logical, intent(in), dimension(:,:) :: equivalences integer :: i, i1, i2 print *, 'Equivalence matrix: ' do i = 1, size (ftuple_array) call ftuple_array(i)%get(i1,i2) print *, 'i: ', i, '(', i1, i2, '): ', equivalences(i,:) end do end subroutine print_equivalence_matrix @ %def print_equivalence_matrix @ Class for working with the flavor specification arrays. <>= public :: flv_structure_t <>= type :: flv_structure_t integer, dimension(:), allocatable :: flst integer, dimension(:), allocatable :: tag integer :: nlegs = 0 integer :: n_in = 0 logical, dimension(:), allocatable :: massive logical, dimension(:), allocatable :: colored real(default), dimension(:), allocatable :: charge real(default) :: prt_symm_fs = 1._default integer :: eqv_index = 0 contains <> end type flv_structure_t @ %def flv_structure_t @ Returns \texttt{true} if the two particles at position \texttt{i} and \texttt{j} in the flavor array can originate from the same splitting. For this purpose, the function first checks whether the splitting is allowed at all. If this is the case, the emitter is removed from the flavor array. If the resulting array is equivalent to the Born flavor structure \texttt{flv\_born}, the pair is accepted as a valid splitting. We first check whether the splitting is possible. The array [[flv_orig]] contains all particles which share a vertex with the particles at position [[i]] and [[j]]. If any of these particles belongs to the initial state, a PDG-ID flip is necessary to correctly recognize the vertex. If its size is equal to zero, no splitting is possible and the subroutine is exited. Otherwise, we loop over all possible underlying Born flavor structures and check if any of them equals the actual underlying Born flavor structure. For a quark emitting a gluon, [[flv_orig]] contains the PDG code of the anti-quark. To be on the safe side, a second array is created, which contains both the positively and negatively signed PDG codes. Then, the origial tuple $(i,j)$ is removed from the real flavor structure and the particles in [[flv_orig2]] are inserted. If the resulting Born configuration is equal to the underlying Born configuration, up to a permutation of final-state particles, the tuple $(i,j)$ is accepted as valid. <>= procedure :: valid_pair => flv_structure_valid_pair <>= function flv_structure_valid_pair & (flv, i, j, flv_ref, model) result (valid) logical :: valid class(flv_structure_t), intent(in) :: flv integer, intent(in) :: i,j type(flv_structure_t), intent(in) :: flv_ref type(model_t), intent(in) :: model integer :: k, n_orig type(flv_structure_t) :: flv_test integer, dimension(:), allocatable :: flv_orig valid = .false. if (all ([i, j] <= flv%n_in)) return if (i <= flv%n_in .and. is_fermion(flv%flst(i))) then call model%match_vertex (-flv%flst(i), flv%flst(j), flv_orig) else if (j <= flv%n_in .and. is_fermion(flv%flst(j))) then call model%match_vertex (flv%flst(i), -flv%flst(j), flv_orig) else call model%match_vertex (flv%flst(i), flv%flst(j), flv_orig) end if n_orig = size (flv_orig) if (n_orig == 0) then return else do k = 1, n_orig if (any ([i, j] <= flv%n_in)) then flv_test = flv%insert_particle_isr (i, j, flv_orig(k)) else flv_test = flv%insert_particle_fsr (i, j, flv_orig(k)) end if valid = flv_ref .equiv. flv_test call flv_test%final () if (valid) return end do end if deallocate (flv_orig) end function flv_structure_valid_pair @ %def flv_structure_valid_pair @ This function checks whether two flavor arrays are the same up to a permutation of the final-state particles <>= function flv_structure_equivalent (flv1, flv2, with_tag) result(equiv) logical :: equiv type(flv_structure_t), intent(in) :: flv1, flv2 logical, intent(in) :: with_tag type(flavor_permutation_t) :: perm integer :: n n = size (flv1%flst) equiv = .true. if (n /= size (flv2%flst)) then call msg_fatal & ('flv_structure_equivalent: flavor arrays do not have equal lengths') else if (flv1%n_in /= flv2%n_in) then call msg_fatal & ('flv_structure_equivalent: flavor arrays do not have equal n_in') else call perm%init (flv1, flv2, flv1%n_in, flv1%nlegs, with_tag) equiv = perm%test (flv2, flv1, with_tag) call perm%final () end if end function flv_structure_equivalent @ %def flv_structure_equivalent @ <>= function flv_structure_equivalent_no_tag (flv1, flv2) result(equiv) logical :: equiv type(flv_structure_t), intent(in) :: flv1, flv2 equiv = flv_structure_equivalent (flv1, flv2, .false.) end function flv_structure_equivalent_no_tag function flv_structure_equivalent_with_tag (flv1, flv2) result(equiv) logical :: equiv type(flv_structure_t), intent(in) :: flv1, flv2 equiv = flv_structure_equivalent (flv1, flv2, .true.) end function flv_structure_equivalent_with_tag @ %def flv_structure_equivalent_no_tag, flv_structure_equivalent_with_tag @ <>= pure subroutine flv_structure_assign_flv (flv_out, flv_in) type(flv_structure_t), intent(out) :: flv_out type(flv_structure_t), intent(in) :: flv_in flv_out%nlegs = flv_in%nlegs flv_out%n_in = flv_in%n_in flv_out%prt_symm_fs = flv_in%prt_symm_fs if (allocated (flv_in%flst)) then allocate (flv_out%flst (size (flv_in%flst))) flv_out%flst = flv_in%flst end if if (allocated (flv_in%tag)) then allocate (flv_out%tag (size (flv_in%tag))) flv_out%tag = flv_in%tag end if if (allocated (flv_in%massive)) then allocate (flv_out%massive (size (flv_in%massive))) flv_out%massive = flv_in%massive end if if (allocated (flv_in%colored)) then allocate (flv_out%colored (size (flv_in%colored))) flv_out%colored = flv_in%colored end if end subroutine flv_structure_assign_flv @ %def flv_structure_assign_flv @ <>= pure subroutine flv_structure_assign_integer (flv_out, iarray) type(flv_structure_t), intent(out) :: flv_out integer, intent(in), dimension(:) :: iarray integer :: i flv_out%nlegs = size (iarray) allocate (flv_out%flst (flv_out%nlegs)) allocate (flv_out%tag (flv_out%nlegs)) flv_out%flst = iarray flv_out%tag = [(i, i = 1, flv_out%nlegs)] end subroutine flv_structure_assign_integer @ %def flv_structure_assign_integer @ Returs a new flavor array with the particle at position \texttt{index} removed. <>= procedure :: remove_particle => flv_structure_remove_particle <>= function flv_structure_remove_particle (flv, index) result(flv_new) type(flv_structure_t) :: flv_new class(flv_structure_t), intent(in) :: flv integer, intent(in) :: index integer :: n1, n2 integer :: i, removed_tag n1 = size (flv%flst); n2 = n1 - 1 allocate (flv_new%flst (n2), flv_new%tag (n2)) flv_new%nlegs = n2 flv_new%n_in = flv%n_in removed_tag = flv%tag(index) if (index == 1) then flv_new%flst(1 : n2) = flv%flst(2 : n1) flv_new%tag(1 : n2) = flv%tag(2 : n1) else if (index == n1) then flv_new%flst(1 : n2) = flv%flst(1 : n2) flv_new%tag(1 : n2) = flv%tag(1 : n2) else flv_new%flst(1 : index - 1) = flv%flst(1 : index - 1) flv_new%flst(index : n2) = flv%flst(index + 1 : n1) flv_new%tag(1 : index - 1) = flv%tag(1 : index - 1) flv_new%tag(index : n2) = flv%tag(index + 1 : n1) end if do i = 1, n2 if (flv_new%tag(i) > removed_tag) & flv_new%tag(i) = flv_new%tag(i) - 1 end do call flv_new%compute_prt_symm_fs (flv_new%n_in) end function flv_structure_remove_particle @ %def flv_structure_remove_particle @ Removes the particles at position i1 and i2 and inserts a new particle of matching flavor at position i1. <>= procedure :: insert_particle_fsr => flv_structure_insert_particle_fsr <>= function flv_structure_insert_particle_fsr (flv, i1, i2, flv_add) result (flv_new) type(flv_structure_t) :: flv_new class(flv_structure_t), intent(in) :: flv integer, intent(in) :: i1, i2, flv_add if (flv%flst(i1) + flv_add == 0 .or. flv%flst(i2) + flv_add == 0) then flv_new = flv%insert_particle (i1, i2, -flv_add) else flv_new = flv%insert_particle (i1, i2, flv_add) end if end function flv_structure_insert_particle_fsr @ %def flv_structure_insert_particle_fsr @ Same as [[insert_particle_fsr]] but for ISR, the two particles are not exchangable. <>= procedure :: insert_particle_isr => flv_structure_insert_particle_isr <>= function flv_structure_insert_particle_isr (flv, i_in, i_out, flv_add) result (flv_new) type(flv_structure_t) :: flv_new class(flv_structure_t), intent(in) :: flv integer, intent(in) :: i_in, i_out, flv_add if (flv%flst(i_in) + flv_add == 0) then flv_new = flv%insert_particle (i_in, i_out, -flv_add) else flv_new = flv%insert_particle (i_in, i_out, flv_add) end if end function flv_structure_insert_particle_isr @ %def flv_structure_insert_particle_isr @ Removes the particles at position i1 and i2 and inserts a new particle at position i1. <>= procedure :: insert_particle => flv_structure_insert_particle <>= function flv_structure_insert_particle (flv, i1, i2, particle) result (flv_new) type(flv_structure_t) :: flv_new class(flv_structure_t), intent(in) :: flv integer, intent(in) :: i1, i2, particle type(flv_structure_t) :: flv_tmp integer :: n1, n2 integer :: new_tag n1 = size (flv%flst); n2 = n1 - 1 allocate (flv_new%flst (n2), flv_new%tag (n2)) flv_new%nlegs = n2 flv_new%n_in = flv%n_in new_tag = maxval(flv%tag) + 1 if (i1 < i2) then flv_tmp = flv%remove_particle (i1) flv_tmp = flv_tmp%remove_particle (i2 - 1) else if(i2 < i1) then flv_tmp = flv%remove_particle(i2) flv_tmp = flv_tmp%remove_particle(i1 - 1) else call msg_fatal ("flv_structure_insert_particle: Indices are identical!") end if if (i1 == 1) then flv_new%flst(1) = particle flv_new%flst(2 : n2) = flv_tmp%flst(1 : n2 - 1) flv_new%tag(1) = new_tag flv_new%tag(2 : n2) = flv_tmp%tag(1 : n2 - 1) else if (i1 == n1 .or. i1 == n2) then flv_new%flst(1 : n2 - 1) = flv_tmp%flst(1 : n2 - 1) flv_new%flst(n2) = particle flv_new%tag(1 : n2 - 1) = flv_tmp%tag(1 : n2 - 1) flv_new%tag(n2) = new_tag else flv_new%flst(1 : i1 - 1) = flv_tmp%flst(1 : i1 - 1) flv_new%flst(i1) = particle flv_new%flst(i1 + 1 : n2) = flv_tmp%flst(i1 : n2 - 1) flv_new%tag(1 : i1 - 1) = flv_tmp%tag(1 : i1 - 1) flv_new%tag(i1) = new_tag flv_new%tag(i1 + 1 : n2) = flv_tmp%tag(i1 : n2 - 1) end if call flv_new%compute_prt_symm_fs (flv_new%n_in) end function flv_structure_insert_particle @ %def flv_structure_insert_particle @ Counts the number of occurances of a particle in a flavor array <>= procedure :: count_particle => flv_structure_count_particle <>= function flv_structure_count_particle (flv, part) result (n) class(flv_structure_t), intent(in) :: flv integer, intent(in) :: part integer :: n n = count (flv%flst == part) end function flv_structure_count_particle @ %def flv_structure_count_particle @ Initializer for flavor structures <>= procedure :: init => flv_structure_init <>= subroutine flv_structure_init (flv, aval, n_in, tags) class(flv_structure_t), intent(inout) :: flv integer, intent(in), dimension(:) :: aval integer, intent(in) :: n_in integer, intent(in), dimension(:), optional :: tags integer :: i, n integer, dimension(:), allocatable :: aval_unique integer, dimension(:), allocatable :: mult n = size (aval) allocate (flv%flst (n), flv%tag (n)) flv%flst = aval if (present (tags)) then flv%tag = tags else do i = 1, n flv%tag(i) = i end do end if flv%nlegs = n flv%n_in = n_in call flv%compute_prt_symm_fs (flv%n_in) end subroutine flv_structure_init @ %def flv_structure_init @ <>= procedure :: compute_prt_symm_fs => flv_structure_compute_prt_symm_fs <>= subroutine flv_structure_compute_prt_symm_fs (flv, n_in) class(flv_structure_t), intent(inout) :: flv integer, intent(in) :: n_in integer, dimension(:), allocatable :: flst_unique integer, dimension(:), allocatable :: mult integer :: i flst_unique = remove_duplicates_from_int_array (flv%flst(n_in + 1 :)) allocate (mult(size (flst_unique))) do i = 1, size (flst_unique) mult(i) = count (flv%flst(n_in + 1 :) == flst_unique(i)) end do flv%prt_symm_fs = one / product (gamma (real (mult + 1, default))) end subroutine flv_structure_compute_prt_symm_fs @ %def flv_structure_compute_prt_symm_fs @ <>= procedure :: write => flv_structure_write <>= subroutine flv_structure_write (flv, unit) class(flv_structure_t), intent(in) :: flv integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, '(A)') char (flv%to_string ()) end subroutine flv_structure_write @ %def flv_structure_write @ <>= procedure :: to_string => flv_structure_to_string <>= function flv_structure_to_string (flv) result (flv_string) type(string_t) :: flv_string class(flv_structure_t), intent(in) :: flv integer :: i, n if (allocated (flv%flst)) then flv_string = var_str ("[") n = size (flv%flst) do i = 1, n - 1 flv_string = flv_string // str (flv%flst(i)) // var_str(",") end do flv_string = flv_string // str (flv%flst(n)) // var_str("]") else flv_string = var_str ("[not allocated]") end if end function flv_structure_to_string @ %def flv_structure_to_string @ Creates the underlying Born flavor structure for a given real flavor structure if the particle at position \texttt{emitter} is removed <>= procedure :: create_uborn => flv_structure_create_uborn <>= function flv_structure_create_uborn (flv, emitter, nlo_correction_type) result(flv_uborn) type(flv_structure_t) :: flv_uborn class(flv_structure_t), intent(in) :: flv type(string_t), intent(in) :: nlo_correction_type integer, intent(in) :: emitter integer n_legs integer :: f1, f2 integer :: gauge_boson n_legs = size(flv%flst) allocate (flv_uborn%flst (n_legs - 1), flv_uborn%tag (n_legs - 1)) gauge_boson = determine_gauge_boson_to_be_inserted () if (emitter > flv%n_in) then f1 = flv%flst(n_legs); f2 = flv%flst(n_legs - 1) if (is_massless_vector (f1)) then !!! Emitted particle is a gluon or photon => just remove it flv_uborn = flv%remove_particle(n_legs) else if (is_fermion (f1) .and. is_fermion (f2) .and. f1 + f2 == 0) then !!! Emission type is a gauge boson splitting into two fermions flv_uborn = flv%insert_particle(n_legs - 1, n_legs, gauge_boson) else call msg_error ("Create underlying Born: Unsupported splitting type.") call msg_error (char (str (flv%flst))) call msg_fatal ("FKS - FAIL") end if else if (emitter > 0) then f1 = flv%flst(n_legs); f2 = flv%flst(emitter) if (is_massless_vector (f1)) then flv_uborn = flv%remove_particle(n_legs) else if (is_fermion (f1) .and. is_massless_vector (f2)) then flv_uborn = flv%insert_particle (emitter, n_legs, -f1) else if (is_fermion (f1) .and. is_fermion (f2) .and. f1 == f2) then flv_uborn = flv%insert_particle(emitter, n_legs, gauge_boson) end if else flv_uborn = flv%remove_particle (n_legs) end if contains integer function determine_gauge_boson_to_be_inserted () select case (char (nlo_correction_type)) case ("QCD") determine_gauge_boson_to_be_inserted = GLUON case ("EW") determine_gauge_boson_to_be_inserted = PHOTON case ("Full") call msg_fatal ("NLO correction type 'Full' not yet implemented!") case default call msg_fatal ("Invalid NLO correction type! Valid inputs are: QCD, EW and Full (default: QCD)") end select end function determine_gauge_boson_to_be_inserted end function flv_structure_create_uborn @ %def flv_structure_create_uborn @ <>= procedure :: init_mass_color_and_charge => flv_structure_init_mass_color_and_charge <>= subroutine flv_structure_init_mass_color_and_charge (flv, model) class(flv_structure_t), intent(inout) :: flv type(model_t), intent(in) :: model integer :: i type(flavor_t) :: flavor allocate (flv%massive (flv%nlegs), flv%colored(flv%nlegs), flv%charge(flv%nlegs)) do i = 1, flv%nlegs call flavor%init (flv%flst(i), model) flv%massive(i) = flavor%get_mass () > 0 flv%colored(i) = & is_quark (flv%flst(i)) .or. is_gluon (flv%flst(i)) flv%charge(i) = flavor%get_charge () end do end subroutine flv_structure_init_mass_color_and_charge @ %def flv_structure_init_mass_color_and_charge @ <>= procedure :: get_last_two => flv_structure_get_last_two <>= function flv_structure_get_last_two (flv, n) result (flst_last) integer, dimension(2) :: flst_last class(flv_structure_t), intent(in) :: flv integer, intent(in) :: n flst_last = [flv%flst(n - 1), flv%flst(n)] end function flv_structure_get_last_two @ %def flv_structure_get_last_two @ <>= procedure :: final => flv_structure_final <>= subroutine flv_structure_final (flv) class(flv_structure_t), intent(inout) :: flv if (allocated (flv%flst)) deallocate (flv%flst) if (allocated (flv%tag)) deallocate (flv%tag) if (allocated (flv%massive)) deallocate (flv%massive) if (allocated (flv%colored)) deallocate (flv%colored) if (allocated (flv%charge)) deallocate (flv%charge) end subroutine flv_structure_final @ %def flv_structure_final @ <>= public :: flavor_permutation_t <>= type :: flavor_permutation_t integer, dimension(:,:), allocatable :: perms contains <> end type flavor_permutation_t @ %def flavor_permutation_t @ <>= procedure :: init => flavor_permutation_init <>= subroutine flavor_permutation_init (perm, flv_in, flv_ref, n_first, n_last, with_tag) class(flavor_permutation_t), intent(out) :: perm type(flv_structure_t), intent(in) :: flv_in, flv_ref integer, intent(in) :: n_first, n_last logical, intent(in) :: with_tag integer :: flv1, flv2, tmp integer :: tag1, tag2 integer :: i, j, j_min, i_perm integer, dimension(:,:), allocatable :: perm_list_tmp type(flv_structure_t) :: flv_copy logical :: condition logical, dimension(:), allocatable :: already_correct flv_copy = flv_in allocate (perm_list_tmp (factorial (n_last - n_first - 1), 2)) allocate (already_correct (flv_in%nlegs)) already_correct = flv_in%flst == flv_ref%flst if (with_tag) & already_correct = already_correct .and. (flv_in%tag == flv_ref%tag) j_min = n_first + 1 i_perm = 0 do i = n_first + 1, n_last flv1 = flv_ref%flst(i) tag1 = flv_ref%tag(i) do j = j_min, n_last if (already_correct(i) .or. already_correct(j)) cycle flv2 = flv_copy%flst(j) tag2 = flv_copy%tag(j) condition = (flv1 == flv2) .and. i /= j if (with_tag) condition = condition .and. (tag1 == tag2) if (condition) then i_perm = i_perm + 1 tmp = flv_copy%flst(i) flv_copy%flst(i) = flv2 flv_copy%flst(j) = tmp tmp = flv_copy%tag(i) flv_copy%tag(i) = tag2 flv_copy%tag(j) = tmp perm_list_tmp (i_perm, 1) = i perm_list_tmp (i_perm, 2) = j exit end if end do j_min = j_min + 1 end do allocate (perm%perms (i_perm, 2)) perm%perms = perm_list_tmp (1 : i_perm, :) deallocate (perm_list_tmp) call flv_copy%final () end subroutine flavor_permutation_init @ %def flavor_permutation_init @ <>= procedure :: write => flavor_permutation_write <>= subroutine flavor_permutation_write (perm, unit) class(flavor_permutation_t), intent(in) :: perm integer, intent(in), optional :: unit integer :: i, n, u u = given_output_unit (unit); if (u < 0) return write (u, "(A)") "Flavor permutation list: " n = size (perm%perms, dim = 1) if (n > 0) then do i = 1, n write (u, "(A1,I1,1X,I1,A1)", advance = "no") "[", perm%perms(i,1), perm%perms(i,2), "]" if (i < n) write (u, "(A4)", advance = "no") " // " end do write (u, "(A)") "" else write (u, "(A)") "[Empty]" end if end subroutine flavor_permutation_write @ %def flavor_permutation_write @ <>= procedure :: reset => flavor_permutation_final procedure :: final => flavor_permutation_final <>= subroutine flavor_permutation_final (perm) class(flavor_permutation_t), intent(inout) :: perm if (allocated (perm%perms)) deallocate (perm%perms) end subroutine flavor_permutation_final @ %def flavor_permutation_final @ <>= generic :: apply => apply_permutation, & apply_flavor, apply_integer, apply_ftuple procedure :: apply_permutation => flavor_permutation_apply_permutation procedure :: apply_flavor => flavor_permutation_apply_flavor procedure :: apply_integer => flavor_permutation_apply_integer procedure :: apply_ftuple => flavor_permutation_apply_ftuple <>= elemental function flavor_permutation_apply_permutation (perm_1, perm_2) & result (perm_out) type(flavor_permutation_t) :: perm_out class(flavor_permutation_t), intent(in) :: perm_1 type(flavor_permutation_t), intent(in) :: perm_2 integer :: n1, n2 n1 = size (perm_1%perms, dim = 1) n2 = size (perm_2%perms, dim = 1) allocate (perm_out%perms (n1 + n2, 2)) perm_out%perms (1 : n1, :) = perm_1%perms perm_out%perms (n1 + 1: n1 + n2, :) = perm_2%perms end function flavor_permutation_apply_permutation @ %def flavor_permutation_apply_permutation @ <>= elemental function flavor_permutation_apply_flavor (perm, flv_in, invert) & result (flv_out) type(flv_structure_t) :: flv_out class(flavor_permutation_t), intent(in) :: perm type(flv_structure_t), intent(in) :: flv_in logical, intent(in), optional :: invert integer :: i, i1, i2 integer :: p1, p2, incr integer :: flv_tmp, tag_tmp logical :: inv inv = .false.; if (present(invert)) inv = invert flv_out = flv_in if (inv) then p1 = 1 p2 = size (perm%perms, dim = 1) incr = 1 else p1 = size (perm%perms, dim = 1) p2 = 1 incr = -1 end if do i = p1, p2, incr i1 = perm%perms(i,1) i2 = perm%perms(i,2) flv_tmp = flv_out%flst(i1) tag_tmp = flv_out%tag(i1) flv_out%flst(i1) = flv_out%flst(i2) flv_out%flst(i2) = flv_tmp flv_out%tag(i1) = flv_out%tag(i2) flv_out%tag(i2) = tag_tmp end do end function flavor_permutation_apply_flavor @ %def flavor_permutation_apply_flavor @ <>= elemental function flavor_permutation_apply_integer (perm, i_in) result (i_out) integer :: i_out class(flavor_permutation_t), intent(in) :: perm integer, intent(in) :: i_in integer :: i, i1, i2 i_out = i_in do i = size (perm%perms(:,1)), 1, -1 i1 = perm%perms(i,1) i2 = perm%perms(i,2) if (i_out == i1) then i_out = i2 else if (i_out == i2) then i_out = i1 end if end do end function flavor_permutation_apply_integer @ %def flavor_permutation_apply_integer @ <>= elemental function flavor_permutation_apply_ftuple (perm, f_in) result (f_out) type(ftuple_t) :: f_out class(flavor_permutation_t), intent(in) :: perm type(ftuple_t), intent(in) :: f_in integer :: i, i1, i2 f_out = f_in do i = size (perm%perms, dim = 1), 1, -1 i1 = perm%perms(i,1) i2 = perm%perms(i,2) if (f_out%ireg(1) == i1) then f_out%ireg(1) = i2 else if (f_out%ireg(1) == i2) then f_out%ireg(1) = i1 end if if (f_out%ireg(2) == i1) then f_out%ireg(2) = i2 else if (f_out%ireg(2) == i2) then f_out%ireg(2) = i1 end if end do if (f_out%ireg(1) > f_out%ireg(2)) f_out%ireg = f_out%ireg([2,1]) end function flavor_permutation_apply_ftuple @ %def flavor_permutation_apply_ftuple @ <>= procedure :: test => flavor_permutation_test <>= function flavor_permutation_test (perm, flv1, flv2, with_tag) result (valid) logical :: valid class(flavor_permutation_t), intent(in) :: perm type(flv_structure_t), intent(in) :: flv1, flv2 logical, intent(in) :: with_tag type(flv_structure_t) :: flv_test flv_test = perm%apply (flv2, invert = .true.) valid = all (flv_test%flst == flv1%flst) if (with_tag) valid = valid .and. all (flv_test%tag == flv1%tag) call flv_test%final () end function flavor_permutation_test @ %def flavor_permutation_test @ A singular region is a partition of phase space which is associated with an individual emitter and, if relevant, resonance. It is associated with an $\alpha_r$- and resonance-index, with a real flavor structure and its underlying Born flavor structure. To compute the FKS weights, it is relevant to know all the other particle indices which can result in a divergenent phase space configuration, which are collected in the [[ftuples]]-array. Some singular regions might behave physically identical. E.g. a real flavor structure associated with three-jet production is $[11,-11,2,-2,21,21]$. Here, there are two possible [[ftuples]] which contribute to the same $u \rightarrow u g$ splitting, namely $(3,5)$ and $(3,6)$. The resulting singular regions will be identical. To avoid this, one singular region is associated with the multiplicity factor [[mult]]. When computing the subtraction terms for each singular region, the result is then simply multiplied by this factor.\\ The [[double_fsr]]-flag indicates whether the singular region should also be supplied by a symmetry factor, explained below. <>= public :: singular_region_t <>= type :: singular_region_t integer :: alr integer :: i_res type(flv_structure_t) :: flst_real type(flv_structure_t) :: flst_uborn integer :: mult integer :: emitter integer :: nregions integer :: real_index type(ftuple_t), dimension(:), allocatable :: ftuples integer :: uborn_index logical :: double_fsr = .false. logical :: soft_divergence = .false. logical :: coll_divergence = .false. type(string_t) :: nlo_correction_type integer, dimension(:), allocatable :: i_reg_to_i_con logical :: pseudo_isr = .false. logical :: sc_required = .false. integer :: eqv_index = 0 contains <> end type singular_region_t @ %def singular_region_t @ <>= procedure :: init => singular_region_init <>= subroutine singular_region_init (sregion, alr, mult, i_res, & flst_real, flst_uborn, flv_born, emitter, ftuples, equivalences, & nlo_correction_type) class(singular_region_t), intent(out) :: sregion integer, intent(in) :: alr, mult, i_res type(flv_structure_t), intent(in) :: flst_real type(flv_structure_t), intent(in) :: flst_uborn type(flv_structure_t), dimension(:), intent(in) :: flv_born integer, intent(in) :: emitter type(ftuple_t), intent(inout), dimension(:) :: ftuples logical, intent(inout), dimension(:,:) :: equivalences type(string_t), intent(in) :: nlo_correction_type integer :: i call debug_input_values () sregion%alr = alr sregion%mult = mult sregion%i_res = i_res sregion%flst_real = flst_real sregion%flst_uborn = flst_uborn sregion%emitter = emitter sregion%nlo_correction_type = nlo_correction_type sregion%nregions = size (ftuples) allocate (sregion%ftuples (sregion%nregions)) sregion%ftuples = ftuples do i = 1, size(flv_born) if (flv_born (i) .equiv. sregion%flst_uborn) then sregion%uborn_index = i exit end if end do sregion%sc_required = any (sregion%flst_uborn%flst == GLUON) .or. & any (sregion%flst_uborn%flst == PHOTON) contains subroutine debug_input_values() if (debug_on) call msg_debug2 (D_SUBTRACTION, "singular_region_init") if (debug2_active (D_SUBTRACTION)) then print *, 'alr = ', alr print *, 'mult = ', mult print *, 'i_res = ', i_res call flst_real%write () call flst_uborn%write () print *, 'emitter = ', emitter call print_equivalence_matrix (ftuples, equivalences) end if end subroutine debug_input_values end subroutine singular_region_init @ %def singular_region_init <>= procedure :: write => singular_region_write <>= subroutine singular_region_write (sregion, unit, maxnregions) class(singular_region_t), intent(in) :: sregion integer, intent(in), optional :: unit integer, intent(in), optional :: maxnregions character(len=7), parameter :: flst_format = "(I3,A1)" character(len=7), parameter :: ireg_space_format = "(7X,A1)" integer :: nreal, nborn, i, u, mr integer :: nleft, nright, nreg, nreg_diff u = given_output_unit (unit); if (u < 0) return mr = sregion%nregions; if (present (maxnregions)) mr = maxnregions nreal = size (sregion%flst_real%flst) nborn = size (sregion%flst_uborn%flst) call write_vline (u) write (u, '(A1)', advance = 'no') '[' do i = 1, nreal - 1 write (u, flst_format, advance = 'no') sregion%flst_real%flst(i), ',' end do write (u, flst_format, advance = 'no') sregion%flst_real%flst(nreal), ']' call write_vline (u) write (u, '(I6)', advance = 'no') sregion%real_index call write_vline (u) write (u, '(I3)', advance = 'no') sregion%emitter call write_vline (u) write (u, '(I3)', advance = 'no') sregion%mult call write_vline (u) write (u, '(I4)', advance = 'no') sregion%nregions call write_vline (u) if (sregion%i_res > 0) then write (u, '(I3)', advance = 'no') sregion%i_res call write_vline (u) end if nreg = sregion%nregions if (nreg == mr) then nleft = 0 nright = 0 else nreg_diff = mr - nreg nleft = nreg_diff / 2 if (mod(nreg_diff , 2) == 0) then nright = nleft else nright = nleft + 1 end if end if if (nleft > 0) then do i = 1, nleft write(u, ireg_space_format, advance='no') ' ' end do end if write (u, '(A)', advance = 'no') char (ftuple_string (sregion%ftuples, .false.)) call write_vline (u) write (u,'(A1)',advance = 'no') '[' do i = 1, nborn - 1 write(u, flst_format, advance = 'no') sregion%flst_uborn%flst(i), ',' end do write (u, flst_format, advance = 'no') sregion%flst_uborn%flst(nborn), ']' call write_vline (u) write (u, '(I7)', advance = 'no') sregion%uborn_index call write_vline (u) if (sregion%nlo_correction_type == "EW") then write (u, '(A3)', advance = 'no') 'ew' else if (sregion%nlo_correction_type == "QCD") then write (u, '(A4)', advance = 'no') 'qcd' else write (u, '(A5)', advance = 'no') 'none' end if write (u, '(A)') end subroutine singular_region_write @ %def singular_region_write @ <>= procedure :: write_latex => singular_region_write_latex <>= subroutine singular_region_write_latex (region, unit) class(singular_region_t), intent(in) :: region integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(I2,A3,A,A3,I2,A3,I1,A3,I1,A3,A,A3,I2,A3,A,A3)") & region%alr, " & ", char (region%flst_real%to_string ()), & " & ", region%real_index, " & ", region%emitter, " & ", & region%mult, " & ", char (ftuple_string (region%ftuples, .true.)), & " & ", region%uborn_index, " & ", char (region%flst_uborn%to_string ()), & " \\" end subroutine singular_region_write_latex @ %def singular_region_write_latex @ In case of a $g \rightarrow gg$ splitting, the factor \begin{equation*} \frac{2E_{\rm{em}}}{E_{\rm{em}} + E_{\rm{rad}}} \end{equation*} is multiplied to the real matrix element. This way, the symmetry of the splitting is used and only one singular region has to be taken into account. However, the factor ensures that there is only a soft singularity if the radiated parton becomes soft. <>= procedure :: set_splitting_info => singular_region_set_splitting_info <>= subroutine singular_region_set_splitting_info (region, n_in) class(singular_region_t), intent(inout) :: region integer, intent(in) :: n_in integer :: i1, i2 integer :: reg region%double_fsr = .false. region%soft_divergence = .false. associate (ftuple => region%ftuples) do reg = 1, region%nregions call ftuple(reg)%get (i1, i2) if (i1 /= region%emitter .or. i2 /= region%flst_real%nlegs) then cycle else if (ftuple(reg)%splitting_type == V_TO_VV .or. & ftuple(reg)%splitting_type == F_TO_FV ) then region%soft_divergence = .true. end if if (i1 == 0) then region%coll_divergence = .not. all (region%flst_real%massive(1:n_in)) else region%coll_divergence = .not. region%flst_real%massive(i1) end if if (ftuple(reg)%splitting_type == V_TO_VV) then if (all (ftuple(reg)%ireg > n_in)) & region%double_fsr = all (is_gluon (region%flst_real%flst(ftuple(reg)%ireg))) exit else if (ftuple(reg)%splitting_type == UNDEFINED_SPLITTING) then call msg_fatal ("All splittings should be defined!") end if end if end do if (.not. region%soft_divergence .and. .not. region%coll_divergence) & call msg_fatal ("Singular region defined without divergence!") end associate end subroutine singular_region_set_splitting_info @ %def singular_region_set_splitting_info @ <>= procedure :: double_fsr_factor => singular_region_double_fsr_factor <>= function singular_region_double_fsr_factor (region, p) result (val) class(singular_region_t), intent(in) :: region type(vector4_t), intent(in), dimension(:) :: p real(default) :: val real(default) :: E_rad, E_em if (region%double_fsr) then E_em = energy (p(region%emitter)) E_rad = energy (p(region%flst_real%nlegs)) val = two * E_em / (E_em + E_rad) else val = one end if end function singular_region_double_fsr_factor @ %def singular_region_double_fsr_factor @ <>= procedure :: has_soft_divergence => singular_region_has_soft_divergence <>= function singular_region_has_soft_divergence (region) result (div) logical :: div class(singular_region_t), intent(in) :: region div = region%soft_divergence end function singular_region_has_soft_divergence @ %def singular_region_has_soft_divergence @ <>= procedure :: has_collinear_divergence => & singular_region_has_collinear_divergence <>= function singular_region_has_collinear_divergence (region) result (div) logical :: div class(singular_region_t), intent(in) :: region div = region%coll_divergence end function singular_region_has_collinear_divergence @ %def singular_region_has_collinear_divergence @ <>= procedure :: has_identical_ftuples => singular_region_has_identical_ftuples <>= elemental function singular_region_has_identical_ftuples (sregion) result (value) logical :: value class(singular_region_t), intent(in) :: sregion integer :: alr value = .false. do alr = 1, sregion%nregions value = value .or. (count (sregion%ftuples(alr) == sregion%ftuples) > 1) end do end function singular_region_has_identical_ftuples @ %def singular_region_has_identical_ftuples @ <>= interface assignment(=) module procedure singular_region_assign end interface <>= subroutine singular_region_assign (reg_out, reg_in) type(singular_region_t), intent(out) :: reg_out type(singular_region_t), intent(in) :: reg_in reg_out%alr = reg_in%alr reg_out%i_res = reg_in%i_res reg_out%flst_real = reg_in%flst_real reg_out%flst_uborn = reg_in%flst_uborn reg_out%mult = reg_in%mult reg_out%emitter = reg_in%emitter reg_out%nregions = reg_in%nregions reg_out%real_index = reg_in%real_index reg_out%uborn_index = reg_in%uborn_index reg_out%double_fsr = reg_in%double_fsr reg_out%soft_divergence = reg_in%soft_divergence reg_out%coll_divergence = reg_in%coll_divergence reg_out%nlo_correction_type = reg_in%nlo_correction_type if (allocated (reg_in%ftuples)) then allocate (reg_out%ftuples (size (reg_in%ftuples))) reg_out%ftuples = reg_in%ftuples else call msg_bug ("singular_region_assign: Trying to copy a singular region without allocated ftuples!") end if end subroutine singular_region_assign @ %def singular_region_assign @ Two singular regions match if they would produce the same amplitude. For this we have to check that their real and underlying Born flavor structures are equivalent, as determined by the [[prc_core]]. However, since there are more aspects of a singular region that make it unique, we have to check other attributes as well. <>= interface operator(.match.) module procedure singular_region_match end interface <>= function singular_region_match (reg1, reg2) result (match) type(singular_region_t), intent(in) :: reg1, reg2 logical :: match match = all ([reg1%flst_real%eqv_index, reg2%flst_real%eqv_index] > 0) match = match .and. (reg1%flst_real%eqv_index == reg2%flst_real%eqv_index) match = match .and. (reg1%flst_uborn%eqv_index == reg2%flst_uborn%eqv_index) match = match .and. (reg1%mult == reg2%mult) match = match .and. (reg1%emitter == reg2%emitter) match = match .and. (reg1%nregions == reg2%nregions) match = match .and. (reg1%double_fsr .eqv. reg2%double_fsr) match = match .and. (reg1%soft_divergence .eqv. reg2%soft_divergence) match = match .and. (reg1%coll_divergence .eqv. reg2%coll_divergence) match = match .and. (char (reg1%nlo_correction_type) == char (reg2%nlo_correction_type)) if (match) match = match .and. (all (reg1%ftuples == reg2%ftuples)) end function singular_region_match @ %def singular_region_match @ <>= type :: resonance_mapping_t type(resonance_history_t), dimension(:), allocatable :: res_histories integer, dimension(:), allocatable :: alr_to_i_res integer, dimension(:,:), allocatable :: i_res_to_alr type(vector4_t), dimension(:), allocatable :: p_res contains <> end type resonance_mapping_t @ %def resonance_mapping_t @ Testing: Init resonance mapping for $\mu \mu b b$ final state. <>= procedure :: init => resonance_mapping_init <>= subroutine resonance_mapping_init (res_map, res_hist) class(resonance_mapping_t), intent(inout) :: res_map type(resonance_history_t), intent(in), dimension(:) :: res_hist integer :: n_hist, i_hist1, i_hist2, n_contributors n_contributors = 0 n_hist = size (res_hist) allocate (res_map%res_histories (n_hist)) do i_hist1 = 1, n_hist if (i_hist1 + 1 <= n_hist) then do i_hist2 = i_hist1 + 1, n_hist if (.not. (res_hist(i_hist1) .contains. res_hist(i_hist2))) & n_contributors = n_contributors + res_hist(i_hist2)%n_resonances end do else n_contributors = n_contributors + res_hist(i_hist1)%n_resonances end if end do allocate (res_map%p_res (n_contributors)) res_map%res_histories = res_hist res_map%p_res = vector4_null end subroutine resonance_mapping_init @ %def resonance_mapping_init @ <>= procedure :: set_alr_to_i_res => resonance_mapping_set_alr_to_i_res <>= subroutine resonance_mapping_set_alr_to_i_res (res_map, regions, alr_new_to_old) class(resonance_mapping_t), intent(inout) :: res_map type(singular_region_t), intent(in), dimension(:) :: regions integer, intent(out), dimension(:), allocatable :: alr_new_to_old integer :: alr, i_res integer :: alr_new, n_alr_res integer :: k if (debug_on) call msg_debug (D_SUBTRACTION, "resonance_mapping_set_alr_to_i_res") n_alr_res = 0 do alr = 1, size (regions) do i_res = 1, size (res_map%res_histories) if (res_map%res_histories(i_res)%contains_leg (regions(alr)%emitter)) & n_alr_res = n_alr_res + 1 end do end do allocate (res_map%alr_to_i_res (n_alr_res)) allocate (res_map%i_res_to_alr (size (res_map%res_histories), 10)) res_map%i_res_to_alr = 0 allocate (alr_new_to_old (n_alr_res)) alr_new = 1 do alr = 1, size (regions) do i_res = 1, size (res_map%res_histories) if (res_map%res_histories(i_res)%contains_leg (regions(alr)%emitter)) then res_map%alr_to_i_res (alr_new) = i_res alr_new_to_old (alr_new) = alr alr_new = alr_new + 1 end if end do end do do i_res = 1, size (res_map%res_histories) k = 1 do alr = 1, size (regions) if (res_map%res_histories(i_res)%contains_leg (regions(alr)%emitter)) then res_map%i_res_to_alr (i_res, k) = alr k = k + 1 end if end do end do if (debug_active (D_SUBTRACTION)) then print *, 'i_res_to_alr:' do i_res = 1, size(res_map%i_res_to_alr, dim=1) print *, res_map%i_res_to_alr (i_res, :) end do print *, 'alr_new_to_old:', alr_new_to_old end if end subroutine resonance_mapping_set_alr_to_i_res @ %def resonance_mapping_set_alr_to_i_res @ <>= procedure :: get_resonance_history => resonance_mapping_get_resonance_history <>= function resonance_mapping_get_resonance_history (res_map, alr) result (res_hist) type(resonance_history_t) :: res_hist class(resonance_mapping_t), intent(in) :: res_map integer, intent(in) :: alr res_hist = res_map%res_histories(res_map%alr_to_i_res (alr)) end function resonance_mapping_get_resonance_history @ %def resonance_mapping_get_resonance_history @ <>= procedure :: write => resonance_mapping_write <>= subroutine resonance_mapping_write (res_map) class(resonance_mapping_t), intent(in) :: res_map integer :: i_res do i_res = 1, size (res_map%res_histories) call res_map%res_histories(i_res)%write () end do end subroutine resonance_mapping_write @ %def resonance_mapping_write @ <>= procedure :: get_resonance_value => resonance_mapping_get_resonance_value <>= function resonance_mapping_get_resonance_value (res_map, i_res, p, i_gluon) result (p_map) real(default) :: p_map class(resonance_mapping_t), intent(in) :: res_map integer, intent(in) :: i_res type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), optional :: i_gluon p_map = res_map%res_histories(i_res)%mapping (p, i_gluon) end function resonance_mapping_get_resonance_value @ %def resonance_mapping_get_resonance_value @ <>= procedure :: get_resonance_all => resonance_mapping_get_resonance_all <>= function resonance_mapping_get_resonance_all (res_map, alr, p, i_gluon) result (p_map) real(default) :: p_map class(resonance_mapping_t), intent(in) :: res_map integer, intent(in) :: alr type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), optional :: i_gluon integer :: i_res p_map = zero do i_res = 1, size (res_map%res_histories) associate (res => res_map%res_histories(i_res)) if (any (res_map%i_res_to_alr (i_res, :) == alr)) & p_map = p_map + res%mapping (p, i_gluon) end associate end do end function resonance_mapping_get_resonance_all @ %def resonance_mapping_get_resonance_all @ <>= procedure :: get_weight => resonance_mapping_get_weight <>= function resonance_mapping_get_weight (res_map, alr, p) result (pfr) real(default) :: pfr class(resonance_mapping_t), intent(in) :: res_map integer, intent(in) :: alr type(vector4_t), intent(in), dimension(:) :: p real(default) :: sumpfr integer :: i_res sumpfr = zero do i_res = 1, size (res_map%res_histories) sumpfr = sumpfr + res_map%get_resonance_value (i_res, p) end do pfr = res_map%get_resonance_value (res_map%alr_to_i_res (alr), p) / sumpfr end function resonance_mapping_get_weight @ %def resonance_mapping_get_weight @ <>= procedure :: get_resonance_alr => resonance_mapping_get_resonance_alr <>= function resonance_mapping_get_resonance_alr (res_map, alr, p, i_gluon) result (p_map) real(default) :: p_map class(resonance_mapping_t), intent(in) :: res_map integer, intent(in) :: alr type(vector4_t), intent(in), dimension(:) :: p integer, intent(in), optional :: i_gluon integer :: i_res i_res = res_map%alr_to_i_res (alr) p_map = res_map%res_histories(i_res)%mapping (p, i_gluon) end function resonance_mapping_get_resonance_alr @ %def resonance_mapping_get_resonance_alr @ <>= interface assignment(=) module procedure resonance_mapping_assign end interface <>= subroutine resonance_mapping_assign (res_map_out, res_map_in) type(resonance_mapping_t), intent(out) :: res_map_out type(resonance_mapping_t), intent(in) :: res_map_in if (allocated (res_map_in%res_histories)) then allocate (res_map_out%res_histories (size (res_map_in%res_histories))) res_map_out%res_histories = res_map_in%res_histories end if if (allocated (res_map_in%alr_to_i_res)) then allocate (res_map_out%alr_to_i_res (size (res_map_in%alr_to_i_res))) res_map_out%alr_to_i_res = res_map_in%alr_to_i_res end if if (allocated (res_map_in%i_res_to_alr)) then allocate (res_map_out%i_res_to_alr & (size (res_map_in%i_res_to_alr, 1), size (res_map_in%i_res_to_alr, 2))) res_map_out%i_res_to_alr = res_map_in%i_res_to_alr end if if (allocated (res_map_in%p_res)) then allocate (res_map_out%p_res (size (res_map_in%p_res))) res_map_out%p_res = res_map_in%p_res end if end subroutine resonance_mapping_assign @ %def resonance_mapping_assign @ Every FKS mapping should store the $\sum_\alpha d_{ij}^{-1}$ and $\sum_\alpha d_{ij,\rm{soft}}^{-1}$. Also we keep the option open to use a normlization factor, which ensures $\sum_\alpha S_\alpha = 1$. <>= type, abstract :: fks_mapping_t real(default) :: sumdij real(default) :: sumdij_soft logical :: pseudo_isr = .false. real(default) :: normalization_factor = one contains <> end type fks_mapping_t @ %def fks_mapping_t @ <>= public :: fks_mapping_default_t <>= type, extends (fks_mapping_t) :: fks_mapping_default_t real(default) :: exp_1, exp_2 integer :: n_in contains <> end type fks_mapping_default_t @ %def fks_mapping_default_t @ <>= public :: fks_mapping_resonances_t <>= type, extends (fks_mapping_t) :: fks_mapping_resonances_t real(default) :: exp_1, exp_2 type(resonance_mapping_t) :: res_map integer :: i_con = 0 contains <> end type fks_mapping_resonances_t @ %def fks_mapping_resonances_t @ <>= public :: operator(.equiv.) public :: operator(.equivtag.) <>= interface operator(.equiv.) module procedure flv_structure_equivalent_no_tag end interface interface operator(.equivtag.) module procedure flv_structure_equivalent_with_tag end interface interface assignment(=) module procedure flv_structure_assign_flv module procedure flv_structure_assign_integer end interface @ %def operator_equiv @ <>= public :: region_data_t <>= type :: region_data_t type(singular_region_t), dimension(:), allocatable :: regions type(flv_structure_t), dimension(:), allocatable :: flv_born type(flv_structure_t), dimension(:), allocatable :: flv_real integer, dimension(:), allocatable :: eqv_flv_index_born integer, dimension(:), allocatable :: eqv_flv_index_real integer, dimension(:), allocatable :: emitters integer :: n_regions = 0 integer :: n_emitters = 0 integer :: n_flv_born = 0 integer :: n_flv_real = 0 integer :: n_in = 0 integer :: n_legs_born = 0 integer :: n_legs_real = 0 integer :: n_phs = 0 integer :: alpha_power = 0 integer :: alphas_power = 0 type(string_t) :: nlo_correction_type class(fks_mapping_t), allocatable :: fks_mapping integer, dimension(:), allocatable :: resonances type(resonance_contributors_t), dimension(:), allocatable :: alr_contributors integer, dimension(:), allocatable :: alr_to_i_contributor integer, dimension(:), allocatable :: i_phs_to_i_con contains <> end type region_data_t @ %def region_data_t @ <>= procedure :: allocate_fks_mappings => region_data_allocate_fks_mappings <>= subroutine region_data_allocate_fks_mappings (reg_data, mapping_type) class(region_data_t), intent(inout) :: reg_data integer, intent(in) :: mapping_type select case (mapping_type) case (FKS_DEFAULT) allocate (fks_mapping_default_t :: reg_data%fks_mapping) case (FKS_RESONANCES) allocate (fks_mapping_resonances_t :: reg_data%fks_mapping) case default call msg_fatal ("Init region_data: FKS mapping not implemented!") end select end subroutine region_data_allocate_fks_mappings @ %def region_data_allocate_fks_mappings @ <>= procedure :: init => region_data_init <>= subroutine region_data_init (reg_data, n_in, model, flavor_born, & flavor_real, nlo_correction_type, alpha_pow, alphas_pow) class(region_data_t), intent(out) :: reg_data integer, intent(in) :: n_in, alpha_pow, alphas_pow type(model_t), intent(in) :: model integer, intent(in), dimension(:,:) :: flavor_born, flavor_real integer, dimension(:,:), allocatable :: flv_real_tmp type(ftuple_list_t), dimension(:), allocatable :: ftuples integer, dimension(:), allocatable :: emitter type(flv_structure_t), dimension(:), allocatable :: flst_alr integer :: i, n_real integer :: n_flv_real_before_check type(string_t), intent(in) :: nlo_correction_type reg_data%n_in = n_in reg_data%alpha_power = alpha_pow reg_data%alphas_power = alphas_pow reg_data%n_flv_born = size (flavor_born, dim = 2) reg_data%n_legs_born = size (flavor_born, dim = 1) reg_data%n_legs_real = reg_data%n_legs_born + 1 reg_data%nlo_correction_type = nlo_correction_type n_flv_real_before_check = size (flavor_real, dim = 2) allocate (reg_data%flv_born (reg_data%n_flv_born)) allocate (flv_real_tmp (reg_data%n_legs_real, n_flv_real_before_check)) do i = 1, reg_data%n_flv_born call reg_data%flv_born(i)%init (flavor_born (:, i), n_in) end do n_real = 0 do i = 1, n_flv_real_before_check if (nlo_correction_type == "EW") then if (.not. (query_coupling_powers & (flavor_real (:, i), reg_data%alpha_power + 1, reg_data%alphas_power))) cycle end if n_real = n_real + 1 flv_real_tmp (:, n_real) = flavor_real (:, i) end do allocate (reg_data%flv_real (n_real)) do i = 1, n_real call reg_data%flv_real(i)%init (flv_real_tmp (:, i), n_in) end do call reg_data%find_regions (model, ftuples, emitter, flst_alr) call reg_data%init_singular_regions (ftuples, emitter, flst_alr, nlo_correction_type) reg_data%n_flv_real = maxval (reg_data%regions%real_index) call reg_data%find_emitters () call reg_data%set_mass_color_and_charge (model) call reg_data%set_splitting_info () end subroutine region_data_init @ %def region_data_init @ <>= procedure :: init_resonance_information => region_data_init_resonance_information <>= subroutine region_data_init_resonance_information (reg_data) class(region_data_t), intent(inout) :: reg_data call reg_data%enlarge_singular_regions_with_resonances () call reg_data%find_resonances () end subroutine region_data_init_resonance_information @ %def region_data_init_resonance_information @ <>= procedure :: set_resonance_mappings => region_data_set_resonance_mappings <>= subroutine region_data_set_resonance_mappings (reg_data, resonance_histories) class(region_data_t), intent(inout) :: reg_data type(resonance_history_t), intent(in), dimension(:) :: resonance_histories select type (map => reg_data%fks_mapping) type is (fks_mapping_resonances_t) call map%res_map%init (resonance_histories) end select end subroutine region_data_set_resonance_mappings @ %def region_data_set_resonance_mappings @ <>= procedure :: setup_fks_mappings => region_data_setup_fks_mappings <>= subroutine region_data_setup_fks_mappings (reg_data, template, n_in) class(region_data_t), intent(inout) :: reg_data type(fks_template_t), intent(in) :: template integer, intent(in) :: n_in call reg_data%allocate_fks_mappings (template%mapping_type) select type (map => reg_data%fks_mapping) type is (fks_mapping_default_t) call map%set_parameter (n_in, template%fks_dij_exp1, template%fks_dij_exp2) end select end subroutine region_data_setup_fks_mappings @ %def region_data_setup_fks_mappings @ So far, we have only created singular regions for a non-resonant case. When resonance mappings are required, we have more singular regions, since they must now be identified by their emitter-resonance pair index, where the emitter must be compatible with the resonance. <>= procedure :: enlarge_singular_regions_with_resonances & => region_data_enlarge_singular_regions_with_resonances <>= subroutine region_data_enlarge_singular_regions_with_resonances (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr integer, dimension(:), allocatable :: alr_new_to_old integer :: n_alr_new type(singular_region_t), dimension(:), allocatable :: save_regions if (debug_on) call msg_debug (D_SUBTRACTION, "region_data_enlarge_singular_regions_with_resonances") call debug_input_values () select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_default_t) return type is (fks_mapping_resonances_t) allocate (save_regions (reg_data%n_regions)) do alr = 1, reg_data%n_regions save_regions(alr) = reg_data%regions(alr) end do associate (res_map => fks_mapping%res_map) call res_map%set_alr_to_i_res (reg_data%regions, alr_new_to_old) deallocate (reg_data%regions) n_alr_new = size (alr_new_to_old) reg_data%n_regions = n_alr_new allocate (reg_data%regions (n_alr_new)) do alr = 1, n_alr_new reg_data%regions(alr) = save_regions(alr_new_to_old (alr)) reg_data%regions(alr)%i_res = res_map%alr_to_i_res (alr) end do end associate end select contains subroutine debug_input_values () if (debug2_active (D_SUBTRACTION)) then call reg_data%write () end if end subroutine debug_input_values end subroutine region_data_enlarge_singular_regions_with_resonances @ %def region_data_enlarge_singular_regions_with_resonances @ <>= procedure :: set_isr_pseudo_regions => region_data_set_isr_pseudo_regions <>= subroutine region_data_set_isr_pseudo_regions (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr integer :: n_alr_new !!! Subroutine called for threshold factorization -> !!! Size of singular regions at this point is fixed type(singular_region_t), dimension(2) :: save_regions integer, dimension(4) :: alr_new_to_old do alr = 1, reg_data%n_regions save_regions(alr) = reg_data%regions(alr) end do n_alr_new = reg_data%n_regions * 2 alr_new_to_old = [1, 1, 2, 2] deallocate (reg_data%regions) allocate (reg_data%regions (n_alr_new)) reg_data%n_regions = n_alr_new do alr = 1, n_alr_new reg_data%regions(alr) = save_regions(alr_new_to_old (alr)) call add_pseudo_emitters (reg_data%regions(alr)) if (mod (alr, 2) == 0) reg_data%regions(alr)%pseudo_isr = .true. end do contains subroutine add_pseudo_emitters (sregion) type(singular_region_t), intent(inout) :: sregion type(ftuple_t), dimension(2) :: ftuples_save integer :: alr do alr = 1, 2 ftuples_save(alr) = sregion%ftuples(alr) end do deallocate (sregion%ftuples) sregion%nregions = sregion%nregions * 2 allocate (sregion%ftuples (sregion%nregions)) do alr = 1, sregion%nregions sregion%ftuples(alr) = ftuples_save (alr_new_to_old(alr)) if (mod (alr, 2) == 0) sregion%ftuples(alr)%pseudo_isr = .true. end do end subroutine add_pseudo_emitters end subroutine region_data_set_isr_pseudo_regions @ %def region_data_set_isr_pseudo_regions @ This subroutine splits up the ftuple-list of the singular regions into interference-free lists, i.e. lists which only contain the same emitter. This is relevant for factorized NLO calculations. In the current implementation, it is hand-tailored for the threshold computation, but should be generalized further in the future. <>= procedure :: split_up_interference_regions_for_threshold => & region_data_split_up_interference_regions_for_threshold <>= subroutine region_data_split_up_interference_regions_for_threshold (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr, i_ftuple integer :: current_emitter integer :: i1, i2 integer :: n_new_reg type(ftuple_t), dimension(2) :: ftuples do alr = 1, reg_data%n_regions associate (region => reg_data%regions(alr)) current_emitter = region%emitter n_new_reg = 0 do i_ftuple = 1, region%nregions call region%ftuples(i_ftuple)%get (i1, i2) if (i1 == current_emitter) then n_new_reg = n_new_reg + 1 ftuples(n_new_reg) = region%ftuples(i_ftuple) end if end do deallocate (region%ftuples) allocate (region%ftuples(n_new_reg)) region%ftuples = ftuples (1 : n_new_reg) region%nregions = n_new_reg end associate end do reg_data%fks_mapping%normalization_factor = 0.5_default end subroutine region_data_split_up_interference_regions_for_threshold @ %def region_data_split_up_interference_regions_for_threshold @ <>= procedure :: set_mass_color_and_charge => region_data_set_mass_color_and_charge <>= subroutine region_data_set_mass_color_and_charge (reg_data, model) class(region_data_t), intent(inout) :: reg_data type(model_t), intent(in) :: model integer :: i do i = 1, reg_data%n_regions associate (region => reg_data%regions(i)) call region%flst_uborn%init_mass_color_and_charge (model) call region%flst_real%init_mass_color_and_charge (model) end associate end do do i = 1, reg_data%n_flv_born call reg_data%flv_born(i)%init_mass_color_and_charge (model) end do do i = 1, size (reg_data%flv_real) call reg_data%flv_real(i)%init_mass_color_and_charge (model) end do end subroutine region_data_set_mass_color_and_charge @ %def region_data_set_mass_color_and_charge @ <>= procedure :: uses_resonances => region_data_uses_resonances <>= function region_data_uses_resonances (reg_data) result (val) logical :: val class(region_data_t), intent(in) :: reg_data select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) val = .true. class default val = .false. end select end function region_data_uses_resonances @ %def region_data_uses_resonances @ Creates a list containing the emitter of each singular region. <>= procedure :: get_emitter_list => region_data_get_emitter_list <>= pure function region_data_get_emitter_list (reg_data) result (emitters) class(region_data_t), intent(in) :: reg_data integer, dimension(:), allocatable :: emitters integer :: i allocate (emitters (reg_data%n_regions)) do i = 1, reg_data%n_regions emitters(i) = reg_data%regions(i)%emitter end do end function region_data_get_emitter_list @ %def region_data_get_emitter_list @ Returns the number of emitters not equal to 0 to avoid double counting between emitters 0, 1 and 2. <>= procedure :: get_n_emitters_sc => region_data_get_n_emitters_sc <>= function region_data_get_n_emitters_sc (reg_data) result (n_emitters_sc) class(region_data_t), intent(in) :: reg_data integer :: n_emitters_sc n_emitters_sc = count (reg_data%emitters /= 0) end function region_data_get_n_emitters_sc @ %def region_data_get_n_emitters_sc @ <>= procedure :: get_associated_resonances => region_data_get_associated_resonances <>= function region_data_get_associated_resonances (reg_data, emitter) result (res) integer, dimension(:), allocatable :: res class(region_data_t), intent(in) :: reg_data integer, intent(in) :: emitter integer :: alr, i integer :: n_res select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) n_res = 0 do alr = 1, reg_data%n_regions if (reg_data%regions(alr)%emitter == emitter) & n_res = n_res + 1 end do if (n_res > 0) then allocate (res (n_res)) else return end if i = 1 do alr = 1, reg_data%n_regions if (reg_data%regions(alr)%emitter == emitter) then res (i) = fks_mapping%res_map%alr_to_i_res (alr) i = i + 1 end if end do end select end function region_data_get_associated_resonances @ %def region_data_get_associated_resonances @ <>= procedure :: emitter_is_compatible_with_resonance => & region_data_emitter_is_compatible_with_resonance <>= function region_data_emitter_is_compatible_with_resonance & (reg_data, i_res, emitter) result (compatible) logical :: compatible class(region_data_t), intent(in) :: reg_data integer, intent(in) :: i_res, emitter integer :: i_res_alr, alr compatible = .false. select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) do alr = 1, reg_data%n_regions i_res_alr = fks_mapping%res_map%alr_to_i_res (alr) if (i_res_alr == i_res .and. reg_data%get_emitter(alr) == emitter) then compatible = .true. exit end if end do end select end function region_data_emitter_is_compatible_with_resonance @ %def region_data_emitter_is_compatible_with_resonance @ <>= procedure :: emitter_is_in_resonance => region_data_emitter_is_in_resonance <>= function region_data_emitter_is_in_resonance (reg_data, i_res, emitter) result (exist) logical :: exist class(region_data_t), intent(in) :: reg_data integer, intent(in) :: i_res, emitter integer :: i exist = .false. select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) associate (res_history => fks_mapping%res_map%res_histories(i_res)) do i = 1, res_history%n_resonances exist = exist .or. any (res_history%resonances(i)%contributors%c == emitter) end do end associate end select end function region_data_emitter_is_in_resonance @ %def region_data_emitter_is_in_resonance @ <>= procedure :: get_contributors => region_data_get_contributors <>= subroutine region_data_get_contributors (reg_data, i_res, emitter, c, success) class(region_data_t), intent(in) :: reg_data integer, intent(in) :: i_res, emitter integer, intent(inout), dimension(:), allocatable :: c logical, intent(out) :: success integer :: i success = .false. select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) associate (res_history => fks_mapping%res_map%res_histories (i_res)) do i = 1, res_history%n_resonances if (any (res_history%resonances(i)%contributors%c == emitter)) then allocate (c (size (res_history%resonances(i)%contributors%c))) c = res_history%resonances(i)%contributors%c success = .true. exit end if end do end associate end select end subroutine region_data_get_contributors @ %def region_data_get_contributors @ <>= procedure :: get_emitter => region_data_get_emitter <>= pure function region_data_get_emitter (reg_data, alr) result (emitter) class(region_data_t), intent(in) :: reg_data integer, intent(in) :: alr integer :: emitter emitter = reg_data%regions(alr)%emitter end function region_data_get_emitter @ %def region_data_get_emitter @ <>= procedure :: map_real_to_born_index => region_data_map_real_to_born_index <>= function region_data_map_real_to_born_index (reg_data, real_index) result (uborn_index) integer :: uborn_index class(region_data_t), intent(in) :: reg_data integer, intent(in) :: real_index integer :: alr uborn_index = 0 do alr = 1, size (reg_data%regions) if (reg_data%regions(alr)%real_index == real_index) then uborn_index = reg_data%regions(alr)%uborn_index exit end if end do end function region_data_map_real_to_born_index @ %def region_data_map_real_to_born_index @ <>= generic :: get_flv_states_born => get_flv_states_born_single, get_flv_states_born_array procedure :: get_flv_states_born_single => region_data_get_flv_states_born_single procedure :: get_flv_states_born_array => region_data_get_flv_states_born_array <>= function region_data_get_flv_states_born_array (reg_data) result (flv_states) integer, dimension(:,:), allocatable :: flv_states class(region_data_t), intent(in) :: reg_data integer :: i_flv allocate (flv_states (reg_data%n_legs_born, reg_data%n_flv_born)) do i_flv = 1, reg_data%n_flv_born flv_states (:, i_flv) = reg_data%flv_born(i_flv)%flst end do end function region_data_get_flv_states_born_array function region_data_get_flv_states_born_single (reg_data, i_flv) result (flv_states) integer, dimension(:), allocatable :: flv_states class(region_data_t), intent(in) :: reg_data integer, intent(in) :: i_flv allocate (flv_states (reg_data%n_legs_born)) flv_states = reg_data%flv_born(i_flv)%flst end function region_data_get_flv_states_born_single @ %def region_data_get_flv_states_born @ <>= generic :: get_flv_states_real => get_flv_states_real_single, get_flv_states_real_array procedure :: get_flv_states_real_single => region_data_get_flv_states_real_single procedure :: get_flv_states_real_array => region_data_get_flv_states_real_array <>= function region_data_get_flv_states_real_single (reg_data, i_flv) result (flv_states) integer, dimension(:), allocatable :: flv_states class(region_data_t), intent(in) :: reg_data integer, intent(in) :: i_flv integer :: i_reg allocate (flv_states (reg_data%n_legs_real)) do i_reg = 1, reg_data%n_regions if (i_flv == reg_data%regions(i_reg)%real_index) then flv_states = reg_data%regions(i_reg)%flst_real%flst exit end if end do end function region_data_get_flv_states_real_single function region_data_get_flv_states_real_array (reg_data) result (flv_states) integer, dimension(:,:), allocatable :: flv_states class(region_data_t), intent(in) :: reg_data integer :: i_flv allocate (flv_states (reg_data%n_legs_real, reg_data%n_flv_real)) do i_flv = 1, reg_data%n_flv_real flv_states (:, i_flv) = reg_data%get_flv_states_real (i_flv) end do end function region_data_get_flv_states_real_array @ %def region_data_get_flv_states_real @ <>= procedure :: get_all_flv_states => region_data_get_all_flv_states <>= subroutine region_data_get_all_flv_states (reg_data, flv_born, flv_real) class(region_data_t), intent(in) :: reg_data integer, dimension(:,:), allocatable, intent(out) :: flv_born, flv_real allocate (flv_born (reg_data%n_legs_born, reg_data%n_flv_born)) flv_born = reg_data%get_flv_states_born () allocate (flv_real (reg_data%n_legs_real, reg_data%n_flv_real)) flv_real = reg_data%get_flv_states_real () end subroutine region_data_get_all_flv_states @ %def region_data_get_all_flv_states @ <>= procedure :: get_n_in => region_data_get_n_in <>= function region_data_get_n_in (reg_data) result (n_in) integer :: n_in class(region_data_t), intent(in) :: reg_data n_in = reg_data%n_in end function region_data_get_n_in @ %def region_data_get_n_in @ <>= procedure :: get_n_legs_real => region_data_get_n_legs_real <>= function region_data_get_n_legs_real (reg_data) result (n_legs) integer :: n_legs class(region_data_t), intent(in) :: reg_data n_legs = reg_data%n_legs_real end function region_data_get_n_legs_real @ %def region_data_get_n_legs_real <>= procedure :: get_n_legs_born => region_data_get_n_legs_born <>= function region_data_get_n_legs_born (reg_data) result (n_legs) integer :: n_legs class(region_data_t), intent(in) :: reg_data n_legs = reg_data%n_legs_born end function region_data_get_n_legs_born @ %def region_data_get_n_legs_born <>= procedure :: get_n_flv_real => region_data_get_n_flv_real <>= function region_data_get_n_flv_real (reg_data) result (n_flv) integer :: n_flv class(region_data_t), intent(in) :: reg_data n_flv = reg_data%n_flv_real end function region_data_get_n_flv_real @ %def region_data_get_n_flv_real <>= procedure :: get_n_flv_born => region_data_get_n_flv_born <>= function region_data_get_n_flv_born (reg_data) result (n_flv) integer :: n_flv class(region_data_t), intent(in) :: reg_data n_flv = reg_data%n_flv_born end function region_data_get_n_flv_born @ %def region_data_get_n_flv_born @ Returns $S_i = \frac{1}{\mathcal{D}d_i}$ or $S_{ij} = \frac{1}{\mathcal{D}d_{ij}}$ for one particular singular region. At this point, the flavor array should be rearranged in such a way that the emitted particle is at the last position of the flavor structure list. <>= generic :: get_svalue => get_svalue_last_pos, get_svalue_ij procedure :: get_svalue_last_pos => region_data_get_svalue_last_pos procedure :: get_svalue_ij => region_data_get_svalue_ij <>= function region_data_get_svalue_ij (reg_data, p_real, alr, i, j, i_res) result (sval) class(region_data_t), intent(inout) :: reg_data type(vector4_t), intent(in), dimension(:) :: p_real integer, intent(in) :: alr, i, j integer, intent(in) :: i_res real(default) :: sval associate (map => reg_data%fks_mapping) call map%compute_sumdij (reg_data%regions(alr), p_real) select type (map) type is (fks_mapping_resonances_t) map%i_con = reg_data%alr_to_i_contributor (alr) end select map%pseudo_isr = reg_data%regions(alr)%pseudo_isr sval = map%svalue (p_real, i, j, i_res) * map%normalization_factor end associate end function region_data_get_svalue_ij function region_data_get_svalue_last_pos (reg_data, p, alr, emitter, i_res) result (sval) class(region_data_t), intent(inout) :: reg_data type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: alr, emitter integer, intent(in) :: i_res real(default) :: sval sval = reg_data%get_svalue (p, alr, emitter, reg_data%n_legs_real, i_res) end function region_data_get_svalue_last_pos @ %def region_data_get_svalue @ The same as above, but for the soft limit. <>= procedure :: get_svalue_soft => region_data_get_svalue_soft <>= function region_data_get_svalue_soft & (reg_data, p_born, p_soft, alr, emitter, i_res) result (sval) class(region_data_t), intent(inout) :: reg_data type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft integer, intent(in) :: alr, emitter, i_res real(default) :: sval associate (map => reg_data%fks_mapping) call map%compute_sumdij_soft (reg_data%regions(alr), p_born, p_soft) select type (map) type is (fks_mapping_resonances_t) map%i_con = reg_data%alr_to_i_contributor (alr) end select map%pseudo_isr = reg_data%regions(alr)%pseudo_isr sval = map%svalue_soft (p_born, p_soft, emitter, i_res) * map%normalization_factor end associate end function region_data_get_svalue_soft @ %def region_data_get_svalue_soft @ This subroutine starts with a specification of $N$- and $N+1$-particle configurations, [[flst_born]] and [[flst_real]], saved in [[reg_data]]. From these, it creates a list of fundamental tuples, a list of emitters and a list containing the $N+1$-particle configuration, rearranged in such a way that the emitter-radiation pair is last ([[flst_alr]]). For the $e^+ \, e^- \, \rightarrow u \, \bar{u} \, g$- example, the generated objects are shown in table \ref{table:ftuples and flavors}. Note that at this point, [[flst_alr]] is arranged in such a way that the emitter can only be equal to $n_{legs}-1$ for final-state radiation or 0, 1, or 2 for initial-state radiation. Further, it occurs that regions can be equivalent. For example in table \ref{table:ftuples and flavors} the regions corresponding to \texttt{alr} = 1 and \texttt{alr} = 3 as well as \texttt{alr} = 2 and \texttt{alr} = 4 describe the same physics and are therefore equivalent. @ <>= procedure :: find_regions => region_data_find_regions <>= subroutine region_data_find_regions & (reg_data, model, ftuples, emitters, flst_alr) class(region_data_t), intent(in) :: reg_data type(model_t), intent(in) :: model type(ftuple_list_t), intent(out), dimension(:), allocatable :: ftuples integer, intent(out), dimension(:), allocatable :: emitters type(flv_structure_t), intent(out), dimension(:), allocatable :: flst_alr type(ftuple_list_t), dimension(:,:), allocatable :: ftuples_tmp integer, dimension(:,:), allocatable :: ftuple_index integer :: n_born, n_real integer :: n_legreal integer :: i_born, i_real, i_ftuple integer :: last_registered_i_born, last_registered_i_real n_born = size (reg_data%flv_born) n_real = size (reg_data%flv_real) n_legreal = size (reg_data%flv_real(1)%flst) allocate (emitters (0)) allocate (flst_alr (0)) allocate (ftuples (0)) i_ftuple = 0 last_registered_i_born = 0; last_registered_i_real = 0 do i_real = 1, n_real do i_born = 1, n_born call setup_flsts_emitters_and_ftuples_fsr & (i_real, i_born, i_ftuple, flst_alr, emitters, ftuples) call setup_flsts_emitters_and_ftuples_isr & (i_real, i_born, i_ftuple, flst_alr, emitters, ftuples) end do end do contains function incr_i_ftuple_if_required (i_born, i_real, i_ftuple_in) result (i_ftuple) integer :: i_ftuple integer, intent(in) :: i_born, i_real, i_ftuple_in if (last_registered_i_born /= i_born .or. last_registered_i_real /= i_real) then last_registered_i_born = i_born last_registered_i_real = i_real i_ftuple = i_ftuple_in + 1 else i_ftuple = i_ftuple_in end if end function incr_i_ftuple_if_required subroutine setup_flsts_emitters_and_ftuples_fsr & (i_real, i_born, i_ftuple, flst_alr, emitters, ftuples) integer, intent(in) :: i_real, i_born integer, intent(inout) :: i_ftuple type(flv_structure_t), intent(inout), dimension(:), allocatable :: flst_alr integer, intent(inout), dimension(:), allocatable :: emitters type(ftuple_list_t), intent(inout), dimension(:), allocatable :: ftuples type(ftuple_list_t) :: ftuples_tmp type(flv_structure_t) :: flst_alr_tmp type(ftuple_t) :: current_ftuple integer :: leg1, leg2 logical :: valid associate (flv_born => reg_data%flv_born(i_born), & flv_real => reg_data%flv_real(i_real)) do leg1 = reg_data%n_in + 1, n_legreal do leg2 = leg1 + 1, n_legreal valid = flv_real%valid_pair(leg1, leg2, flv_born, model) if (valid) then if (is_vector(flv_real%flst(leg1)) .and. & is_fermion(flv_real%flst(leg2))) then flst_alr_tmp = create_alr (flv_real, & reg_data%n_in, leg2, leg1) else flst_alr_tmp = create_alr (flv_real, & reg_data%n_in, leg1, leg2) end if flst_alr = [flst_alr, flst_alr_tmp] emitters = [emitters, n_legreal - 1] call current_ftuple%set (leg1, leg2) call current_ftuple%determine_splitting_type_fsr & (flv_real, leg1, leg2) call current_ftuple%determine_sub_correction_type & (flv_born, flv_real, leg1, leg2) i_ftuple = incr_i_ftuple_if_required (i_born, i_real, i_ftuple) if (i_ftuple > size (ftuples)) then call ftuples_tmp%append (current_ftuple) ftuples = [ftuples, ftuples_tmp] else call ftuples(i_ftuple)%append (current_ftuple) end if end if end do end do end associate end subroutine setup_flsts_emitters_and_ftuples_fsr subroutine setup_flsts_emitters_and_ftuples_isr & (i_real, i_born, i_ftuple, flst_alr, emitters, ftuples) integer, intent(in) :: i_real, i_born integer, intent(inout) :: i_ftuple type(flv_structure_t), intent(inout), dimension(:), allocatable :: flst_alr integer, intent(inout), dimension(:), allocatable :: emitters type(ftuple_list_t), intent(inout), dimension(:), allocatable :: ftuples type(ftuple_list_t) :: ftuples_tmp type(flv_structure_t) :: flst_alr_tmp type(ftuple_t) :: current_ftuple integer :: leg, emitter logical :: valid1, valid2 associate (flv_born => reg_data%flv_born(i_born), & flv_real => reg_data%flv_real(i_real)) do leg = reg_data%n_in + 1, n_legreal valid1 = flv_real%valid_pair(1, leg, flv_born, model) if (reg_data%n_in > 1) then valid2 = flv_real%valid_pair(2, leg, flv_born, model) else valid2 = .false. end if if (valid1 .and. valid2) then emitter = 0 else if (valid1 .and. .not. valid2) then emitter = 1 else if (.not. valid1 .and. valid2) then emitter = 2 else emitter = -1 end if if (valid1 .or. valid2) then flst_alr_tmp = create_alr (flv_real, reg_data%n_in, emitter, leg) flst_alr = [flst_alr, flst_alr_tmp] emitters = [emitters, emitter] call current_ftuple%set(emitter, leg) call current_ftuple%determine_splitting_type_isr & (flv_real, emitter, leg) call current_ftuple%determine_sub_correction_type & (flv_born, flv_real, emitter, leg) i_ftuple = incr_i_ftuple_if_required (i_born, i_real, i_ftuple) if (i_ftuple > size (ftuples)) then call ftuples_tmp%append (current_ftuple) ftuples = [ftuples, ftuples_tmp] else call ftuples(i_ftuple)%append (current_ftuple) end if end if end do end associate end subroutine setup_flsts_emitters_and_ftuples_isr end subroutine region_data_find_regions @ %def region_data_find_regions @ We transfer the mapping of flavor structures that lead to the same amplitude (with structure functions already accounted for!) to the Born and real [[flv_structure]] of each [[singular_region]]. We then use this information, besides other data of each [[singular_region]], to determine which produce the same amplitude for the non-subtracted real and real subtraction terms and set up the equivalence index mapping for each region. <>= procedure :: find_eqv_regions => region_data_find_eqv_regions <>= subroutine region_data_find_eqv_regions (reg_data, optimize) class(region_data_t), intent(inout) :: reg_data logical, intent(in) :: optimize integer :: n_reg, alr1, alr2 n_reg = reg_data%n_regions if (optimize) then do alr1 = 1, n_reg reg_data%regions(alr1)%flst_uborn%eqv_index = & reg_data%eqv_flv_index_born(reg_data%regions(alr1)%uborn_index) reg_data%regions(alr1)%flst_real%eqv_index = & reg_data%eqv_flv_index_real(reg_data%regions(alr1)%real_index) end do do alr1 = 1, n_reg do alr2 = 1, alr1 if (reg_data%regions(alr2) .match. reg_data%regions(alr1)) then reg_data%regions(alr1)%eqv_index = alr2 exit end if end do end do else do alr1 = 1, n_reg reg_data%regions(alr1)%eqv_index = alr1 end do end if end subroutine region_data_find_eqv_regions @ %def region_data_find_eqv_regions @ Creates singular regions according to table \ref{table:singular regions}. It scans all regions in table \ref{table:ftuples and flavors} and records the real flavor structures. If they are equivalent, the flavor structure is not recorded, but the multiplicity of the present one is increased. <>= procedure :: init_singular_regions => region_data_init_singular_regions <>= subroutine region_data_init_singular_regions & (reg_data, ftuples, emitter, flv_alr, nlo_correction_type) class(region_data_t), intent(inout) :: reg_data type(ftuple_list_t), intent(inout), dimension(:), allocatable :: ftuples type(string_t), intent(in) :: nlo_correction_type type(string_t), dimension(:), allocatable :: nlo_correction_type_dyn integer :: n_independent_flv integer, intent(in), dimension(:) :: emitter type(flv_structure_t), intent(in), dimension(:) :: flv_alr type(flv_structure_t), dimension(:), allocatable :: flv_uborn, flv_alr_registered integer, dimension(:), allocatable :: mult integer, dimension(:), allocatable :: flst_emitter integer :: n_regions, maxregions integer, dimension(:), allocatable :: index integer :: i, i_flv, n_legs logical :: equiv, valid_fs_splitting, pure_corr_type, corr_type_valid, non_singular_reg integer :: i_first, i_reg, i_reg_prev integer, dimension(:), allocatable :: region_to_ftuple, alr_limits integer, dimension(:), allocatable :: equiv_index maxregions = size (emitter) n_legs = flv_alr(1)%nlegs allocate (flv_uborn (maxregions)) allocate (flv_alr_registered (maxregions)) allocate (mult (maxregions)) mult = 0 allocate (flst_emitter (maxregions)) allocate (index (0)) allocate (region_to_ftuple (maxregions)) allocate (equiv_index (maxregions)) allocate (nlo_correction_type_dyn (maxregions)) call setup_region_mappings (n_independent_flv, alr_limits, region_to_ftuple) nlo_correction_type_dyn = nlo_correction_type i_first = 1 i_reg = 1 SCAN_FLAVORS: do i_flv = 1, n_independent_flv SCAN_FTUPLES: do i = i_first, i_first + alr_limits (i_flv) - 1 equiv = .false. corr_type_valid = .true. non_singular_reg = .false. if (i == i_first) then flv_alr_registered(i_reg) = flv_alr(i) if (nlo_correction_type == "EW" .and. reg_data%alphas_power > 0) then nlo_correction_type_dyn (i_reg) = set_dynamic_correction_type (i) end if flv_uborn(i_reg) = flv_alr(i)%create_uborn (emitter(i), & nlo_correction_type_dyn (i_reg)) flst_emitter(i_reg) = emitter(i) equiv_index(i_reg) = region_to_ftuple(i) if (nlo_correction_type == "EW" .and. reg_data%alphas_power > 0) then corr_type_valid = (nlo_correction_type_dyn (i_reg) == "EW" .and. & query_coupling_powers (flv_uborn(i_reg)%flst, & reg_data%alpha_power, reg_data%alphas_power)) & .or. (nlo_correction_type_dyn (i_reg) == "QCD" .and. & query_coupling_powers (flv_uborn(i_reg)%flst, & reg_data%alpha_power + 1, reg_data%alphas_power - 1)) non_singular_reg = .not. corr_type_valid .and. & qcd_ew_interferences (flv_alr_registered(i_reg)%flst) & + .and. query_coupling_powers (flv_alr_registered(i_reg)%flst, & + reg_data%alpha_power+2, reg_data%alphas_power-1) & .and. .not. qcd_ew_interferences (flv_uborn(i_reg)%flst) & .and. nlo_correction_type_dyn (i_reg) == "QCD" if (non_singular_reg) nlo_correction_type_dyn (i_reg) = "none" end if if (corr_type_valid .or. non_singular_reg) then mult(i_reg) = mult(i_reg) + 1 index = [index, region_to_real_index(ftuples, i)] i_reg = i_reg + 1 end if else !!! Check for equivalent flavor structures do i_reg_prev = 1, i_reg - 1 if (emitter(i) == flst_emitter(i_reg_prev) .and. emitter(i) > reg_data%n_in) then valid_fs_splitting = check_fs_splitting (flv_alr(i)%get_last_two(n_legs), & flv_alr_registered(i_reg_prev)%get_last_two(n_legs), & flv_alr(i)%tag(n_legs - 1), flv_alr_registered(i_reg_prev)%tag(n_legs - 1)) if (nlo_correction_type == "EW" .and. reg_data%alphas_power > 0) then nlo_correction_type_dyn (i_reg) = set_dynamic_correction_type (i) end if pure_corr_type = nlo_correction_type_dyn (i_reg) & == nlo_correction_type_dyn (i_reg_prev) if ((flv_alr(i) .equiv. flv_alr_registered(i_reg_prev)) & .and. valid_fs_splitting .and. pure_corr_type) then mult(i_reg_prev) = mult(i_reg_prev) + 1 equiv = .true. call ftuples(region_to_real_index(ftuples, i))%set_equiv & (equiv_index(i_reg_prev), region_to_ftuple(i)) exit end if else if (emitter(i) == flst_emitter(i_reg_prev) .and. emitter(i) <= reg_data%n_in) then if (nlo_correction_type == "EW" .and. reg_data%alphas_power > 0) then nlo_correction_type_dyn (i_reg) = set_dynamic_correction_type (i) end if pure_corr_type = nlo_correction_type_dyn (i_reg) & == nlo_correction_type_dyn (i_reg_prev) if ((flv_alr(i) .equiv. flv_alr_registered(i_reg_prev)) & .and. pure_corr_type) then mult(i_reg_prev) = mult(i_reg_prev) + 1 equiv = .true. call ftuples(region_to_real_index(ftuples, i))%set_equiv & (equiv_index(i_reg_prev), region_to_ftuple(i)) exit end if end if end do if (.not. equiv) then flv_alr_registered(i_reg) = flv_alr(i) if (nlo_correction_type == "EW" .and. reg_data%alphas_power > 0) then nlo_correction_type_dyn (i_reg) = set_dynamic_correction_type (i) end if flv_uborn(i_reg) = flv_alr(i)%create_uborn (emitter(i), & nlo_correction_type_dyn (i_reg)) flst_emitter(i_reg) = emitter(i) equiv_index (i_reg) = region_to_ftuple(i) if (nlo_correction_type == "EW" .and. reg_data%alphas_power > 0) then corr_type_valid = (nlo_correction_type_dyn (i_reg) == "EW" .and. & query_coupling_powers (flv_uborn(i_reg)%flst, & reg_data%alpha_power, reg_data%alphas_power)) & .or. (nlo_correction_type_dyn (i_reg) == "QCD" .and. & query_coupling_powers (flv_uborn(i_reg)%flst, & reg_data%alpha_power + 1, reg_data%alphas_power - 1)) non_singular_reg = .not. corr_type_valid .and. & qcd_ew_interferences (flv_alr_registered(i_reg)%flst) & + .and. query_coupling_powers (flv_alr_registered(i_reg)%flst, & + reg_data%alpha_power+2, reg_data%alphas_power-1) & .and. .not. qcd_ew_interferences (flv_uborn(i_reg)%flst) & .and. nlo_correction_type_dyn (i_reg) == "QCD" if (non_singular_reg) nlo_correction_type_dyn (i_reg) = "none" end if if (corr_type_valid .or. non_singular_reg) then mult(i_reg) = mult(i_reg) + 1 index = [index, region_to_real_index(ftuples, i)] i_reg = i_reg + 1 end if end if end if end do SCAN_FTUPLES i_first = i_first + alr_limits(i_flv) end do SCAN_FLAVORS n_regions = i_reg - 1 allocate (reg_data%regions (n_regions)) reg_data%n_regions = n_regions call account_for_regions_from_other_uborns (ftuples) call init_regions_with_permuted_flavors () call assign_real_indices () deallocate (flv_uborn) deallocate (flv_alr_registered) deallocate (mult) deallocate (flst_emitter) deallocate (index) deallocate (region_to_ftuple) deallocate (equiv_index) contains subroutine account_for_regions_from_other_uborns (ftuples) type(ftuple_list_t), intent(inout), dimension(:), allocatable :: ftuples integer :: alr1, alr2, i type(ftuple_t), dimension(:), allocatable :: ftuples_alr1, ftuples_alr2 type(flavor_permutation_t) :: perm_list logical, dimension(:,:), allocatable :: equivalences do alr1 = 1, n_regions do alr2 = 1, n_regions if (index(alr1) == index(alr2)) cycle if (flv_alr_registered(alr1) .equiv. flv_alr_registered(alr2)) then call ftuples(index(alr1))%to_array (ftuples_alr1, equivalences, .false.) call ftuples(index(alr2))%to_array (ftuples_alr2, equivalences, .false.) do i = 1, size (ftuples_alr2) if (.not. any (ftuple_equal_ireg (ftuples_alr1, ftuples_alr2(i)))) then call ftuples(index(alr1))%append (ftuples_alr2(i)) end if end do end if end do end do end subroutine account_for_regions_from_other_uborns subroutine setup_region_mappings (n_independent_flv, & alr_limits, region_to_ftuple) integer, intent(inout) :: n_independent_flv integer, intent(inout), dimension(:), allocatable :: alr_limits integer, intent(inout), dimension(:), allocatable :: region_to_ftuple integer :: i, j, i_flv if (any (ftuples%get_n_tuples() == 0)) & call msg_fatal ("Inconsistent collection of FKS pairs!") n_independent_flv = size (ftuples) alr_limits = ftuples%get_n_tuples() if (.not. (sum (alr_limits) == maxregions)) & call msg_fatal ("Too many regions!") j = 1 do i_flv = 1, n_independent_flv do i = 1, alr_limits(i_flv) region_to_ftuple(j) = i j = j + 1 end do end do end subroutine setup_region_mappings subroutine check_permutation (perm, flv_perm, flv_orig, i_reg) type(flavor_permutation_t), intent(in) :: perm type(flv_structure_t), intent(in) :: flv_perm, flv_orig integer, intent(in) :: i_reg type(flv_structure_t) :: flv_test flv_test = perm%apply (flv_orig, invert = .true.) if (.not. all (flv_test%flst == flv_perm%flst)) then print *, 'Fail at: ', i_reg print *, 'Original flavor structure: ', flv_orig%flst call perm%write () print *, 'Permuted flavor: ', flv_perm%flst print *, 'Should be: ', flv_test%flst call msg_fatal ("Permutation does not reproduce original flavor!") end if end subroutine check_permutation subroutine init_regions_with_permuted_flavors () type(flavor_permutation_t) :: perm_list type(ftuple_t), dimension(:), allocatable :: ftuple_array logical, dimension(:,:), allocatable :: equivalences integer :: i, j do j = 1, n_regions do i = 1, reg_data%n_flv_born if (reg_data%flv_born (i) .equiv. flv_uborn (j)) then call perm_list%reset () call perm_list%init (reg_data%flv_born(i), flv_uborn(j), & reg_data%n_in, reg_data%n_legs_born, .true.) flv_uborn(j) = perm_list%apply (flv_uborn(j)) flv_alr_registered(j) = perm_list%apply (flv_alr_registered(j)) flst_emitter(j) = perm_list%apply (flst_emitter(j)) end if end do call ftuples(index(j))%to_array (ftuple_array, equivalences, .false.) do i = 1, size (reg_data%flv_real) if (reg_data%flv_real(i) .equiv. flv_alr_registered(j)) then call perm_list%reset () call perm_list%init (flv_alr_registered(j), reg_data%flv_real(i), & reg_data%n_in, reg_data%n_legs_real, .false.) if (debug_active (D_SUBTRACTION)) call check_permutation & (perm_list, reg_data%flv_real(i), flv_alr_registered(j), j) ftuple_array = perm_list%apply (ftuple_array) call ftuple_sort_array (ftuple_array, equivalences) end if end do call reg_data%regions(j)%init (j, mult(j), 0, flv_alr_registered(j), & flv_uborn(j), reg_data%flv_born, flst_emitter(j), ftuple_array, & equivalences, nlo_correction_type_dyn (j)) if (allocated (ftuple_array)) deallocate (ftuple_array) if (allocated (equivalences)) deallocate (equivalences) end do end subroutine init_regions_with_permuted_flavors subroutine assign_real_indices () type(flv_structure_t) :: current_flv_real type(flv_structure_t), dimension(:), allocatable :: these_flv integer :: i_real, current_uborn_index integer :: i, j, this_i_real allocate (these_flv (size (flv_alr_registered))) i_real = 1 associate (regions => reg_data%regions) do i = 1, reg_data%n_regions do j = 1, size (these_flv) if (.not. allocated (these_flv(j)%flst)) then this_i_real = i_real call these_flv(i_real)%init (flv_alr_registered(i)%flst, reg_data%n_in) i_real = i_real + 1 exit else if (all (these_flv(j)%flst == flv_alr_registered(i)%flst)) then this_i_real = j exit end if end do regions(i)%real_index = this_i_real end do end associate deallocate (these_flv) end subroutine assign_real_indices subroutine write_perm_list (perm_list) integer, intent(in), dimension(:,:) :: perm_list integer :: i do i = 1, size (perm_list(:,1)) write (*,'(I1,1x,I1,A)', advance = "no" ) perm_list(i,1), perm_list(i,2), '/' end do print *, '' end subroutine write_perm_list function check_fs_splitting (flv1, flv2, tag1, tag2) result (valid) logical :: valid integer, intent(in), dimension(2) :: flv1, flv2 integer, intent(in) :: tag1, tag2 if (flv1(1) + flv1(2) == 0) then valid = abs(flv1(1)) == abs(flv2(1)) .and. abs(flv1(2)) == abs(flv2(2)) else valid = flv1(1) == flv2(1) .and. flv1(2) == flv2(2) .and. tag1 == tag2 end if end function check_fs_splitting function set_dynamic_correction_type (i_flv_alr) result (nlo_corr_type_dyn) type(string_t) :: nlo_corr_type_dyn type(ftuple_t) :: ftuple_tmp integer, intent(in) :: i_flv_alr ftuple_tmp = ftuples (region_to_real_index(ftuples, i_flv_alr))%get_ftuple & (region_to_ftuple(i_flv_alr)) if (ftuple_tmp%qcd_split) then nlo_corr_type_dyn = var_str ("QCD") else nlo_corr_type_dyn = var_str ("EW") end if end function set_dynamic_correction_type end subroutine region_data_init_singular_regions @ %def region_data_init_singular_regions @ Create an array containing all emitters and resonances of [[region_data]]. <>= procedure :: find_emitters => region_data_find_emitters <>= subroutine region_data_find_emitters (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr, j, n_em, em integer, dimension(:), allocatable :: em_count allocate (em_count(reg_data%n_regions)) em_count = -1 n_em = 0 !!!Count the number of different emitters do alr = 1, reg_data%n_regions em = reg_data%regions(alr)%emitter if (.not. any (em_count == em)) then n_em = n_em + 1 em_count(alr) = em end if end do if (n_em < 1) call msg_fatal ("region_data_find_emitters: No emitters found!") reg_data%n_emitters = n_em allocate (reg_data%emitters (reg_data%n_emitters)) reg_data%emitters = -1 j = 1 do alr = 1, size (reg_data%regions) em = reg_data%regions(alr)%emitter if (.not. any (reg_data%emitters == em)) then reg_data%emitters(j) = em j = j + 1 end if end do end subroutine region_data_find_emitters @ %def region_data_find_emitters @ <>= procedure :: find_resonances => region_data_find_resonances <>= subroutine region_data_find_resonances (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr, j, k, n_res, n_contr integer :: res integer, dimension(10) :: res_count type(resonance_contributors_t), dimension(10) :: contributors_count type(resonance_contributors_t) :: contributors integer :: i_res, emitter logical :: share_emitter res_count = -1 n_res = 0; n_contr = 0 !!! Count the number of different resonances do alr = 1, reg_data%n_regions select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) res = fks_mapping%res_map%alr_to_i_res (alr) if (.not. any (res_count == res)) then n_res = n_res + 1 res_count(alr) = res end if end select end do if (n_res > 0) allocate (reg_data%resonances (n_res)) j = 1 select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) do alr = 1, size (reg_data%regions) res = fks_mapping%res_map%alr_to_i_res (alr) if (.not. any (reg_data%resonances == res)) then reg_data%resonances(j) = res j = j + 1 end if end do allocate (reg_data%alr_to_i_contributor (size (reg_data%regions))) do alr = 1, size (reg_data%regions) i_res = fks_mapping%res_map%alr_to_i_res (alr) emitter = reg_data%regions(alr)%emitter call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter) if (.not. share_emitter) cycle if (.not. any (contributors_count == contributors)) then n_contr = n_contr + 1 contributors_count(alr) = contributors end if if (allocated (contributors%c)) deallocate (contributors%c) end do allocate (reg_data%alr_contributors (n_contr)) j = 1 do alr = 1, size (reg_data%regions) i_res = fks_mapping%res_map%alr_to_i_res (alr) emitter = reg_data%regions(alr)%emitter call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter) if (.not. share_emitter) cycle if (.not. any (reg_data%alr_contributors == contributors)) then reg_data%alr_contributors(j) = contributors reg_data%alr_to_i_contributor (alr) = j j = j + 1 else do k = 1, size (reg_data%alr_contributors) if (reg_data%alr_contributors(k) == contributors) exit end do reg_data%alr_to_i_contributor (alr) = k end if if (allocated (contributors%c)) deallocate (contributors%c) end do end select call reg_data%extend_ftuples (n_res) call reg_data%set_contributors () end subroutine region_data_find_resonances @ %def region_data_find_resonances @ <>= procedure :: set_i_phs_to_i_con => region_data_set_i_phs_to_i_con <>= subroutine region_data_set_i_phs_to_i_con (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr integer :: i_res, emitter, i_con, i_phs, i_em type(phs_identifier_t), dimension(:), allocatable :: phs_id_tmp logical :: share_emitter, phs_exist type(resonance_contributors_t) :: contributors allocate (phs_id_tmp (reg_data%n_phs)) if (allocated (reg_data%resonances)) then allocate (reg_data%i_phs_to_i_con (reg_data%n_phs)) do i_em = 1, size (reg_data%emitters) emitter = reg_data%emitters(i_em) do i_res = 1, size (reg_data%resonances) if (reg_data%emitter_is_compatible_with_resonance (i_res, emitter)) then alr = find_alr (emitter, i_res) if (alr == 0) call msg_fatal ("Could not find requested alpha region!") i_con = reg_data%alr_to_i_contributor (alr) call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter) if (.not. share_emitter) cycle call check_for_phs_identifier & (phs_id_tmp, reg_data%n_in, emitter, contributors%c, phs_exist, i_phs) if (phs_id_tmp(i_phs)%emitter < 0) then phs_id_tmp(i_phs)%emitter = emitter allocate (phs_id_tmp(i_phs)%contributors (size (contributors%c))) phs_id_tmp(i_phs)%contributors = contributors%c end if reg_data%i_phs_to_i_con (i_phs) = i_con end if if (allocated (contributors%c)) deallocate (contributors%c) end do end do end if contains function find_alr (emitter, i_res) result (alr) integer :: alr integer, intent(in) :: emitter, i_res integer :: i do i = 1, reg_data%n_regions if (reg_data%regions(i)%emitter == emitter .and. & reg_data%regions(i)%i_res == i_res) then alr = i return end if end do alr = 0 end function find_alr end subroutine region_data_set_i_phs_to_i_con @ %def region_data_set_i_phs_to_i_con @ <>= procedure :: set_alr_to_i_phs => region_data_set_alr_to_i_phs <>= subroutine region_data_set_alr_to_i_phs (reg_data, phs_identifiers, alr_to_i_phs) class(region_data_t), intent(inout) :: reg_data type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers integer, intent(out), dimension(:) :: alr_to_i_phs integer :: alr, i_phs integer :: emitter, i_res type(resonance_contributors_t) :: contributors logical :: share_emitter, phs_exist do alr = 1, reg_data%n_regions associate (region => reg_data%regions(alr)) emitter = region%emitter i_res = region%i_res if (i_res /= 0) then call reg_data%get_contributors (i_res, emitter, & contributors%c, share_emitter) if (.not. share_emitter) cycle end if if (allocated (contributors%c)) then call check_for_phs_identifier (phs_identifiers, reg_data%n_in, & emitter, contributors%c, phs_exist = phs_exist, i_phs = i_phs) else call check_for_phs_identifier (phs_identifiers, reg_data%n_in, & emitter, phs_exist = phs_exist, i_phs = i_phs) end if if (.not. phs_exist) & call msg_fatal ("phs identifiers are not set up correctly!") alr_to_i_phs(alr) = i_phs end associate if (allocated (contributors%c)) deallocate (contributors%c) end do end subroutine region_data_set_alr_to_i_phs @ %def region_data_set_alr_to_i_phs @ <>= procedure :: set_contributors => region_data_set_contributors <>= subroutine region_data_set_contributors (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr, i_res, i_reg, i_con integer :: i1, i2, i_em integer, dimension(:), allocatable :: contributors logical :: share_emitter do alr = 1, size (reg_data%regions) associate (sregion => reg_data%regions(alr)) allocate (sregion%i_reg_to_i_con (sregion%nregions)) do i_reg = 1, sregion%nregions call sregion%ftuples(i_reg)%get (i1, i2) i_em = get_emitter_index (i1, i2, reg_data%n_legs_real) i_res = sregion%ftuples(i_reg)%i_res call reg_data%get_contributors (i_res, i_em, contributors, share_emitter) !!! Lookup contributor index do i_con = 1, size (reg_data%alr_contributors) if (all (reg_data%alr_contributors(i_con)%c == contributors)) then sregion%i_reg_to_i_con (i_reg) = i_con exit end if end do deallocate (contributors) end do end associate end do contains function get_emitter_index (i1, i2, n) result (i_em) integer :: i_em integer, intent(in) :: i1, i2, n if (i1 == n) then i_em = i2 else i_em = i1 end if end function get_emitter_index end subroutine region_data_set_contributors @ %def region_data_set_contributors @ This extension of the ftuples is still too naive as it assumes that the same resonances are possible for all ftuples <>= procedure :: extend_ftuples => region_data_extend_ftuples <>= subroutine region_data_extend_ftuples (reg_data, n_res) class(region_data_t), intent(inout) :: reg_data integer, intent(in) :: n_res integer :: alr, n_reg_save integer :: i_reg, i_res, i_em, k type(ftuple_t), dimension(:), allocatable :: ftuple_save integer :: n_new do alr = 1, size (reg_data%regions) associate (sregion => reg_data%regions(alr)) n_reg_save = sregion%nregions allocate (ftuple_save (n_reg_save)) ftuple_save = sregion%ftuples n_new = count_n_new_ftuples (sregion, n_res) deallocate (sregion%ftuples) sregion%nregions = n_new allocate (sregion%ftuples (n_new)) k = 1 do i_res = 1, n_res do i_reg = 1, n_reg_save associate (ftuple_new => sregion%ftuples(k)) i_em = ftuple_save(i_reg)%ireg(1) if (reg_data%emitter_is_in_resonance (i_res, i_em)) then call ftuple_new%set (i_em, ftuple_save(i_reg)%ireg(2)) ftuple_new%i_res = i_res ftuple_new%splitting_type = ftuple_save(i_reg)%splitting_type k = k + 1 end if end associate end do end do end associate deallocate (ftuple_save) end do contains function count_n_new_ftuples (sregion, n_res) result (n_new) integer :: n_new type(singular_region_t), intent(in) :: sregion integer, intent(in) :: n_res integer :: i_reg, i_res, i_em n_new = 0 do i_reg = 1, sregion%nregions do i_res = 1, n_res i_em = sregion%ftuples(i_reg)%ireg(1) if (reg_data%emitter_is_in_resonance (i_res, i_em)) & n_new = n_new + 1 end do end do end function count_n_new_ftuples end subroutine region_data_extend_ftuples @ %def region_data_extend_ftuples @ <>= procedure :: get_flavor_indices => region_data_get_flavor_indices <>= function region_data_get_flavor_indices (reg_data, born) result (i_flv) integer, dimension(:), allocatable :: i_flv class(region_data_t), intent(in) :: reg_data logical, intent(in) :: born allocate (i_flv (reg_data%n_regions)) if (born) then i_flv = reg_data%regions%uborn_index else i_flv = reg_data%regions%real_index end if end function region_data_get_flavor_indices @ %def region_data_get_flavor_indices @ <>= procedure :: get_matrix_element_index => region_data_get_matrix_element_index <>= function region_data_get_matrix_element_index (reg_data, i_reg) result (i_me) integer :: i_me class(region_data_t), intent(in) :: reg_data integer, intent(in) :: i_reg i_me = reg_data%regions(i_reg)%real_index end function region_data_get_matrix_element_index @ %def region_data_get_matrix_element_index @ <>= procedure :: compute_number_of_phase_spaces & => region_data_compute_number_of_phase_spaces <>= subroutine region_data_compute_number_of_phase_spaces (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: i_em, i_res, i_phs integer :: emitter type(resonance_contributors_t) :: contributors integer, parameter :: n_max_phs = 10 type(phs_identifier_t), dimension(n_max_phs) :: phs_id_tmp logical :: share_emitter, phs_exist if (allocated (reg_data%resonances)) then reg_data%n_phs = 0 do i_em = 1, size (reg_data%emitters) emitter = reg_data%emitters(i_em) do i_res = 1, size (reg_data%resonances) if (reg_data%emitter_is_compatible_with_resonance (i_res, emitter)) then call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter) if (.not. share_emitter) cycle call check_for_phs_identifier & (phs_id_tmp, reg_data%n_in, emitter, contributors%c, phs_exist, i_phs) if (.not. phs_exist) then reg_data%n_phs = reg_data%n_phs + 1 if (reg_data%n_phs > n_max_phs) call msg_fatal & ("Buffer of phase space identifieres: Too much phase spaces!") call phs_id_tmp(i_phs)%init (emitter, contributors%c) end if end if if (allocated (contributors%c)) deallocate (contributors%c) end do end do else reg_data%n_phs = size (remove_duplicates_from_int_array (reg_data%emitters)) end if end subroutine region_data_compute_number_of_phase_spaces @ %def region_data_compute_number_of_phase_spaces @ <>= procedure :: get_n_phs => region_data_get_n_phs <>= function region_data_get_n_phs (reg_data) result (n_phs) integer :: n_phs class(region_data_t), intent(in) :: reg_data n_phs = reg_data%n_phs end function region_data_get_n_phs @ %def region_data_get_n_phs @ <>= procedure :: set_splitting_info => region_data_set_splitting_info <>= subroutine region_data_set_splitting_info (reg_data) class(region_data_t), intent(inout) :: reg_data integer :: alr do alr = 1, reg_data%n_regions call reg_data%regions(alr)%set_splitting_info (reg_data%n_in) end do end subroutine region_data_set_splitting_info @ %def region_data_set_splitting_info @ <>= procedure :: init_phs_identifiers => region_data_init_phs_identifiers <>= subroutine region_data_init_phs_identifiers (reg_data, phs_id) class(region_data_t), intent(in) :: reg_data type(phs_identifier_t), intent(out), dimension(:), allocatable :: phs_id integer :: i_em, i_res, i_phs integer :: emitter type(resonance_contributors_t) :: contributors logical :: share_emitter, phs_exist allocate (phs_id (reg_data%n_phs)) do i_em = 1, size (reg_data%emitters) emitter = reg_data%emitters(i_em) if (allocated (reg_data%resonances)) then do i_res = 1, size (reg_data%resonances) call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter) if (.not. share_emitter) cycle call check_for_phs_identifier & (phs_id, reg_data%n_in, emitter, contributors%c, phs_exist, i_phs) if (.not. phs_exist) & call phs_id(i_phs)%init (emitter, contributors%c) if (allocated (contributors%c)) deallocate (contributors%c) end do else call check_for_phs_identifier (phs_id, reg_data%n_in, emitter, & phs_exist = phs_exist, i_phs = i_phs) if (.not. phs_exist) call phs_id(i_phs)%init (emitter) end if end do end subroutine region_data_init_phs_identifiers @ %def region_data_init_phs_identifiers @ Gathers all ftuples from all ALRs. There are at most $n \cdot (n-1)$ ftuples with $i$ and $j$ in the final state and up to $3n$ ftuples with $i$ in the initial state. <>= procedure :: get_all_ftuples => region_data_get_all_ftuples <>= subroutine region_data_get_all_ftuples (reg_data, ftuples) class(region_data_t), intent(in) :: reg_data type(ftuple_t), intent(inout), dimension(:), allocatable :: ftuples type(ftuple_t), dimension(:), allocatable :: ftuple_tmp integer :: i, j, alr, n_fs j = 0 n_fs = reg_data%n_legs_real - reg_data%n_in allocate (ftuple_tmp (n_fs * (n_fs - 1) + 3 * n_fs)) do i = 1, reg_data%n_regions associate (region => reg_data%regions(i)) do alr = 1, region%nregions if (.not. any (ftuple_equal_ireg (region%ftuples(alr), ftuple_tmp))) then j = j + 1 ftuple_tmp(j) = region%ftuples(alr) end if end do end associate end do allocate (ftuples (j)) ftuples = ftuple_tmp(1:j) deallocate (ftuple_tmp) end subroutine region_data_get_all_ftuples @ %def region_data_get_all_ftuples @ <>= procedure :: write_to_file => region_data_write_to_file <>= subroutine region_data_write_to_file (reg_data, proc_id, latex, os_data) class(region_data_t), intent(inout) :: reg_data type(string_t), intent(in) :: proc_id logical, intent(in) :: latex type(os_data_t), intent(in) :: os_data type(string_t) :: filename integer :: u integer :: status if (latex) then filename = proc_id // "_fks_regions.tex" else filename = proc_id // "_fks_regions.out" end if u = free_unit () open (u, file=char(filename), action = "write", status="replace") if (latex) then call reg_data%write_latex (u) close (u) call os_data%build_latex_file & (proc_id // "_fks_regions", stat_out = status) if (status /= 0) & call msg_error (char ("Failed to compile " // filename)) else call reg_data%write (u) close (u) end if end subroutine region_data_write_to_file @ %def region_data_write_to_file @ <>= procedure :: write_latex => region_data_write_latex <>= subroutine region_data_write_latex (reg_data, unit) class(region_data_t), intent(in) :: reg_data integer, intent(in), optional :: unit integer :: i, u u = given_output_unit (); if (present (unit)) u = unit write (u, "(A)") "\documentclass{article}" write (u, "(A)") "\begin{document}" write (u, "(A)") "%FKS region data, automatically created by WHIZARD" write (u, "(A)") "\begin{table}" write (u, "(A)") "\begin{center}" write (u, "(A)") "\begin{tabular} {|c|c|c|c|c|c|c|c|}" write (u, "(A)") "\hline" write (u, "(A)") "$\alpha_r$ & $f_r$ & $i_r$ & $\varepsilon$ & $\varsigma$ & $\mathcal{P}_{\rm{FKS}}$ & $i_b$ & $f_b$ \\" write (u, "(A)") "\hline" do i = 1, reg_data%n_regions call reg_data%regions(i)%write_latex (u) end do write (u, "(A)") "\hline" write (u, "(A)") "\end{tabular}" write (u, "(A)") "\caption{List of singular regions}" write (u, "(A)") "\begin{description}" write (u, "(A)") "\item[$\alpha_r$] Index of the singular region" write (u, "(A)") "\item[$f_r$] Real flavor structure" write (u, "(A)") "\item[$i_r$] Index of the associated real flavor structure" write (u, "(A)") "\item[$\varepsilon$] Emitter" write (u, "(A)") "\item[$\varsigma$] Multiplicity" !!! The symbol used by 0908.4272 for multiplicities write (u, "(A)") "\item[$\mathcal{P}_{\rm{FKS}}$] The set of singular FKS-pairs" write (u, "(A)") "\item[$i_b$] Underlying Born index" write (u, "(A)") "\item[$f_b$] Underlying Born flavor structure" write (u, "(A)") "\end{description}" write (u, "(A)") "\end{center}" write (u, "(A)") "\end{table}" write (u, "(A)") "\end{document}" end subroutine region_data_write_latex @ %def region_data_write_latex @ Creates a table with information about all singular regions and writes it to a file. <>= procedure :: write => region_data_write <>= subroutine region_data_write (reg_data, unit) class(region_data_t), intent(in) :: reg_data integer, intent(in), optional :: unit integer :: j integer :: maxnregions, i_reg_max type(string_t) :: flst_title, ftuple_title integer :: n_res, u u = given_output_unit (unit); if (u < 0) return maxnregions = 1; i_reg_max = 1 do j = 1, reg_data%n_regions if (size (reg_data%regions(j)%ftuples) > maxnregions) then maxnregions = reg_data%regions(j)%nregions i_reg_max = j end if end do flst_title = '(A' // flst_title_format(reg_data%n_legs_real) // ')' ftuple_title = '(A' // ftuple_title_format() // ')' write (u,'(A,1X,I4)') 'Total number of regions: ', size(reg_data%regions) write (u, '(A4)', advance = 'no') ' alr' call write_vline (u) write (u, char (flst_title), advance = 'no') 'flst_real' call write_vline (u) write (u, '(A6)', advance = 'no') 'i_real' call write_vline (u) write (u, '(A3)', advance = 'no') 'em' call write_vline (u) write (u, '(A3)', advance = 'no') 'mult' call write_vline (u) write (u, '(A4)', advance = 'no') 'nreg' call write_vline (u) if (allocated (reg_data%fks_mapping)) then select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) write (u, '(A3)', advance = 'no') 'res' call write_vline (u) end select end if write (u, char (ftuple_title), advance = 'no') 'ftuples' call write_vline (u) flst_title = '(A' // flst_title_format(reg_data%n_legs_born) // ')' write (u, char (flst_title), advance = 'no') 'flst_born' call write_vline (u) write (u, '(A7)', advance = 'no') 'i_born' call write_vline (u) write (u, '(A4)') 'corr' do j = 1, reg_data%n_regions write (u, '(I4)', advance = 'no') j call reg_data%regions(j)%write (u, maxnregions) end do call write_separator (u) if (allocated (reg_data%fks_mapping)) then select type (fks_mapping => reg_data%fks_mapping) type is (fks_mapping_resonances_t) write (u, '(A)') write (u, '(A)') "The FKS regions are combined with resonance information: " n_res = size (fks_mapping%res_map%res_histories) write (u, '(A,1X,I1)') "Number of QCD resonance histories: ", n_res do j = 1, n_res write (u, '(A,1X,I1)') "i_res = ", j call fks_mapping%res_map%res_histories(j)%write (u) call write_separator (u) end do end select end if contains function flst_title_format (n) result (frmt) integer, intent(in) :: n type(string_t) :: frmt character(len=2) :: frmt_char write (frmt_char, '(I2)') 4 * n + 1 frmt = var_str (frmt_char) end function flst_title_format function ftuple_title_format () result (frmt) type(string_t) :: frmt integer :: n_ftuple_char !!! An ftuple (x,x) consists of five characters. In the string, they !!! are separated by maxregions - 1 commas. In total these are !!! 5 * maxnregions + maxnregions - 1 = 6 * maxnregions - 1 characters. !!! The {} brackets at add two additional characters. n_ftuple_char = 6 * maxnregions + 1 !!! If there are resonances, each ftuple with a resonance adds a ";x" !!! to the ftuple n_ftuple_char = n_ftuple_char + 2 * count (reg_data%regions(i_reg_max)%ftuples%i_res > 0) !!! Pseudo-ISR regions are denoted with a * at the end n_ftuple_char = n_ftuple_char + count (reg_data%regions(i_reg_max)%ftuples%pseudo_isr) frmt = str (n_ftuple_char) end function ftuple_title_format end subroutine region_data_write @ %def region_data_write @ <>= subroutine write_vline (u) integer, intent(in) :: u character(len=10), parameter :: sep_format = "(1X,A2,1X)" write (u, sep_format, advance = 'no') '||' end subroutine write_vline @ %def write_vline @ <>= public :: assignment(=) <>= interface assignment(=) module procedure region_data_assign end interface <>= subroutine region_data_assign (reg_data_out, reg_data_in) type(region_data_t), intent(out) :: reg_data_out type(region_data_t), intent(in) :: reg_data_in integer :: i if (allocated (reg_data_in%regions)) then allocate (reg_data_out%regions (size (reg_data_in%regions))) do i = 1, size (reg_data_in%regions) reg_data_out%regions(i) = reg_data_in%regions(i) end do else call msg_warning ("Copying region data without allocated singular regions!") end if if (allocated (reg_data_in%flv_born)) then allocate (reg_data_out%flv_born (size (reg_data_in%flv_born))) do i = 1, size (reg_data_in%flv_born) reg_data_out%flv_born(i) = reg_data_in%flv_born(i) end do else call msg_warning ("Copying region data without allocated born flavor structure!") end if if (allocated (reg_data_in%flv_real)) then allocate (reg_data_out%flv_real (size (reg_data_in%flv_real))) do i = 1, size (reg_data_in%flv_real) reg_data_out%flv_real(i) = reg_data_in%flv_real(i) end do else call msg_warning ("Copying region data without allocated real flavor structure!") end if if (allocated (reg_data_in%emitters)) then allocate (reg_data_out%emitters (size (reg_data_in%emitters))) do i = 1, size (reg_data_in%emitters) reg_data_out%emitters(i) = reg_data_in%emitters(i) end do else call msg_warning ("Copying region data without allocated emitters!") end if reg_data_out%n_regions = reg_data_in%n_regions reg_data_out%n_emitters = reg_data_in%n_emitters reg_data_out%n_flv_born = reg_data_in%n_flv_born reg_data_out%n_flv_real = reg_data_in%n_flv_real reg_data_out%n_in = reg_data_in%n_in reg_data_out%n_legs_born = reg_data_in%n_legs_born reg_data_out%n_legs_real = reg_data_in%n_legs_real if (allocated (reg_data_in%fks_mapping)) then select type (fks_mapping_in => reg_data_in%fks_mapping) type is (fks_mapping_default_t) allocate (fks_mapping_default_t :: reg_data_out%fks_mapping) select type (fks_mapping_out => reg_data_out%fks_mapping) type is (fks_mapping_default_t) fks_mapping_out = fks_mapping_in end select type is (fks_mapping_resonances_t) allocate (fks_mapping_resonances_t :: reg_data_out%fks_mapping) select type (fks_mapping_out => reg_data_out%fks_mapping) type is (fks_mapping_resonances_t) fks_mapping_out = fks_mapping_in end select end select else call msg_warning ("Copying region data without allocated FKS regions!") end if if (allocated (reg_data_in%resonances)) then allocate (reg_data_out%resonances (size (reg_data_in%resonances))) reg_data_out%resonances = reg_data_in%resonances end if reg_data_out%n_phs = reg_data_in%n_phs if (allocated (reg_data_in%alr_contributors)) then allocate (reg_data_out%alr_contributors (size (reg_data_in%alr_contributors))) reg_data_out%alr_contributors = reg_data_in%alr_contributors end if if (allocated (reg_data_in%alr_to_i_contributor)) then allocate (reg_data_out%alr_to_i_contributor & (size (reg_data_in%alr_to_i_contributor))) reg_data_out%alr_to_i_contributor = reg_data_in%alr_to_i_contributor end if end subroutine region_data_assign @ %def region_data_assign @ Returns the index of the real flavor structure an ftuple belogs to. <>= function region_to_real_index (list, i) result(index) type(ftuple_list_t), intent(in), dimension(:), allocatable :: list integer, intent(in) :: i integer, dimension(:), allocatable :: nreg integer :: index, j allocate (nreg (0)) index = 0 do j = 1, size (list) nreg = [nreg, sum (list(:j)%get_n_tuples ())] if (j == 1) then if (i <= nreg(j)) then index = j exit end if else if (i > nreg(j - 1) .and. i <= nreg(j)) then index = j exit end if end if end do end function region_to_real_index @ %def region_to_real_index @ Final state emission: Rearrange the flavor array in such a way that the emitted particle is last and the emitter is second last. [[i1]] is the index of the emitter, [[i2]] is the index of the emitted particle. Initial state emission: Just put the emitted particle to the last position. <>= function create_alr (flv1, n_in, i_em, i_rad) result(flv2) type(flv_structure_t), intent(in) :: flv1 integer, intent(in) :: n_in integer, intent(in) :: i_em, i_rad type(flv_structure_t) :: flv2 integer :: n n = size (flv1%flst) allocate (flv2%flst (n), flv2%tag (n)) flv2%nlegs = n flv2%n_in = n_in if (i_em > n_in) then flv2%flst(1 : n_in) = flv1%flst(1 : n_in) flv2%flst(n - 1) = flv1%flst(i_em) flv2%flst(n) = flv1%flst(i_rad) flv2%tag(1 : n_in) = flv1%tag(1 : n_in) flv2%tag(n - 1) = flv1%tag(i_em) flv2%tag(n) = flv1%tag(i_rad) call fill_remaining_flavors (n_in, .true.) else flv2%flst(1 : n_in) = flv1%flst(1 : n_in) flv2%flst(n) = flv1%flst(i_rad) flv2%tag(1 : n_in) = flv1%tag(1 : n_in) flv2%tag(n) = flv1%tag(i_rad) call fill_remaining_flavors (n_in, .false.) end if call flv2%compute_prt_symm_fs (flv2%n_in) contains @ Order remaining particles according to their original position <>= subroutine fill_remaining_flavors (n_in, final_final) integer, intent(in) :: n_in logical, intent(in) :: final_final integer :: i, j logical :: check j = n_in + 1 do i = n_in + 1, n if (final_final) then check = (i /= i_em .and. i /= i_rad) else check = (i /= i_rad) end if if (check) then flv2%flst(j) = flv1%flst(i) flv2%tag(j) = flv1%tag(i) j = j + 1 end if end do end subroutine fill_remaining_flavors end function create_alr @ %def create_alr @ <>= procedure :: has_pseudo_isr => region_data_has_pseudo_isr <>= function region_data_has_pseudo_isr (reg_data) result (val) logical :: val class(region_data_t), intent(in) :: reg_data val = any (reg_data%regions%pseudo_isr) end function region_data_has_pseudo_isr @ %def region_data_has_pseudo_isr @ Performs consistency checks on [[region_data]]. Up to now only checks that no [[ftuple]] appears more than once. <>= procedure :: check_consistency => region_data_check_consistency <>= subroutine region_data_check_consistency (reg_data, fail_fatal, unit) class(region_data_t), intent(in) :: reg_data logical, intent(in) :: fail_fatal integer, intent(in), optional :: unit integer :: u integer :: i_reg, alr integer :: i1, f1, f2 logical :: undefined_ftuples, same_ftuple_indices, valid_splitting logical, dimension(4) :: no_fail u = given_output_unit(unit); if (u < 0) return no_fail = .true. call msg_message ("Check that no negative ftuple indices occur", unit = u) do i_reg = 1, reg_data%n_regions if (any (reg_data%regions(i_reg)%ftuples%has_negative_elements ())) then !!! This error is so severe that we stop immediately call msg_fatal ("Negative ftuple indices!") end if end do call msg_message ("Success!", unit = u) call msg_message ("Check that there is no ftuple with identical elements", unit = u) do i_reg = 1, reg_data%n_regions if (any (reg_data%regions(i_reg)%ftuples%has_identical_elements ())) then !!! This error is so severe that we stop immediately call msg_fatal ("Identical ftuple indices!") end if end do call msg_message ("Success!", unit = u) call msg_message ("Check that there are no duplicate ftuples in a region", unit = u) do i_reg = 1, reg_data%n_regions if (reg_data%regions(i_reg)%has_identical_ftuples ()) then if (no_fail(1)) then call msg_error ("FAIL: ", unit = u) no_fail(1) = .false. end if write (u, '(A,1x,I3)') 'i_reg:', i_reg end if end do if (no_fail(1)) call msg_message ("Success!", unit = u) call msg_message ("Check that ftuples add up to a valid splitting", unit = u) do i_reg = 1, reg_data%n_regions do alr = 1, reg_data%regions(i_reg)%nregions associate (region => reg_data%regions(i_reg)) i1 = region%ftuples(alr)%ireg(1) if (i1 == 0) i1 = 1 !!! Gluon emission from both initial-state particles f1 = region%flst_real%flst(i1) f2 = region%flst_real%flst(region%ftuples(alr)%ireg(2)) ! Flip PDG sign of IS fermions to allow a q -> g q splitting ! in which the ftuple has the flavors (q,q). if (i1 <= reg_data%n_in .and. is_fermion(f1)) then f1 = -f1 end if valid_splitting = f1 + f2 == 0 & .or. (is_gluon(f1) .and. is_gluon(f2)) & .or. (is_massive_vector(f1) .and. is_photon(f2)) & .or. is_fermion_vector_splitting (f1, f2) if (.not. valid_splitting) then if (no_fail(2)) then call msg_error ("FAIL: ", unit = u) no_fail(2) = .false. end if write (u, '(A,1x,I3)') 'i_reg:', i_reg exit end if end associate end do end do if (no_fail(2)) call msg_message ("Success!", unit = u) call msg_message ("Check that at least one ftuple contains the emitter", unit = u) do i_reg = 1, reg_data%n_regions associate (region => reg_data%regions(i_reg)) if (.not. any (region%emitter == region%ftuples%ireg(1))) then if (no_fail(3)) then call msg_error ("FAIL: ", unit = u) no_fail(3) = .false. end if write (u, '(A,1x,I3)') 'i_reg:', i_reg end if end associate end do if (no_fail(3)) call msg_message ("Success!", unit = u) call msg_message ("Check that each region has at least one ftuple & &with index n + 1", unit = u) do i_reg = 1, reg_data%n_regions if (.not. any (reg_data%regions(i_reg)%ftuples%ireg(2) == reg_data%n_legs_real)) then if (no_fail(4)) then call msg_error ("FAIL: ", unit = u) no_fail(4) = .false. end if write (u, '(A,1x,I3)') 'i_reg:', i_reg end if end do if (no_fail(4)) call msg_message ("Success!", unit = u) if (.not. all (no_fail)) & call abort_with_message ("Stop due to inconsistent region data!") contains subroutine abort_with_message (msg) character(len=*), intent(in) :: msg if (fail_fatal) then call msg_fatal (msg) else call msg_error (msg, unit = u) end if end subroutine abort_with_message function is_fermion_vector_splitting (pdg_1, pdg_2) result (value) logical :: value integer, intent(in) :: pdg_1, pdg_2 value = (is_fermion (pdg_1) .and. is_massless_vector (pdg_2)) .or. & (is_fermion (pdg_2) .and. is_massless_vector (pdg_1)) end function end subroutine region_data_check_consistency @ %def region_data_check_consistency @ <>= procedure :: requires_spin_correlations => region_data_requires_spin_correlations <>= function region_data_requires_spin_correlations (reg_data) result (val) class(region_data_t), intent(in) :: reg_data logical :: val integer :: alr val = .false. do alr = 1, reg_data%n_regions val = reg_data%regions(alr)%sc_required if (val) return end do end function region_data_requires_spin_correlations @ %def region_data_requires_spin_correlations @ We have to apply the symmetry factor for identical particles of the real flavor structure to the born squared matrix element. The corresponding factor from the born flavor structure has to be cancelled. <>= procedure :: born_to_real_symm_factor_fs => region_data_born_to_real_symm_factor_fs <>= function region_data_born_to_real_symm_factor_fs (reg_data, alr) result (factor) class(region_data_t), intent(in) :: reg_data integer, intent(in) :: alr real(default) :: factor associate (flv_real => reg_data%regions(alr)%flst_real, & flv_uborn => reg_data%regions(alr)%flst_uborn) factor = flv_real%prt_symm_fs / flv_uborn%prt_symm_fs end associate end function region_data_born_to_real_symm_factor_fs @ %def region_data_born_to_real_symm_factor_fs @ <>= procedure :: final => region_data_final <>= subroutine region_data_final (reg_data) class(region_data_t), intent(inout) :: reg_data if (allocated (reg_data%regions)) deallocate (reg_data%regions) if (allocated (reg_data%flv_born)) deallocate (reg_data%flv_born) if (allocated (reg_data%flv_real)) deallocate (reg_data%flv_real) if (allocated (reg_data%emitters)) deallocate (reg_data%emitters) if (allocated (reg_data%fks_mapping)) deallocate (reg_data%fks_mapping) if (allocated (reg_data%resonances)) deallocate (reg_data%resonances) if (allocated (reg_data%alr_contributors)) deallocate (reg_data%alr_contributors) if (allocated (reg_data%alr_to_i_contributor)) deallocate (reg_data%alr_to_i_contributor) end subroutine region_data_final @ %def region_data_final @ <>= procedure (fks_mapping_dij), deferred :: dij <>= abstract interface function fks_mapping_dij (map, p, i, j, i_con) result (d) import real(default) :: d class(fks_mapping_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: i, j integer, intent(in), optional :: i_con end function fks_mapping_dij end interface @ %def fks_mapping_dij @ <>= procedure (fks_mapping_compute_sumdij), deferred :: compute_sumdij <>= abstract interface subroutine fks_mapping_compute_sumdij (map, sregion, p_real) import class(fks_mapping_t), intent(inout) :: map type(singular_region_t), intent(in) :: sregion type(vector4_t), intent(in), dimension(:) :: p_real end subroutine fks_mapping_compute_sumdij end interface @ %def fks_mapping_compute_sumdij @ <>= procedure (fks_mapping_svalue), deferred :: svalue <>= abstract interface function fks_mapping_svalue (map, p, i, j, i_res) result (value) import real(default) :: value class(fks_mapping_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: i, j integer, intent(in), optional :: i_res end function fks_mapping_svalue end interface @ %def fks_mapping_svalue <>= procedure (fks_mapping_dij_soft), deferred :: dij_soft <>= abstract interface function fks_mapping_dij_soft (map, p_born, p_soft, em, i_con) result (d) import real(default) :: d class(fks_mapping_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft integer, intent(in) :: em integer, intent(in), optional :: i_con end function fks_mapping_dij_soft end interface @ %def fks_mapping_dij_soft @ <>= procedure (fks_mapping_compute_sumdij_soft), deferred :: compute_sumdij_soft <>= abstract interface subroutine fks_mapping_compute_sumdij_soft (map, sregion, p_born, p_soft) import class(fks_mapping_t), intent(inout) :: map type(singular_region_t), intent(in) :: sregion type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft end subroutine fks_mapping_compute_sumdij_soft end interface @ %def fks_mapping_compute_sumdij_soft @ <>= procedure (fks_mapping_svalue_soft), deferred :: svalue_soft <>= abstract interface function fks_mapping_svalue_soft (map, p_born, p_soft, em, i_res) result (value) import real(default) :: value class(fks_mapping_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft integer, intent(in) :: em integer, intent(in), optional :: i_res end function fks_mapping_svalue_soft end interface @ %def fks_mapping_svalue_soft @ <>= procedure :: set_parameter => fks_mapping_default_set_parameter <>= subroutine fks_mapping_default_set_parameter (map, n_in, dij_exp1, dij_exp2) class(fks_mapping_default_t), intent(inout) :: map integer, intent(in) :: n_in real(default), intent(in) :: dij_exp1, dij_exp2 map%n_in = n_in map%exp_1 = dij_exp1 map%exp_2 = dij_exp2 end subroutine fks_mapping_default_set_parameter @ %def fks_mapping_default_set_parameter @ Computes the $d_{ij}$-quantities defined als follows: \begin{align*} d_{0i} &= \left[E_i^2\left(1-y_i\right)\right]^{p_2}\\, d_{1i} &= \left[2E_i^2\left(1-y_i\right)\right]^{p_2}\\, d_{2i} &= \left[2E_i^2\left(1+y_i\right)\right]^{p_2}\\, \end{align*} for initial state regions and \begin{align*} d_{ij} = \left[2(k_i \cdot k_j) \frac{E_i E_j}{(E_i+E_j)^2}\right]^{p_1} \end{align*} for final state regions, c.f. [1002.2581, Eq. 4.23f]. The exponents $p_1$ and $p_2$ can be used for tuning the efficiency of the mapping and are set to $1$ per default. <>= procedure :: dij => fks_mapping_default_dij <>= function fks_mapping_default_dij (map, p, i, j, i_con) result (d) real(default) :: d class(fks_mapping_default_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: i, j integer, intent(in), optional :: i_con d = zero if (map%pseudo_isr) then d = dij_threshold_gluon_from_top (i, j, p, map%exp_1) else if (i > map%n_in .and. j > map%n_in) then d = dij_fsr (p(i), p(j), map%exp_1) else d = dij_isr (map%n_in, i, j, p, map%exp_2) end if contains function dij_fsr (p1, p2, expo) result (d_ij) real(default) :: d_ij type(vector4_t), intent(in) :: p1, p2 real(default), intent(in) :: expo real(default) :: E1, E2 E1 = p1%p(0); E2 = p2%p(0) d_ij = (two * p1 * p2 * E1 * E2 / (E1 + E2)**2)**expo end function dij_fsr function dij_threshold_gluon_from_top (i, j, p, expo) result (d_ij) real(default) :: d_ij integer, intent(in) :: i, j type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: expo type(vector4_t) :: p_top if (i == THR_POS_B) then p_top = p(THR_POS_WP) + p(THR_POS_B) else p_top = p(THR_POS_WM) + p(THR_POS_BBAR) end if d_ij = dij_fsr (p_top, p(j), expo) end function dij_threshold_gluon_from_top function dij_isr (n_in, i, j, p, expo) result (d_ij) real(default) :: d_ij integer, intent(in) :: n_in, i, j type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: expo real(default) :: E, y select case (n_in) case (1) call get_emitter_variables (1, i, j, p, E, y) d_ij = (E**2 * (one - y**2))**expo case (2) if ((i == 0 .and. j > 2) .or. (j == 0 .and. i > 2)) then call get_emitter_variables (0, i, j, p, E, y) d_ij = (E**2 * (one - y**2))**expo else if ((i == 1 .and. j > 2) .or. (j == 1 .and. i > 2)) then call get_emitter_variables (1, i, j, p, E, y) d_ij = (two * E**2 * (one - y))**expo else if ((i == 2 .and. j > 2) .or. (j == 2 .and. i > 2)) then call get_emitter_variables (2, i, j, p, E, y) d_ij = (two * E**2 * (one + y))**expo end if end select end function dij_isr subroutine get_emitter_variables (i_check, i, j, p, E, y) integer, intent(in) :: i_check, i, j type(vector4_t), intent(in), dimension(:) :: p real(default), intent(out) :: E, y if (j == i_check) then E = energy (p(i)) y = polar_angle_ct (p(i)) else E = energy (p(j)) y = polar_angle_ct(p(j)) end if end subroutine get_emitter_variables end function fks_mapping_default_dij @ %def fks_mapping_default_dij @ Computes the quantity \begin{equation*} \mathcal{D} = \sum_k \frac{1}{d_{0k}} + \sum_{kl} \frac{1}{d_{kl}}. \end{equation*} where the sum goes over all ftuples of a single singular region. <>= procedure :: compute_sumdij => fks_mapping_default_compute_sumdij <>= subroutine fks_mapping_default_compute_sumdij (map, sregion, p_real) class(fks_mapping_default_t), intent(inout) :: map type(singular_region_t), intent(in) :: sregion type(vector4_t), intent(in), dimension(:) :: p_real real(default) :: d integer :: i_ftuple, i, j associate (ftuples => sregion%ftuples) d = zero do i_ftuple = 1, sregion%nregions call ftuples(i_ftuple)%get (i, j) map%pseudo_isr = ftuples(i_ftuple)%pseudo_isr d = d + one / map%dij (p_real, i, j) end do end associate map%sumdij = d end subroutine fks_mapping_default_compute_sumdij @ %def fks_mapping_default_compute_sumdij @ Computes \begin{equation*} S_i = \frac{1}{\mathcal{D} d_{0i}} \end{equation*} or \begin{equation*} S_{ij} = \frac{1}{\mathcal{D} d_{ij}}, \end{equation*} respectively. <>= procedure :: svalue => fks_mapping_default_svalue <>= function fks_mapping_default_svalue (map, p, i, j, i_res) result (value) real(default) :: value class(fks_mapping_default_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: i, j integer, intent(in), optional :: i_res value = one / (map%dij (p, i, j) * map%sumdij) end function fks_mapping_default_svalue @ %def fks_mapping_default_svalue @ In the soft limit, our treatment of the divergencies requires a modification of the mapping functions. Recall that there, the ratios of the $d$-functions must approach either $1$ or $0$. This means \begin{equation*} \frac{d_{lm}}{d_{0m}} = \frac{(2k_l \cdot k_m) \left[E_lE_m /(E_l + E_m)^2\right]}{E_m^2 (1-y^2)} \overset {k_m = E_m \hat{k}} {=} \frac{E_l E_m^2}{(E_l + E_m)^2} \frac{2k_l \cdot \hat{k}}{E_m^2 (1-y^2)} \overset {E_m \to 0}{=} \frac{2k_l \cdot \hat{k}}{E_l}{(1-y^2)}, \end{equation*} where we have written the gluon momentum in terms of the soft momentum $\hat{k}$. In the same limit \begin{equation*} \frac{d_{lm}}{d_{nm}} = \frac{k_l \cdot \hat{k}}{k_n \cdot \hat{k}} \frac{E_n}{E_l}. \end{equation*} From these equations we can deduce the soft limit of $d$: \begin{align*} d_0^{\rm{soft}} &= 1 - y^2,\\ d_1^{\rm{soft}} &= 2(1-y),\\ d_2^{\rm{soft}} &= 2(1+y),\\ d_i^{\rm{soft}} &= \frac{2 k_i \cdot \hat{k}}{E_i}. \end{align*} <>= procedure :: dij_soft => fks_mapping_default_dij_soft <>= function fks_mapping_default_dij_soft (map, p_born, p_soft, em, i_con) result (d) real(default) :: d class(fks_mapping_default_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft integer, intent(in) :: em integer, intent(in), optional :: i_con if (map%pseudo_isr) then d = dij_soft_threshold_gluon_from_top (em, p_born, p_soft, map%exp_1) else if (em <= map%n_in) then d = dij_soft_isr (map%n_in, p_soft, map%exp_2) else d = dij_soft_fsr (p_born(em), p_soft, map%exp_1) end if contains function dij_soft_threshold_gluon_from_top (em, p_born, p_soft, expo) result (dij_soft) real(default) :: dij_soft integer, intent(in) :: em type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft real(default), intent(in) :: expo type(vector4_t) :: p_top if (em == THR_POS_B) then p_top = p_born(THR_POS_WP) + p_born(THR_POS_B) else p_top = p_born(THR_POS_WM) + p_born(THR_POS_BBAR) end if dij_soft = dij_soft_fsr (p_top, p_soft, expo) end function dij_soft_threshold_gluon_from_top function dij_soft_fsr (p_em, p_soft, expo) result (dij_soft) real(default) :: dij_soft type(vector4_t), intent(in) :: p_em, p_soft real(default), intent(in) :: expo dij_soft = (two * p_em * p_soft / p_em%p(0))**expo end function dij_soft_fsr function dij_soft_isr (n_in, p_soft, expo) result (dij_soft) real(default) :: dij_soft integer, intent(in) :: n_in type(vector4_t), intent(in) :: p_soft real(default), intent(in) :: expo real(default) :: y y = polar_angle_ct (p_soft) select case (n_in) case (1) dij_soft = one - y**2 case (2) select case (em) case (0) dij_soft = one - y**2 case (1) dij_soft = two * (one - y) case (2) dij_soft = two * (one + y) case default dij_soft = zero call msg_fatal ("fks_mappings_default_dij_soft: n_in > 2") end select case default dij_soft = zero call msg_fatal ("fks_mappings_default_dij_soft: n_in > 2") end select dij_soft = dij_soft**expo end function dij_soft_isr end function fks_mapping_default_dij_soft @ %def fks_mapping_default_dij_soft @ Computes the sum of all soft [[dij]]s required to normalize the soft S functions [[s_alpha_soft]] similar to [[fks_mapping_default_compute_sumdij]]. In the soft limit however, we need to skip all ftuples $(i,j)$ in which $j$ does not correspond to the emitted particle because those $d_{ij}$s are finite and thus their contribution to the soft S function vanishes in the limit of soft radiation. Technically, they would not vanish if computed here because the fixed [[p_soft]] at this point would not fit their actual emitter. <>= procedure :: compute_sumdij_soft => fks_mapping_default_compute_sumdij_soft <>= subroutine fks_mapping_default_compute_sumdij_soft (map, sregion, p_born, p_soft) class(fks_mapping_default_t), intent(inout) :: map type(singular_region_t), intent(in) :: sregion type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft real(default) :: d integer :: i_ftuple, i, j integer :: nlegs d = zero nlegs = size (sregion%flst_real%flst) associate (ftuples => sregion%ftuples) do i_ftuple = 1, sregion%nregions call ftuples(i_ftuple)%get (i ,j) if (j == nlegs) then map%pseudo_isr = ftuples(i_ftuple)%pseudo_isr d = d + one / map%dij_soft (p_born, p_soft, i) end if end do end associate map%sumdij_soft = d end subroutine fks_mapping_default_compute_sumdij_soft @ %def fks_mapping_default_compute_sumdij_soft @ <>= procedure :: svalue_soft => fks_mapping_default_svalue_soft <>= function fks_mapping_default_svalue_soft (map, p_born, p_soft, em, i_res) result (value) real(default) :: value class(fks_mapping_default_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft integer, intent(in) :: em integer, intent(in), optional :: i_res value = one / (map%sumdij_soft * map%dij_soft (p_born, p_soft, em)) end function fks_mapping_default_svalue_soft @ %def fks_mapping_default_svalue_soft @ <>= interface assignment(=) module procedure fks_mapping_default_assign end interface <>= subroutine fks_mapping_default_assign (fks_map_out, fks_map_in) type(fks_mapping_default_t), intent(out) :: fks_map_out type(fks_mapping_default_t), intent(in) :: fks_map_in fks_map_out%exp_1 = fks_map_in%exp_1 fks_map_out%exp_2 = fks_map_in%exp_2 fks_map_out%n_in = fks_map_in%n_in end subroutine fks_mapping_default_assign @ %def fks_mapping_default_assign @ The $d_{ij,k}$-functions for the resonance mapping are basically the same as in the default case, but the kinematical values here must be evaluated in the resonance frame of reference. The energy of parton $i$ in a given resonance frame with momentum $p_{res}$ is \begin{equation*} E_i = \frac{p_i^0 \cdot p_{res}}{m_{res}}. \end{equation*} However, since the expressions only depend on ratios of four-momenta, we leave out the denominator because it will cancel out anyway. <>= procedure :: dij => fks_mapping_resonances_dij <>= function fks_mapping_resonances_dij (map, p, i, j, i_con) result (d) real(default) :: d class(fks_mapping_resonances_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: i, j integer, intent(in), optional :: i_con real(default) :: E1, E2 integer :: ii_con if (present (i_con)) then ii_con = i_con else call msg_fatal ("Resonance mappings require resonance index as input!") end if d = 0 if (i /= j) then if (i > 2 .and. j > 2) then associate (p_res => map%res_map%p_res (ii_con)) E1 = p(i) * p_res E2 = p(j) * p_res d = two * p(i) * p(j) * E1 * E2 / (E1 + E2)**2 end associate else call msg_fatal ("Resonance mappings are not implemented for ISR") end if end if end function fks_mapping_resonances_dij @ %def fks_mapping_resonances_dij @ Computes \begin{equation*} S_\alpha = \frac{P^{f_r(\alpha)}d^{-1}(\alpha)} {\sum_{f_r' \in T(F_r(\alpha))}P^{f_r'}\sum_{\alpha' \in Sr(f_r')}d^{-1}(\alpha)}. \end{equation*} <>= procedure :: compute_sumdij => fks_mapping_resonances_compute_sumdij <>= subroutine fks_mapping_resonances_compute_sumdij (map, sregion, p_real) class(fks_mapping_resonances_t), intent(inout) :: map type(singular_region_t), intent(in) :: sregion type(vector4_t), intent(in), dimension(:) :: p_real real(default) :: d, pfr integer :: i_res, i_reg, i, j, i_con integer :: nlegreal nlegreal = size (p_real) d = zero do i_reg = 1, sregion%nregions associate (ftuple => sregion%ftuples(i_reg)) call ftuple%get (i, j) i_res = ftuple%i_res end associate pfr = map%res_map%get_resonance_value (i_res, p_real, nlegreal) i_con = sregion%i_reg_to_i_con (i_reg) d = d + pfr / map%dij (p_real, i, j, i_con) end do map%sumdij = d end subroutine fks_mapping_resonances_compute_sumdij @ %def fks_mapping_resonances_compute_sumdij @ <>= procedure :: svalue => fks_mapping_resonances_svalue <>= function fks_mapping_resonances_svalue (map, p, i, j, i_res) result (value) real(default) :: value class(fks_mapping_resonances_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p integer, intent(in) :: i, j integer, intent(in), optional :: i_res real(default) :: pfr integer :: i_gluon i_gluon = size (p) pfr = map%res_map%get_resonance_value (i_res, p, i_gluon) value = pfr / (map%dij (p, i, j, map%i_con) * map%sumdij) end function fks_mapping_resonances_svalue @ %def fks_mapping_resonances_svalue @ <>= procedure :: get_resonance_weight => fks_mapping_resonances_get_resonance_weight <>= function fks_mapping_resonances_get_resonance_weight (map, alr, p) result (pfr) real(default) :: pfr class(fks_mapping_resonances_t), intent(in) :: map integer, intent(in) :: alr type(vector4_t), intent(in), dimension(:) :: p pfr = map%res_map%get_weight (alr, p) end function fks_mapping_resonances_get_resonance_weight @ %def fks_mapping_resonances_get_resonance_weight @ As above, the soft limit of $d_{ij,k}$ must be computed in the resonance frame of reference. <>= procedure :: dij_soft => fks_mapping_resonances_dij_soft <>= function fks_mapping_resonances_dij_soft (map, p_born, p_soft, em, i_con) result (d) real(default) :: d class(fks_mapping_resonances_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft integer, intent(in) :: em integer, intent(in), optional :: i_con real(default) :: E1, E2 integer :: ii_con type(vector4_t) :: pb if (present (i_con)) then ii_con = i_con else call msg_fatal ("fks_mapping_resonances requires resonance index") end if associate (p_res => map%res_map%p_res(ii_con)) pb = p_born(em) E1 = pb * p_res E2 = p_soft * p_res d = two * pb * p_soft * E1 * E2 / E1**2 end associate end function fks_mapping_resonances_dij_soft @ %def fks_mapping_resonances_dij_soft @ <>= procedure :: compute_sumdij_soft => fks_mapping_resonances_compute_sumdij_soft <>= subroutine fks_mapping_resonances_compute_sumdij_soft (map, sregion, p_born, p_soft) class(fks_mapping_resonances_t), intent(inout) :: map type(singular_region_t), intent(in) :: sregion type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft real(default) :: d real(default) :: pfr integer :: i_res, i, j, i_reg, i_con integer :: nlegs d = zero nlegs = size (sregion%flst_real%flst) do i_reg = 1, sregion%nregions associate (ftuple => sregion%ftuples(i_reg)) call ftuple%get(i, j) i_res = ftuple%i_res end associate pfr = map%res_map%get_resonance_value (i_res, p_born) i_con = sregion%i_reg_to_i_con (i_reg) if (j == nlegs) d = d + pfr / map%dij_soft (p_born, p_soft, i, i_con) end do map%sumdij_soft = d end subroutine fks_mapping_resonances_compute_sumdij_soft @ %def fks_mapping_resonances_compute_sumdij_soft @ <>= procedure :: svalue_soft => fks_mapping_resonances_svalue_soft <>= function fks_mapping_resonances_svalue_soft (map, p_born, p_soft, em, i_res) result (value) real(default) :: value class(fks_mapping_resonances_t), intent(in) :: map type(vector4_t), intent(in), dimension(:) :: p_born type(vector4_t), intent(in) :: p_soft integer, intent(in) :: em integer, intent(in), optional :: i_res real(default) :: pfr pfr = map%res_map%get_resonance_value (i_res, p_born) value = pfr / (map%sumdij_soft * map%dij_soft (p_born, p_soft, em, map%i_con)) end function fks_mapping_resonances_svalue_soft @ %def fks_mapping_resonances_svalue_soft @ <>= procedure :: set_resonance_momentum => fks_mapping_resonances_set_resonance_momentum <>= subroutine fks_mapping_resonances_set_resonance_momentum (map, p) class(fks_mapping_resonances_t), intent(inout) :: map type(vector4_t), intent(in) :: p map%res_map%p_res = p end subroutine fks_mapping_resonances_set_resonance_momentum @ %def fks_mapping_resonances_set_resonance_momentum @ <>= procedure :: set_resonance_momenta => fks_mapping_resonances_set_resonance_momenta <>= subroutine fks_mapping_resonances_set_resonance_momenta (map, p) class(fks_mapping_resonances_t), intent(inout) :: map type(vector4_t), intent(in), dimension(:) :: p map%res_map%p_res = p end subroutine fks_mapping_resonances_set_resonance_momenta @ %def fks_mapping_resonances_set_resonance_momenta @ <>= interface assignment(=) module procedure fks_mapping_resonances_assign end interface <>= subroutine fks_mapping_resonances_assign (fks_map_out, fks_map_in) type(fks_mapping_resonances_t), intent(out) :: fks_map_out type(fks_mapping_resonances_t), intent(in) :: fks_map_in fks_map_out%exp_1 = fks_map_in%exp_1 fks_map_out%exp_2 = fks_map_in%exp_2 fks_map_out%res_map = fks_map_in%res_map end subroutine fks_mapping_resonances_assign @ %def fks_mapping_resonances_assign @ <>= public :: create_resonance_histories_for_threshold <>= function create_resonance_histories_for_threshold () result (res_history) type(resonance_history_t) :: res_history res_history%n_resonances = 2 allocate (res_history%resonances (2)) allocate (res_history%resonances(1)%contributors%c(2)) allocate (res_history%resonances(2)%contributors%c(2)) res_history%resonances(1)%contributors%c = [THR_POS_WP, THR_POS_B] res_history%resonances(2)%contributors%c = [THR_POS_WM, THR_POS_BBAR] end function create_resonance_histories_for_threshold @ %def create_resonance_histories_for_threshold @ <>= public :: setup_region_data_for_test <>= subroutine setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, nlo_corr_type, & alpha_pow, alphas_pow) integer, intent(in) :: n_in, alpha_pow, alphas_pow integer, intent(in), dimension(:,:) :: flv_born, flv_real type(string_t), intent(in) :: nlo_corr_type type(region_data_t), intent(out) :: reg_data type(model_t), pointer :: test_model => null () call create_test_model (var_str ("SM"), test_model) call test_model%set_real (var_str ("me"), 0._default) call test_model%set_real (var_str ("mmu"), 0._default) call test_model%set_real (var_str ("mtau"), 0._default) call test_model%set_real (var_str ("ms"), 0._default) call test_model%set_real (var_str ("mc"), 0._default) call test_model%set_real (var_str ("mb"), 0._default) call reg_data%init (n_in, test_model, flv_born, flv_real, nlo_corr_type, alpha_pow, & alphas_pow) end subroutine setup_region_data_for_test @ %def setup_region_data_for_test @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Unit tests} \clearpage <<[[fks_regions_ut.f90]]>>= <> module fks_regions_ut use unit_tests use fks_regions_uti <> <> contains <> end module fks_regions_ut @ %def fks_regions_ut @ <<[[fks_regions_uti.f90]]>>= <> module fks_regions_uti <> use format_utils, only: write_separator use os_interface use models use fks_regions <> <> contains <> end module fks_regions_uti @ %def fks_regions_uti @ <>= public :: fks_regions_test <>= subroutine fks_regions_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results call test(fks_regions_1, "fks_regions_1", & "Test flavor structure utilities", u, results) call test(fks_regions_2, "fks_regions_2", & "Test singular regions for final-state radiation for n = 2", & u, results) call test(fks_regions_3, "fks_regions_3", & "Test singular regions for final-state radiation for n = 3", & u, results) call test(fks_regions_4, "fks_regions_4", & "Test singular regions for final-state radiation for n = 4", & u, results) call test(fks_regions_5, "fks_regions_5", & "Test singular regions for final-state radiation for n = 5", & u, results) call test(fks_regions_6, "fks_regions_6", & "Test singular regions for initial-state radiation", & u, results) call test(fks_regions_7, "fks_regions_7", & "Check Latex output", u, results) call test(fks_regions_8, "fks_regions_8", & "Test singular regions for initial-state photon contributions", & u, results) end subroutine fks_regions_test @ %def fks_regions_test @ <>= public :: fks_regions_1 <>= subroutine fks_regions_1 (u) integer, intent(in) :: u type(flv_structure_t) :: flv_born, flv_real type(model_t), pointer :: test_model => null () write (u, "(A)") "* Test output: fks_regions_1" write (u, "(A)") "* Purpose: Test utilities of flavor structure manipulation" write (u, "(A)") call create_test_model (var_str ("SM"), test_model) flv_born = [11, -11, 2, -2] flv_real = [11, -11, 2, -2, 21] flv_born%n_in = 2; flv_real%n_in = 2 write (u, "(A)") "* Valid splittings of ee -> uu" write (u, "(A)") "Born Flavors: " call flv_born%write (u) write (u, "(A)") "Real Flavors: " call flv_real%write (u) write (u, "(A,L1)") "3, 4 (2, -2) : ", flv_real%valid_pair (3, 4, flv_born, test_model) write (u, "(A,L1)") "4, 3 (-2, 2) : ", flv_real%valid_pair (4, 3, flv_born, test_model) write (u, "(A,L1)") "3, 5 (2, 21) : ", flv_real%valid_pair (3, 5, flv_born, test_model) write (u, "(A,L1)") "5, 3 (21, 2) : ", flv_real%valid_pair (5, 3, flv_born, test_model) write (u, "(A,L1)") "4, 5 (-2, 21): ", flv_real%valid_pair (4, 5, flv_born, test_model) write (u, "(A,L1)") "5, 4 (21, -2): ", flv_real%valid_pair (5, 4, flv_born, test_model) call write_separator (u) call flv_born%final () call flv_real%final () flv_born = [2, -2, 11, -11] flv_real = [2, -2, 11, -11, 21] flv_born%n_in = 2; flv_real%n_in = 2 write (u, "(A)") "* Valid splittings of uu -> ee" write (u, "(A)") "Born Flavors: " call flv_born%write (u) write (u, "(A)") "Real Flavors: " call flv_real%write (u) write (u, "(A,L1)") "1, 2 (2, -2) : " , flv_real%valid_pair (1, 2, flv_born, test_model) write (u, "(A,L1)") "2, 1 (-2, 2) : " , flv_real%valid_pair (2, 1, flv_born, test_model) write (u, "(A,L1)") "5, 2 (21, -2): " , flv_real%valid_pair (5, 2, flv_born, test_model) write (u, "(A,L1)") "2, 5 (-2, 21): " , flv_real%valid_pair (2, 5, flv_born, test_model) write (u, "(A,L1)") "1, 5 (21, 2) : " , flv_real%valid_pair (5, 1, flv_born, test_model) write (u, "(A,L1)") "5, 1 (2, 21) : " , flv_real%valid_pair (1, 5, flv_born, test_model) call flv_real%final () flv_real = [21, -2, 11, -11, -2] flv_real%n_in = 2 write (u, "(A)") "Real Flavors: " call flv_real%write (u) write (u, "(A,L1)") "1, 2 (21, -2): " , flv_real%valid_pair (1, 2, flv_born, test_model) write (u, "(A,L1)") "2, 1 (-2, 21): " , flv_real%valid_pair (2, 1, flv_born, test_model) write (u, "(A,L1)") "5, 2 (-2, -2): " , flv_real%valid_pair (5, 2, flv_born, test_model) write (u, "(A,L1)") "2, 5 (-2, -2): " , flv_real%valid_pair (2, 5, flv_born, test_model) write (u, "(A,L1)") "5, 1 (-2, 21): " , flv_real%valid_pair (5, 1, flv_born, test_model) write (u, "(A,L1)") "1, 5 (21, -2): " , flv_real%valid_pair (1, 5, flv_born, test_model) call flv_real%final () flv_real = [2, 21, 11, -11, 2] flv_real%n_in = 2 write (u, "(A)") "Real Flavors: " call flv_real%write (u) write (u, "(A,L1)") "1, 2 (2, 21) : " , flv_real%valid_pair (1, 2, flv_born, test_model) write (u, "(A,L1)") "2, 1 (21, 2) : " , flv_real%valid_pair (2, 1, flv_born, test_model) write (u, "(A,L1)") "5, 2 (2, 21) : " , flv_real%valid_pair (5, 2, flv_born, test_model) write (u, "(A,L1)") "2, 5 (21, 2) : " , flv_real%valid_pair (2, 5, flv_born, test_model) write (u, "(A,L1)") "5, 1 (2, 2) : " , flv_real%valid_pair (5, 1, flv_born, test_model) write (u, "(A,L1)") "1, 5 (2, 2) : " , flv_real%valid_pair (1, 5, flv_born, test_model) call write_separator (u) call flv_born%final () call flv_real%final () flv_born = [11, -11, 2, -2, 21] flv_real = [11, -11, 2, -2, 21, 21] flv_born%n_in = 2; flv_real%n_in = 2 write (u, "(A)") "* Valid splittings of ee -> uug" write (u, "(A)") "Born Flavors: " call flv_born%write (u) write (u, "(A)") "Real Flavors: " call flv_real%write (u) write (u, "(A,L1)") "3, 4 (2, -2) : " , flv_real%valid_pair (3, 4, flv_born, test_model) write (u, "(A,L1)") "4, 3 (-2, 2) : " , flv_real%valid_pair (4, 3, flv_born, test_model) write (u, "(A,L1)") "3, 5 (2, 21) : " , flv_real%valid_pair (3, 5, flv_born, test_model) write (u, "(A,L1)") "5, 3 (21, 2) : " , flv_real%valid_pair (5, 3, flv_born, test_model) write (u, "(A,L1)") "4, 5 (-2, 21): " , flv_real%valid_pair (4, 5, flv_born, test_model) write (u, "(A,L1)") "5, 4 (21, -2): " , flv_real%valid_pair (5, 4, flv_born, test_model) write (u, "(A,L1)") "3, 6 (2, 21) : " , flv_real%valid_pair (3, 6, flv_born, test_model) write (u, "(A,L1)") "6, 3 (21, 2) : " , flv_real%valid_pair (6, 3, flv_born, test_model) write (u, "(A,L1)") "4, 6 (-2, 21): " , flv_real%valid_pair (4, 6, flv_born, test_model) write (u, "(A,L1)") "6, 4 (21, -2): " , flv_real%valid_pair (6, 4, flv_born, test_model) write (u, "(A,L1)") "5, 6 (21, 21): " , flv_real%valid_pair (5, 6, flv_born, test_model) write (u, "(A,L1)") "6, 5 (21, 21): " , flv_real%valid_pair (6, 5, flv_born, test_model) call flv_real%final () flv_real = [11, -11, 2, -2, 1, -1] flv_real%n_in = 2 write (u, "(A)") "Real Flavors (exemplary g -> dd splitting): " call flv_real%write (u) write (u, "(A,L1)") "3, 4 (2, -2) : " , flv_real%valid_pair (3, 4, flv_born, test_model) write (u, "(A,L1)") "4, 3 (-2, 2) : " , flv_real%valid_pair (4, 3, flv_born, test_model) write (u, "(A,L1)") "3, 5 (2, 1) : " , flv_real%valid_pair (3, 5, flv_born, test_model) write (u, "(A,L1)") "5, 3 (1, 2) : " , flv_real%valid_pair (5, 3, flv_born, test_model) write (u, "(A,L1)") "4, 5 (-2, 1) : " , flv_real%valid_pair (4, 5, flv_born, test_model) write (u, "(A,L1)") "5, 4 (1, -2) : " , flv_real%valid_pair (5, 4, flv_born, test_model) write (u, "(A,L1)") "3, 6 (2, -1) : " , flv_real%valid_pair (3, 6, flv_born, test_model) write (u, "(A,L1)") "6, 3 (-1, 2) : " , flv_real%valid_pair (6, 3, flv_born, test_model) write (u, "(A,L1)") "4, 6 (-2, -1): " , flv_real%valid_pair (4, 6, flv_born, test_model) write (u, "(A,L1)") "6, 4 (-1, -2): " , flv_real%valid_pair (6, 4, flv_born, test_model) write (u, "(A,L1)") "5, 6 (1, -1) : " , flv_real%valid_pair (5, 6, flv_born, test_model) write (u, "(A,L1)") "6, 5 (-1, 1) : " , flv_real%valid_pair (6, 5, flv_born, test_model) call write_separator (u) call flv_born%final () call flv_real%final () flv_born = [6, -5, 2, -1 ] flv_real = [6, -5, 2, -1, 21] flv_born%n_in = 1; flv_real%n_in = 1 write (u, "(A)") "* Valid splittings of t -> b u d~" write (u, "(A)") "Born Flavors: " call flv_born%write (u) write (u, "(A)") "Real Flavors: " call flv_real%write (u) write (u, "(A,L1)") "1, 2 (6, -5) : " , flv_real%valid_pair (1, 2, flv_born, test_model) write (u, "(A,L1)") "1, 3 (6, 2) : " , flv_real%valid_pair (1, 3, flv_born, test_model) write (u, "(A,L1)") "1, 4 (6, -1) : " , flv_real%valid_pair (1, 4, flv_born, test_model) write (u, "(A,L1)") "2, 1 (-5, 6) : " , flv_real%valid_pair (2, 1, flv_born, test_model) write (u, "(A,L1)") "3, 1 (2, 6) : " , flv_real%valid_pair (3, 1, flv_born, test_model) write (u, "(A,L1)") "4, 1 (-1, 6) : " , flv_real%valid_pair (4, 1, flv_born, test_model) write (u, "(A,L1)") "2, 3 (-5, 2) : " , flv_real%valid_pair (2, 3, flv_born, test_model) write (u, "(A,L1)") "2, 4 (-5, -1): " , flv_real%valid_pair (2, 4, flv_born, test_model) write (u, "(A,L1)") "3, 2 (2, -5) : " , flv_real%valid_pair (3, 2, flv_born, test_model) write (u, "(A,L1)") "4, 2 (-1, -5): " , flv_real%valid_pair (4, 2, flv_born, test_model) write (u, "(A,L1)") "3, 4 (2, -1) : " , flv_real%valid_pair (3, 4, flv_born, test_model) write (u, "(A,L1)") "4, 3 (-1, 2) : " , flv_real%valid_pair (4, 3, flv_born, test_model) write (u, "(A,L1)") "1, 5 (6, 21) : " , flv_real%valid_pair (1, 5, flv_born, test_model) write (u, "(A,L1)") "5, 1 (21, 6) : " , flv_real%valid_pair (5, 1, flv_born, test_model) write (u, "(A,L1)") "2, 5 (-5, 21): " , flv_real%valid_pair (2, 5, flv_born, test_model) write (u, "(A,L1)") "5, 2 (21, 5) : " , flv_real%valid_pair (5, 2, flv_born, test_model) write (u, "(A,L1)") "3, 5 (2, 21) : " , flv_real%valid_pair (3, 5, flv_born, test_model) write (u, "(A,L1)") "5, 3 (21, 2) : " , flv_real%valid_pair (5, 3, flv_born, test_model) write (u, "(A,L1)") "4, 5 (-1, 21): " , flv_real%valid_pair (4, 5, flv_born, test_model) write (u, "(A,L1)") "5, 4 (21, -1): " , flv_real%valid_pair (5, 4, flv_born, test_model) call flv_born%final () call flv_real%final () end subroutine fks_regions_1 @ %def fks_regions_1 @ <>= public :: fks_regions_2 <>= subroutine fks_regions_2 (u) integer, intent(in) :: u integer :: n_flv_born, n_flv_real integer :: n_legs_born, n_legs_real integer :: n_in integer, dimension(:,:), allocatable :: flv_born, flv_real type(region_data_t) :: reg_data write (u, "(A)") "* Test output: fks_regions_2" write (u, "(A)") "* Create singular regions for processes with up to four singular regions" write (u, "(A)") "* ee -> qq with QCD corrections" write (u, "(A)") n_flv_born = 1; n_flv_real = 1 n_legs_born = 4; n_legs_real = 5 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, 2, -2] flv_real (:, 1) = [11, -11, 2, -2, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"), 2, 0) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () call write_separator (u) write (u, "(A)") "* ee -> qq with EW corrections" write (u, "(A)") allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, 2, -2] flv_real (:, 1) = [11, -11, 2, -2, 22] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("EW"), 2, 0) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () call write_separator (u) write (u, "(A)") "* ee -> tt" write (u, "(A)") write (u, "(A)") "* This process has four singular regions because they are not equivalent." n_flv_born = 1; n_flv_real = 1 n_legs_born = 6; n_legs_real = 7 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, 6, -6, 6, -6] flv_real (:, 1) = [11, -11, 6, -6, 6, -6, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"), 4, 0) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () end subroutine fks_regions_2 @ %def fks_regions_2 @ <>= public :: fks_regions_3 <>= subroutine fks_regions_3 (u) integer, intent(in) :: u integer :: n_flv_born, n_flv_real integer :: n_legs_born, n_legs_real integer :: n_in, i, j integer, dimension(:,:), allocatable :: flv_born, flv_real type(region_data_t) :: reg_data write (u, "(A)") "* Test output: fks_regions_3" write (u, "(A)") "* Create singular regions for processes with three final-state particles" write (u, "(A)") "* ee -> qqg" write (u, "(A)") n_flv_born = 1; n_flv_real = 2 n_legs_born = 5; n_legs_real = 6 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, 2, -2, 21] flv_real (:, 1) = [11, -11, 2, -2, 21, 21] flv_real (:, 2) = [11, -11, 2, -2, 1, -1] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"), 2, 1) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () call write_separator (u) write (u, "(A)") "* ee -> qqA" write (u, "(A)") n_flv_born = 1; n_flv_real = 2 n_legs_born = 5; n_legs_real = 6 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, 2, -2, 22] flv_real (:, 1) = [11, -11, 2, -2, 22, 22] flv_real (:, 2) = [11, -11, 2, -2, 11, -11] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("EW"), 3, 0) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () call write_separator (u) write (u, "(A)") "* ee -> jet jet jet" write (u, "(A)") "* with jet = u:U:d:D:s:S:c:C:b:B:gl" write (u, "(A)") n_flv_born = 5; n_flv_real = 22 n_legs_born = 5; n_legs_real = 6 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, -4, 4, 21] flv_born (:, 2) = [11, -11, -2, 2, 21] flv_born (:, 3) = [11, -11, -5, 5, 21] flv_born (:, 4) = [11, -11, -3, 3, 21] flv_born (:, 5) = [11, -11, -1, 1, 21] flv_real (:, 1) = [11, -11, -4, -4, 4, 4] flv_real (:, 2) = [11, -11, -4, -2, 2, 4] flv_real (:, 3) = [11, -11, -4, 4, 21, 21] flv_real (:, 4) = [11, -11, -4, -5, 4, 5] flv_real (:, 5) = [11, -11, -4, -3, 4, 3] flv_real (:, 6) = [11, -11, -4, -1, 2, 3] flv_real (:, 7) = [11, -11, -4, -1, 4, 1] flv_real (:, 8) = [11, -11, -2, -2, 2, 2] flv_real (:, 9) = [11, -11, -2, 2, 21, 21] flv_real (:, 10) = [11, -11, -2, -5, 2, 5] flv_real (:, 11) = [11, -11, -2, -3, 2, 3] flv_real (:, 12) = [11, -11, -2, -3, 4, 1] flv_real (:, 13) = [11, -11, -2, -1, 2, 1] flv_real (:, 14) = [11, -11, -5, -5, 5, 5] flv_real (:, 15) = [11, -11, -5, -3, 3, 5] flv_real (:, 16) = [11, -11, -5, -1, 1, 5] flv_real (:, 17) = [11, -11, -5, 5, 21, 21] flv_real (:, 18) = [11, -11, -3, -3, 3, 3] flv_real (:, 19) = [11, -11, -3, -1, 1, 3] flv_real (:, 20) = [11, -11, -3, 3, 21, 21] flv_real (:, 21) = [11, -11, -1, -1, 1, 1] flv_real (:, 22) = [11, -11, -1, 1, 21, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"), 2, 1) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () call write_separator (u) write (u, "(A)") "* ee -> L L A" write (u, "(A)") "* with L = e2:E2:e3:E3" write (u, "(A)") n_flv_born = 2; n_flv_real = 6 n_legs_born = 5; n_legs_real = 6 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, -15, 15, 22] flv_born (:, 2) = [11, -11, -13, 13, 22] flv_real (:, 1) = [11, -11, -15, -15, 15, 15] flv_real (:, 2) = [11, -11, -15, -13, 13, 13] flv_real (:, 3) = [11, -11, -13, -15, 13, 15] flv_real (:, 4) = [11, -11, -15, 15, 22, 22] flv_real (:, 5) = [11, -11, -13, -13, 13, 13] flv_real (:, 6) = [11, -11, -13, 13, 22, 22] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("EW"), 3, 0) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () end subroutine fks_regions_3 @ %def fks_regions_3 @ <>= public :: fks_regions_4 <>= subroutine fks_regions_4 (u) integer, intent(in) :: u integer :: n_flv_born, n_flv_real integer :: n_legs_born, n_legs_real integer :: n_in integer, dimension(:,:), allocatable :: flv_born, flv_real type(region_data_t) :: reg_data write (u, "(A)") "* Test output: fks_regions_4" write (u, "(A)") "* Create singular regions for processes with four final-state particles" write (u, "(A)") "* ee -> 4 jet" write (u, "(A)") "* with jet = u:U:d:D:s:S:c:C:b:B:gl" write (u, "(A)") n_flv_born = 22; n_flv_real = 22 n_legs_born = 6; n_legs_real = 7 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, -4, -4, 4, 4] flv_born (:, 2) = [11, -11, -4, -2, 2, 4] flv_born (:, 3) = [11, -11, -4, 4, 21, 21] flv_born (:, 4) = [11, -11, -4, -5, 4, 5] flv_born (:, 5) = [11, -11, -4, -3, 4, 3] flv_born (:, 6) = [11, -11, -4, -1, 2, 3] flv_born (:, 7) = [11, -11, -4, -1, 4, 1] flv_born (:, 8) = [11, -11, -2, -2, 2, 2] flv_born (:, 9) = [11, -11, -2, 2, 21, 21] flv_born (:, 10) = [11, -11, -2, -5, 2, 5] flv_born (:, 11) = [11, -11, -2, -3, 2, 3] flv_born (:, 12) = [11, -11, -2, -3, 4, 1] flv_born (:, 13) = [11, -11, -2, -1, 2, 1] flv_born (:, 14) = [11, -11, -5, -5, 5, 5] flv_born (:, 15) = [11, -11, -5, -3, 3, 5] flv_born (:, 16) = [11, -11, -5, -1, 1, 5] flv_born (:, 17) = [11, -11, -5, 5, 21, 21] flv_born (:, 18) = [11, -11, -3, -3, 3, 3] flv_born (:, 19) = [11, -11, -3, -1, 1, 3] flv_born (:, 20) = [11, -11, -3, -3, 21, 21] flv_born (:, 21) = [11, -11, -1, -1, 1, 1] flv_born (:, 22) = [11, -11, -1, 1, 21, 21] flv_real (:, 1) = [11, -11, -4, -4, 4, 4, 21] flv_real (:, 2) = [11, -11, -4, -2, 2, 4, 21] flv_real (:, 3) = [11, -11, -4, 4, 21, 21, 21] flv_real (:, 4) = [11, -11, -4, -5, 4, 5, 21] flv_real (:, 5) = [11, -11, -4, -3, 4, 3, 21] flv_real (:, 6) = [11, -11, -4, -1, 2, 3, 21] flv_real (:, 7) = [11, -11, -4, -1, 4, 1, 21] flv_real (:, 8) = [11, -11, -2, -2, 2, 2, 21] flv_real (:, 9) = [11, -11, -2, 2, 21, 21, 21] flv_real (:, 10) = [11, -11, -2, -5, 2, 5, 21] flv_real (:, 11) = [11, -11, -2, -3, 2, 3, 21] flv_real (:, 12) = [11, -11, -2, -3, 4, 1, 21] flv_real (:, 13) = [11, -11, -2, -1, 2, 1, 21] flv_real (:, 14) = [11, -11, -5, -5, 5, 5, 21] flv_real (:, 15) = [11, -11, -5, -3, 3, 5, 21] flv_real (:, 16) = [11, -11, -5, -1, 1, 5, 21] flv_real (:, 17) = [11, -11, -5, 5, 21, 21, 21] flv_real (:, 18) = [11, -11, -3, -3, 3, 3, 21] flv_real (:, 19) = [11, -11, -3, -1, 1, 3, 21] flv_real (:, 20) = [11, -11, -3, 3, 21, 21, 21] flv_real (:, 21) = [11, -11, -1, -1, 1, 1, 21] flv_real (:, 22) = [11, -11, -1, 1, 21, 21, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"), 2, 2) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () call write_separator (u) write (u, "(A)") "* ee -> bbmumu with QCD corrections" write (u, "(A)") n_flv_born = 1; n_flv_real = 1 n_legs_born = 6; n_legs_real = 7 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, -5, 5, -13, 13] flv_real (:, 1) = [11, -11, -5, 5, -13, 13, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"), 4, 0) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () call write_separator (u) write (u, "(A)") "* ee -> bbmumu with EW corrections" write (u, "(A)") n_flv_born = 1; n_flv_real = 1 n_legs_born = 6; n_legs_real = 7 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, -5, 5, -13, 13] flv_real (:, 1) = [11, -11, -5, 5, -13, 13, 22] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"), 4, 0) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () end subroutine fks_regions_4 @ %def fks_regions_4 @ <>= public :: fks_regions_5 <>= subroutine fks_regions_5 (u) integer, intent(in) :: u integer :: n_flv_born, n_flv_real integer :: n_legs_born, n_legs_real integer :: n_in integer, dimension(:,:), allocatable :: flv_born, flv_real type(region_data_t) :: reg_data write (u, "(A)") "* Test output: fks_regions_5" write (u, "(A)") "* Create singular regions for processes with five final-state particles" write (u, "(A)") "* ee -> 5 jet" write (u, "(A)") "* with jet = u:U:d:D:s:S:c:C:b:B:gl" write (u, "(A)") n_flv_born = 22; n_flv_real = 67 n_legs_born = 7; n_legs_real = 8 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:,1) = [11,-11,-4,-4,4,4,21] flv_born (:,2) = [11,-11,-4,-2,2,4,21] flv_born (:,3) = [11,-11,-4,4,21,21,21] flv_born (:,4) = [11,-11,-4,-5,4,5,21] flv_born (:,5) = [11,-11,-4,-3,4,3,21] flv_born (:,6) = [11,-11,-4,-1,2,3,21] flv_born (:,7) = [11,-11,-4,-1,4,1,21] flv_born (:,8) = [11,-11,-2,-2,2,2,21] flv_born (:,9) = [11,-11,-2,2,21,21,21] flv_born (:,10) = [11,-11,-2,-5,2,5,21] flv_born (:,11) = [11,-11,-2,-3,2,3,21] flv_born (:,12) = [11,-11,-2,-3,4,1,21] flv_born (:,13) = [11,-11,-2,-1,2,1,21] flv_born (:,14) = [11,-11,-5,-5,5,5,21] flv_born (:,15) = [11,-11,-5,-3,3,5,21] flv_born (:,16) = [11,-11,-5,-1,1,5,21] flv_born (:,17) = [11,-11,-5,5,21,21,21] flv_born (:,18) = [11,-11,-3,-3,3,3,21] flv_born (:,19) = [11,-11,-3,-1,1,3,21] flv_born (:,20) = [11,-11,-3,3,21,21,21] flv_born (:,21) = [11,-11,-1,-1,1,1,21] flv_born (:,22) = [11,-11,-1,1,21,21,21] flv_real (:,1) = [11,-11,-4,-4,-4,4,4,4] flv_real (:,2) = [11,-11,-4,-4,-2,2,4,4] flv_real (:,3) = [11,-11,-4,-4,4,4,21,21] flv_real (:,4) = [11,-11,-4,-4,-5,4,4,5] flv_real (:,5) = [11,-11,-4,-4,-3,4,4,3] flv_real (:,6) = [11,-11,-4,-4,-1,2,4,3] flv_real (:,7) = [11,-11,-4,-4,-1,4,4,1] flv_real (:,8) = [11,-11,-4,-2,-2,2,2,4] flv_real (:,9) = [11,-11,-4,-2,2,4,21,21] flv_real (:,10) = [11,-11,-4,-2,-5,2,4,5] flv_real (:,11) = [11,-11,-4,-2,-3,2,4,3] flv_real (:,12) = [11,-11,-4,-2,-3,4,4,1] flv_real (:,13) = [11,-11,-4,-2,-1,2,2,3] flv_real (:,14) = [11,-11,-4,-2,-1,2,4,1] flv_real (:,15) = [11,-11,-4,4,21,21,21,21] flv_real (:,16) = [11,-11,-4,-5,4,5,21,21] flv_real (:,17) = [11,-11,-4,-5,-5,4,5,5] flv_real (:,18) = [11,-11,-4,-5,-3,4,3,5] flv_real (:,19) = [11,-11,-4,-5,-1,2,3,5] flv_real (:,20) = [11,-11,-4,-5,-1,4,1,5] flv_real (:,21) = [11,-11,-4,-3,4,3,21,21] flv_real (:,22) = [11,-11,-4,-3,-3,4,3,3] flv_real (:,23) = [11,-11,-4,-3,-1,2,3,3] flv_real (:,24) = [11,-11,-4,-3,-1,4,1,3] flv_real (:,25) = [11,-11,-4,-1,2,3,21,21] flv_real (:,26) = [11,-11,-4,-1,4,1,21,21] flv_real (:,27) = [11,-11,-4,-1,-1,2,1,3] flv_real (:,28) = [11,-11,-4,-1,-1,4,1,1] flv_real (:,29) = [11,-11,-2,-2,-2,2,2,2] flv_real (:,30) = [11,-11,-2,-2,2,2,21,21] flv_real (:,31) = [11,-11,-2,-2,-5,2,2,5] flv_real (:,32) = [11,-11,-2,-2,-3,2,2,3] flv_real (:,33) = [11,-11,-2,-2,-3,2,4,1] flv_real (:,34) = [11,-11,-2,-2,-1,2,2,1] flv_real (:,35) = [11,-11,-2,2,21,21,21,21] flv_real (:,36) = [11,-11,-2,-5,2,5,21,21] flv_real (:,37) = [11,-11,-2,-5,-5,2,5,5] flv_real (:,38) = [11,-11,-2,-5,-3,2,3,5] flv_real (:,39) = [11,-11,-2,-5,-3,4,1,5] flv_real (:,40) = [11,-11,-2,-5,-1,2,1,5] flv_real (:,41) = [11,-11,-2,-3,2,3,21,21] flv_real (:,42) = [11,-11,-2,-3,4,1,21,21] flv_real (:,43) = [11,-11,-2,-3,-3,2,3,3] flv_real (:,44) = [11,-11,-2,-3,-3,4,1,3] flv_real (:,45) = [11,-11,-2,-3,-1,2,1,3] flv_real (:,46) = [11,-11,-2,-3,-1,4,1,1] flv_real (:,47) = [11,-11,-2,-1,2,1,21,21] flv_real (:,48) = [11,-11,-2,-1,-1,2,1,1] flv_real (:,49) = [11,-11,-5,-5,-5,5,5,5] flv_real (:,50) = [11,-11,-5,-5,-3,3,5,5] flv_real (:,51) = [11,-11,-5,-5,-1,1,5,5] flv_real (:,52) = [11,-11,-5,-5,5,5,21,21] flv_real (:,53) = [11,-11,-5,-3,-3,3,3,5] flv_real (:,54) = [11,-11,-5,-3,-1,1,3,5] flv_real (:,55) = [11,-11,-5,-3,3,5,21,21] flv_real (:,56) = [11,-11,-5,-1,-1,1,1,5] flv_real (:,57) = [11,-11,-5,-1,1,5,21,21] flv_real (:,58) = [11,-11,-5,5,21,21,21,21] flv_real (:,59) = [11,-11,-3,-3,-3,3,3,3] flv_real (:,60) = [11,-11,-3,-3,-1,1,3,3] flv_real (:,61) = [11,-11,-3,-3,3,3,21,21] flv_real (:,62) = [11,-11,-3,-1,-1,1,1,3] flv_real (:,63) = [11,-11,-3,-1,1,3,21,21] flv_real (:,64) = [11,-11,-3,3,21,21,21,21] flv_real (:,65) = [11,-11,-1,-1,-1,1,1,1] flv_real (:,66) = [11,-11,-1,-1,1,1,21,21] flv_real (:,67) = [11,-11,-1,1,21,21,21,21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"), 2, 3) call reg_data%check_consistency (.false., u) call reg_data%write (u) deallocate (flv_born, flv_real) call reg_data%final () end subroutine fks_regions_5 @ %def fks_regions_5 @ <>= public :: fks_regions_6 <>= subroutine fks_regions_6 (u) integer, intent(in) :: u integer :: n_flv_born, n_flv_real integer :: n_legs_born, n_legs_real integer :: n_in integer, dimension(:,:), allocatable :: flv_born, flv_real type(region_data_t) :: reg_data integer :: i, j integer, dimension(10) :: flavors write (u, "(A)") "* Test output: fks_regions_6" write (u, "(A)") "* Create table of singular regions for Drell Yan" write (u, "(A)") n_flv_born = 10; n_flv_real = 30 n_legs_born = 4; n_legs_real = 5 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flavors = [-5, -4, -3, -2, -1, 1, 2, 3, 4, 5] do i = 1, n_flv_born flv_born (3:4, i) = [11, -11] end do do j = 1, n_flv_born flv_born (1, j) = flavors (j) flv_born (2, j) = -flavors (j) end do do i = 1, n_flv_real flv_real (3:4, i) = [11, -11] end do i = 1 do j = 1, n_flv_real if (mod (j, 3) == 1) then flv_real (1, j) = flavors (i) flv_real (2, j) = -flavors (i) flv_real (5, j) = 21 else if (mod (j, 3) == 2) then flv_real (1, j) = flavors (i) flv_real (2, j) = 21 flv_real (5, j) = flavors (i) else flv_real (1, j) = 21 flv_real (2, j) = -flavors (i) flv_real (5, j) = -flavors (i) i = i + 1 end if end do call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"), 2, 0) call reg_data%check_consistency (.false., u) call reg_data%write (u) call write_separator (u) deallocate (flv_born, flv_real) call reg_data%final () write (u, "(A)") "* Create table of singular regions for hadronic top decay" write (u, "(A)") n_flv_born = 1; n_flv_real = 1 n_legs_born = 4; n_legs_real = 5 n_in = 1 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [6, -5, 2, -1] flv_real (:, 1) = [6, -5, 2, -1, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"), 0, 2) call reg_data%check_consistency (.false., u) call reg_data%write (u) call write_separator (u) deallocate (flv_born, flv_real) call reg_data%final () write (u, "(A)") "* Create table of singular regions for dijet s sbar -> jet jet" write (u, "(A)") "* With jet = u:d:gl" write (u, "(A)") n_flv_born = 3; n_flv_real = 3 n_legs_born = 4; n_legs_real = 5 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) do i = 1, n_flv_born flv_born (1:2, i) = [3, -3] end do flv_born (3, :) = [1, 2, 21] flv_born (4, :) = [-1, -2, 21] do i = 1, n_flv_real flv_real (1:2, i) = [3, -3] end do flv_real (3, :) = [1, 2, 21] flv_real (4, :) = [-1, -2, 21] flv_real (5, :) = [21, 21, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"), 0, 2) call reg_data%check_consistency (.false., u) call reg_data%write (u) call reg_data%final () end subroutine fks_regions_6 @ %def fks_regions_6 @ <>= public :: fks_regions_7 <>= subroutine fks_regions_7 (u) integer, intent(in) :: u integer :: n_flv_born, n_flv_real integer :: n_legs_born, n_legs_real integer :: n_in integer, dimension(:,:), allocatable :: flv_born, flv_real type(region_data_t) :: reg_data write (u, "(A)") "* Test output: fks_regions_7" write (u, "(A)") "* Create table of singular regions for ee -> qq" write (u, "(A)") n_flv_born = 1; n_flv_real = 1 n_legs_born = 4; n_legs_real = 5 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, 2, -2] flv_real (:, 1) = [11, -11, 2, -2, 21] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"), 2, 0) call reg_data%write_latex (u) call reg_data%final () end subroutine fks_regions_7 @ %def fks_regions_7 @ <>= public :: fks_regions_8 <>= subroutine fks_regions_8 (u) integer, intent(in) :: u integer :: n_flv_born, n_flv_real integer :: n_legs_born, n_legs_real integer :: n_in integer, dimension(:,:), allocatable :: flv_born, flv_real type(region_data_t) :: reg_data integer :: i, j integer, dimension(10) :: flavors write (u, "(A)") "* Test output: fks_regions_8" write (u, "(A)") "* Create table of singular regions for ee -> ee" write (u, "(A)") n_flv_born = 1; n_flv_real = 3 n_legs_born = 4; n_legs_real = 5 n_in = 2 allocate (flv_born (n_legs_born, n_flv_born)) allocate (flv_real (n_legs_real, n_flv_real)) flv_born (:, 1) = [11, -11, -11, 11] flv_real (:, 1) = [11, -11, -11, 11, 22] flv_real (:, 2) = [11, 22, -11, 11, 11] flv_real (:, 3) = [22, -11, 11, -11, -11] call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("EW"), 2, 0) call reg_data%check_consistency (.false., u) call reg_data%write (u) call reg_data%final () end subroutine fks_regions_8 @ %def fks_regions_8 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Virtual contribution to the cross section} <<[[virtual.f90]]>>= <> module virtual <> <> <> use numeric_utils use constants use diagnostics use pdg_arrays use models use model_data, only: model_data_t, field_data_t use physics_defs use sm_physics use lorentz use flavors use nlo_data, only: get_threshold_momenta, nlo_settings_t use nlo_data, only: ASSOCIATED_LEG_PAIR use fks_regions <> <> <> <> contains <> end module virtual @ %def virtual @ <>= public :: virtual_t <>= type :: virtual_t type(nlo_settings_t) :: settings real(default), dimension(:,:,:), allocatable :: gamma_0, gamma_p, c_flv real(default) :: fac_scale real(default), allocatable :: ren_scale real(default), allocatable :: es_scale2 integer, dimension(:), allocatable :: n_is_neutrinos integer :: n_in, n_legs, n_flv logical :: bad_point = .false. type(string_t) :: selection real(default), dimension(:), allocatable :: sqme_born real(default), dimension(:), allocatable :: sqme_virt_fin real(default), dimension(:,:,:), allocatable :: sqme_color_c real(default), dimension(:,:,:), allocatable :: sqme_charge_c logical :: has_pdfs = .false. contains <> end type virtual_t @ %def virtual_t @ <>= procedure :: init => virtual_init <>= subroutine virtual_init (virt, flv_born, n_in, settings, model, has_pdfs) class(virtual_t), intent(inout) :: virt integer, intent(in), dimension(:,:) :: flv_born integer, intent(in) :: n_in type(nlo_settings_t), intent(in) :: settings class(model_data_t), intent(in) :: model logical, intent(in) :: has_pdfs integer :: i_flv, n_corr n_corr = 2 virt%n_legs = size (flv_born, 1); virt%n_flv = size (flv_born, 2) virt%n_in = n_in allocate (virt%sqme_born (virt%n_flv)) allocate (virt%sqme_virt_fin (virt%n_flv)) allocate (virt%sqme_color_c (virt%n_legs, virt%n_legs, virt%n_flv)) allocate (virt%sqme_charge_c (virt%n_legs, virt%n_legs, virt%n_flv)) allocate (virt%gamma_0 (virt%n_legs, virt%n_flv, n_corr), & virt%gamma_p (virt%n_legs, virt%n_flv, n_corr), & virt%c_flv (virt%n_legs, virt%n_flv, n_corr)) call virt%init_constants (flv_born, settings%fks_template%n_f, model) allocate (virt%n_is_neutrinos (virt%n_flv)) virt%n_is_neutrinos = 0 do i_flv = 1, virt%n_flv if (is_neutrino (flv_born(1, i_flv))) & virt%n_is_neutrinos(i_flv) = virt%n_is_neutrinos(i_flv) + 1 if (is_neutrino (flv_born(2, i_flv))) & virt%n_is_neutrinos(i_flv) = virt%n_is_neutrinos(i_flv) + 1 end do select case (char (settings%virtual_selection)) case ("Full", "OLP", "Subtraction") virt%selection = settings%virtual_selection case default call msg_fatal ('Virtual selection: Possible values are "Full", "OLP" or "Subtraction') end select virt%settings = settings virt%has_pdfs = has_pdfs contains function is_neutrino (flv) result (neutrino) integer, intent(in) :: flv logical :: neutrino neutrino = (abs(flv) == 12 .or. abs(flv) == 14 .or. abs(flv) == 16) end function is_neutrino end subroutine virtual_init @ %def virtual_init @ The virtual subtraction terms contain Casimir operators and derived constants, listed below: \begin{align} \label{eqn:C(q)} C(q) = C(\bar{q}) &= C_F, \\ \label{eqn:C(g)} C(g) &= C_A,\\ \label{eqn:gamma(q)} \gamma(q) = \gamma(\bar{q}) &= \frac{3}{2} C_F,\\ \label{eqn:gamma(g)} \gamma(g) &= \frac{11}{6} C_A - \frac{2}{3} T_F N_f,\\ \label{eqn:gammap(q)} \gamma'(q) = \gamma'(\bar{q}) &= \left(\frac{13}{2} - \frac{2\pi^2}{3}\right) C_F, \\ \label{eqn:gammap(g)} \gamma'(g) &= \left(\frac{67}{9} - \frac{2\pi^2}{3}\right) C_A - \frac{23}{9} T_F N_f. \end{align} For uncolored particles, [[virtual_init_constants]] sets $C$, $\gamma$ and $\gamma'$ to zero. <>= procedure :: init_constants => virtual_init_constants <>= subroutine virtual_init_constants (virt, flv_born, nf_input, model) class(virtual_t), intent(inout) :: virt integer, intent(in), dimension(:,:) :: flv_born integer, intent(in) :: nf_input type(string_t), dimension(2) :: corr_type class(model_data_t), intent(in) :: model type(field_data_t), pointer :: field integer :: i_part, i_flv, pdg, i_corr real(default) :: nf, CA_factor, TR_sum real(default), dimension(:,:), allocatable :: CF_factor, TR_factor type(flavor_t) :: flv allocate (CF_factor (size (flv_born, 1), size (flv_born, 2)), & TR_factor (size (flv_born, 1), size (flv_born, 2))) - TR_sum = 0 corr_type (1) = "QCD"; corr_type (2) = "EW" do i_corr = 1, 2 + TR_sum = 0 if (i_corr == 1) then CA_factor = CA; CF_factor = CF; TR_factor = TR nf = real(nf_input, default) TR_sum = nf * TR else CA_factor = zero do i_flv = 1, size (flv_born, 2) do i_part = 1, size (flv_born, 1) call flv%init (flv_born(i_part, i_flv), model) CF_factor(i_part, i_flv) = (flv%get_charge ())**2 TR_factor(i_part, i_flv) = (flv%get_charge ())**2 if (is_quark (flv_born (i_part, i_flv))) & TR_factor(i_part, i_flv) = NC * TR_factor(i_part, i_flv) end do end do do pdg = 1, nf_input field => model%get_field_ptr (pdg) TR_sum = TR_sum + NC*field%get_charge()**2 end do do pdg = 11, 15, 2 field => model%get_field_ptr (pdg) if (field%get_mass() > 0) exit TR_sum = TR_sum + field%get_charge()**2 end do end if do i_flv = 1, size (flv_born, 2) do i_part = 1, size (flv_born, 1) if (is_massless_vectorboson (flv_born(i_part, i_flv), corr_type (i_corr))) then virt%gamma_0(i_part, i_flv, i_corr) = 11._default / 6._default * CA_factor & - two / three * TR_sum virt%gamma_p(i_part, i_flv, i_corr) = (67._default / 9._default & - two * pi**2 / three) * CA_factor & - 23._default / 9._default * TR_sum virt%c_flv(i_part, i_flv, i_corr) = CA_factor else if (is_corresponding_fermion (flv_born(i_part, i_flv), corr_type (i_corr))) then virt%gamma_0(i_part, i_flv, i_corr) = 1.5_default * CF_factor(i_part, i_flv) virt%gamma_p(i_part, i_flv, i_corr) = (6.5_default - two * pi**2 / three) * CF_factor(i_part, i_flv) virt%c_flv(i_part, i_flv, i_corr) = CF_factor(i_part, i_flv) else if (is_massive_vectorboson (flv_born(i_part, i_flv), corr_type (i_corr))) then virt%gamma_0(i_part, i_flv, i_corr) = zero virt%gamma_p(i_part, i_flv, i_corr) = zero virt%c_flv(i_part, i_flv, i_corr) = CF_factor(i_part, i_flv) else virt%gamma_0(i_part, i_flv, i_corr) = zero virt%gamma_p(i_part, i_flv, i_corr) = zero virt%c_flv(i_part, i_flv, i_corr) = zero end if end do end do end do contains function is_massless_vectorboson (pdg_nr, nlo_corr_type) logical :: is_massless_vectorboson integer, intent(in) :: pdg_nr type(string_t), intent(in) :: nlo_corr_type is_massless_vectorboson = .false. if (nlo_corr_type == "QCD") then is_massless_vectorboson = is_gluon (pdg_nr) else if (nlo_corr_type == "EW") then is_massless_vectorboson = is_photon (pdg_nr) end if end function is_massless_vectorboson function is_corresponding_fermion (pdg_nr, nlo_corr_type) logical :: is_corresponding_fermion integer, intent(in) :: pdg_nr type(string_t), intent(in) :: nlo_corr_type is_corresponding_fermion = .false. if (nlo_corr_type == "QCD") then is_corresponding_fermion = is_quark (pdg_nr) else if (nlo_corr_type == "EW") then is_corresponding_fermion = is_fermion (pdg_nr) end if end function is_corresponding_fermion function is_massive_vectorboson (pdg_nr, nlo_corr_type) logical :: is_massive_vectorboson integer, intent(in) :: pdg_nr type(string_t), intent(in) :: nlo_corr_type is_massive_vectorboson = .false. if (nlo_corr_type == "EW") then is_massive_vectorboson = is_massive_vector (pdg_nr) end if end function is_massive_vectorboson end subroutine virtual_init_constants @ %def virtual_init_constants @ Set the renormalization scale. If the input is zero, use the center-of-mass energy. <>= procedure :: set_ren_scale => virtual_set_ren_scale <>= subroutine virtual_set_ren_scale (virt, ren_scale) class(virtual_t), intent(inout) :: virt real(default), allocatable, intent(in) :: ren_scale if (allocated (ren_scale)) then if (allocated (virt%ren_scale)) then virt%ren_scale = ren_scale else allocate (virt%ren_scale, source=ren_scale) end if end if end subroutine virtual_set_ren_scale @ %def virtual_set_ren_scale @ <>= procedure :: set_fac_scale => virtual_set_fac_scale <>= subroutine virtual_set_fac_scale (virt, p, fac_scale) class(virtual_t), intent(inout) :: virt type(vector4_t), dimension(:), intent(in) :: p real(default), optional :: fac_scale if (present (fac_scale)) then virt%fac_scale = fac_scale else virt%fac_scale = (p(1) + p(2))**1 end if end subroutine virtual_set_fac_scale @ %def virtual_set_fac_scale <>= procedure :: set_ellis_sexton_scale => virtual_set_ellis_sexton_scale <>= subroutine virtual_set_ellis_sexton_scale (virt, Q) class(virtual_t), intent(inout) :: virt real(default), allocatable, intent(in) :: Q if (allocated (Q)) then if (allocated (virt%es_scale2)) then virt%es_scale2 = Q * Q else allocate (virt%es_scale2, source=Q*Q) end if end if end subroutine virtual_set_ellis_sexton_scale @ %def virtual_set_ellis_sexton_scale @ The virtual-subtracted matrix element is given by the equation \begin{equation} \label{eqn:virt_sub} \mathcal{V} = \frac{\alpha_s}{2\pi}\left(\mathcal{Q}\mathcal{B} + \sum \mathcal{I}_{ij}\mathcal{B}_{ij} + \mathcal{V}_{fin}\right), \end{equation} The expressions for $\mathcal{Q}$ can be found in equations \ref{eqn:virt_Q_isr} and \ref{eqn:virt_Q_fsr}. The expressions for $\mathcal{I}_{ij}$ can be found in equations (\ref{I_00}), (\ref{I_mm}), (\ref{I_0m}), depending on whether the particles involved in the radiation process are massive or massless. If two or more flavor structures would produce the same amplitude we only compute one and use the [[eqv_index]] to copy the result to the others (if [[reuse_amplitudes_fks]] is true). The Ellis-Sexton scale is set when explicitly allocated; if not it first is set to the renormalization scale; if that it is not set it will be set to the factorization scale which is the scale used for the virtual corrections. <>= procedure :: evaluate => virtual_evaluate <>= subroutine virtual_evaluate (virt, reg_data, alpha_coupling, & p_born, separate_uborns, sqme_virt) class(virtual_t), intent(inout) :: virt type(region_data_t), intent(in) :: reg_data real(default), dimension(2), intent(in) :: alpha_coupling type(vector4_t), intent(in), dimension(:) :: p_born logical, intent(in) :: separate_uborns real(default), dimension(:), intent(inout) :: sqme_virt integer, dimension(:), allocatable :: eqv_flv_index real(default), dimension(:), allocatable :: sqme_virt_arr real(default) :: s, s_o_Q2, es_scale2 real(default), dimension(reg_data%n_flv_born) :: QB, BI integer :: i_flv, ii_flv, alr, i_corr logical, dimension(:), allocatable :: flv_evaluated integer, dimension(:), allocatable :: corr_index logical :: alr_qcd, alr_ew - QB = zero; BI = zero allocate (flv_evaluated(reg_data%n_flv_born)) allocate (sqme_virt_arr(reg_data%n_flv_born)) sqme_virt_arr = zero flv_evaluated = .false. if (virt%bad_point) return if (allocated (virt%es_scale2)) then es_scale2 = virt%es_scale2 else if (allocated (virt%ren_scale)) then es_scale2 = virt%ren_scale**2 else es_scale2 = virt%fac_scale**2 end if end if if (debug2_active (D_VIRTUAL)) then print *, 'Compute virtual component using alpha = ', alpha_coupling print *, 'Virtual selection: ', char (virt%selection) print *, 'virt%es_scale2 = ', es_scale2 !!! Debugging end if s = sum (p_born(1 : virt%n_in))**2 if (virt%settings%factorization_mode == FACTORIZATION_THRESHOLD) & call set_s_for_threshold () s_o_Q2 = s / es_scale2 * virt%settings%fks_template%xi_cut**2 eqv_flv_index = reg_data%eqv_flv_index_born do i_flv = 1, reg_data%n_flv_born alr_qcd = .false.; alr_ew = .false. do alr = 1, reg_data%n_regions if (i_flv == reg_data%regions(alr)%uborn_index) then if (reg_data%regions(alr)%nlo_correction_type == "QCD") then alr_qcd = .true. else if (reg_data%regions(alr)%nlo_correction_type == "EW") then alr_ew = .true. end if end if end do if (alr_qcd .and. alr_ew) then allocate (corr_index (2)) corr_index (1) = 1; corr_index (2) = 2 else allocate (corr_index (1)) corr_index (1) = 0 if (alr_qcd) then corr_index (1) = 1 else if (alr_ew) then corr_index (1) = 2 end if end if if (.not. flv_evaluated(eqv_flv_index(i_flv)) .and. corr_index(1) > 0) then if (virt%selection == var_str ("Full") .or. virt%selection == var_str ("OLP")) then !!! A factor of alpha_coupling/twopi is assumed to be included in vfin sqme_virt_arr(i_flv) = sqme_virt_arr(i_flv) + virt%sqme_virt_fin(i_flv) end if do i_corr = 1, size (corr_index) + QB = zero; BI = zero if (virt%selection == var_str ("Full") .or. & virt%selection == var_str ("Subtraction")) then call virt%evaluate_initial_state (i_flv, corr_index (i_corr), reg_data, QB) call virt%compute_collinear_contribution & (i_flv, corr_index (i_corr), p_born, sqrt(s), reg_data, QB) select case (virt%settings%factorization_mode) case (FACTORIZATION_THRESHOLD) call virt%compute_eikonals_threshold (i_flv, p_born, s_o_Q2, QB, BI) case default call virt%compute_massive_self_eikonals & (i_flv, corr_index (i_corr), p_born, s_o_Q2, reg_data, QB) call virt%compute_eikonals & (i_flv, corr_index (i_corr), p_born, s_o_Q2, reg_data, BI) end select if (debug2_active (D_VIRTUAL)) then if (corr_index (i_corr) == 1) then print *, 'Correction type: QCD' else print *, 'Correction type: EW' end if print *, 'Evaluate i_flv: ', i_flv print *, 'sqme_born: ', virt%sqme_born (i_flv) print *, 'Q * sqme_born: ', alpha_coupling / twopi * QB(i_flv) print *, 'BI: ', alpha_coupling / twopi * BI(i_flv) print *, 'vfin: ', virt%sqme_virt_fin (i_flv) end if sqme_virt_arr(i_flv) = sqme_virt_arr(i_flv) & + alpha_coupling (corr_index (i_corr))/ twopi * (QB(i_flv) + BI(i_flv)) end if end do if (.not. (debug_active (D_VIRTUAL) .or. & debug2_active (D_VIRTUAL))) flv_evaluated(eqv_flv_index(i_flv)) = .true. else sqme_virt_arr(i_flv) = sqme_virt_arr(eqv_flv_index(i_flv)) end if if (separate_uborns) then sqme_virt(i_flv) = sqme_virt(i_flv) + sqme_virt_arr(i_flv) else sqme_virt(1) = sqme_virt(1) + sqme_virt_arr(i_flv) end if deallocate (corr_index) end do if (debug2_active (D_VIRTUAL)) then call msg_debug2 (D_VIRTUAL, "virtual-subtracted matrix element(s): ") print *, sqme_virt end if do i_flv = 1, reg_data%n_flv_born if (virt%n_is_neutrinos(i_flv) > 0) & sqme_virt = sqme_virt * virt%n_is_neutrinos(i_flv) * two end do contains subroutine set_s_for_threshold () use ttv_formfactors, only: m1s_to_mpole real(default) :: mtop2 mtop2 = m1s_to_mpole (sqrt(s))**2 if (s < four * mtop2) s = four * mtop2 end subroutine set_s_for_threshold end subroutine virtual_evaluate @ %def virtual_evaluate @ <>= procedure :: compute_eikonals => virtual_compute_eikonals <>= subroutine virtual_compute_eikonals (virtual, i_flv, i_corr, & p_born, s_o_Q2, reg_data, BI) class(virtual_t), intent(inout) :: virtual integer, intent(in) :: i_flv, i_corr type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in) :: s_o_Q2 type(region_data_t), intent(in) :: reg_data real(default), intent(inout), dimension(:) :: BI integer :: i, j real(default) :: I_ij, BI_tmp BI_tmp = zero ! TODO vincent_r: Split the procedure into one computing QCD eikonals and one computing QED eikonals. ! TODO vincent_r: In the best case, remove the dependency on reg_data completely. associate (flst_born => reg_data%flv_born(i_flv)) do i = 1, virtual%n_legs do j = 1, virtual%n_legs if (i /= j) then if (i_corr == 1) then if (flst_born%colored(i) .and. flst_born%colored(j)) then I_ij = compute_eikonal_factor (p_born, flst_born%massive, & i, j, s_o_Q2) BI_tmp = BI_tmp + virtual%sqme_color_c (i, j, i_flv) * I_ij if (debug2_active (D_VIRTUAL)) & print *, 'b_ij: ', i, j, virtual%sqme_color_c (i, j, i_flv), 'I_ij: ', I_ij end if else if (i_corr == 2) then I_ij = compute_eikonal_factor (p_born, flst_born%massive, & i, j, s_o_Q2) BI_tmp = BI_tmp + virtual%sqme_charge_c (i, j, i_flv) * I_ij if (debug2_active (D_VIRTUAL)) & print *, 'b_ij: ', virtual%sqme_charge_c (i, j, i_flv), 'I_ij: ', I_ij end if else if (debug2_active (D_VIRTUAL)) then if (i_corr == 1) then print *, 'b_ij: ', i, j, virtual%sqme_color_c (i, j, i_flv), 'I_ij: ', I_ij else if (i_corr == 2) then print *, 'b_ij: ', i, j, virtual%sqme_charge_c (i, j, i_flv), 'I_ij: ', I_ij end if end if end do end do if (virtual%settings%use_internal_color_correlations .or. i_corr == 2) & BI_tmp = BI_tmp * virtual%sqme_born (i_flv) end associate BI(i_flv) = BI(i_flv) + BI_tmp end subroutine virtual_compute_eikonals @ %def virtual_compute_eikonals @ <>= procedure :: compute_eikonals_threshold => virtual_compute_eikonals_threshold <>= subroutine virtual_compute_eikonals_threshold (virtual, i_flv, & p_born, s_o_Q2, QB, BI) class(virtual_t), intent(in) :: virtual integer, intent(in) :: i_flv type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in) :: s_o_Q2 real(default), intent(inout), dimension(:) :: QB real(default), intent(inout), dimension(:) :: BI type(vector4_t), dimension(4) :: p_thr integer :: leg BI = zero; p_thr = get_threshold_momenta (p_born) call compute_massive_self_eikonals (virtual%sqme_born(i_flv), QB(i_flv)) do leg = 1, 2 BI(i_flv) = BI(i_flv) + evaluate_leg_pair (ASSOCIATED_LEG_PAIR(leg), i_flv) end do contains subroutine compute_massive_self_eikonals (sqme_born, QB) real(default), intent(in) :: sqme_born real(default), intent(inout) :: QB integer :: i if (debug_on) call msg_debug2 (D_VIRTUAL, "compute_massive_self_eikonals") if (debug_on) call msg_debug2 (D_VIRTUAL, "s_o_Q2", s_o_Q2) if (debug_on) call msg_debug2 (D_VIRTUAL, "log (s_o_Q2)", log (s_o_Q2)) do i = 1, 4 QB = QB - (cf * (log (s_o_Q2) - 0.5_default * I_m_eps (p_thr(i)))) & * sqme_born end do end subroutine compute_massive_self_eikonals function evaluate_leg_pair (i_start, i_flv) result (b_ij_times_I) real(default) :: b_ij_times_I integer, intent(in) :: i_start, i_flv real(default) :: I_ij integer :: i, j b_ij_times_I = zero do i = i_start, i_start + 1 do j = i_start, i_start + 1 if (i /= j) then I_ij = compute_eikonal_factor & (p_thr, [.true., .true., .true., .true.], i, j, s_o_Q2) b_ij_times_I = b_ij_times_I + & virtual%sqme_color_c (i, j, i_flv) * I_ij if (debug2_active (D_VIRTUAL)) & print *, 'b_ij: ', virtual%sqme_color_c (i, j, i_flv), 'I_ij: ', I_ij end if end do end do if (virtual%settings%use_internal_color_correlations) & b_ij_times_I = b_ij_times_I * virtual%sqme_born (i_flv) if (debug2_active (D_VIRTUAL)) then print *, 'internal color: ', virtual%settings%use_internal_color_correlations print *, 'b_ij_times_I = ', b_ij_times_I print *, 'QB = ', QB end if end function evaluate_leg_pair end subroutine virtual_compute_eikonals_threshold @ %def virtual_compute_eikonals_threshold @ <>= procedure :: set_bad_point => virtual_set_bad_point <>= subroutine virtual_set_bad_point (virt, value) class(virtual_t), intent(inout) :: virt logical, intent(in) :: value virt%bad_point = value end subroutine virtual_set_bad_point @ %def virtual_set_bad_point @ The collinear limit of $\tilde{\mathcal{R}}$ can be integrated over the radiation degrees of freedom, giving the collinear contribution to the virtual component. Its general structure is $\mathcal{Q} \cdot \mathcal{B}$. The initial-state contribution to $\mathcal{Q}$ is simply given by \begin{equation} \label{eqn:virt_Q_isr} \mathcal{Q} = -\log\frac{\mu_F^2}{Q^2} \left(\gamma(\mathcal{I}_1) + 2 C (\mathcal{I}_1) \log(\xi_{\text{cut}}) + \gamma(\mathcal{I}_2) + 2 C (\mathcal{I}_2) \log(\xi_{\text{cut}}) \right), \end{equation} where $Q^2$ is the Ellis-Sexton scale and $\gamma$ is as in eqns. \ref{eqn:gamma(q)} and \ref{eqn:gamma(g)}.\\ [[virtual_evaluate_initial_state]] computes this quantity. The loop over the initial-state particles is only executed if we are dealing with a scattering process, because for decays there are no virtual initial-initial interactions. <>= procedure :: evaluate_initial_state => virtual_evaluate_initial_state <>= subroutine virtual_evaluate_initial_state (virt, i_flv, i_corr, reg_data, QB) class(virtual_t), intent(inout) :: virt type(region_data_t), intent(in) :: reg_data integer, intent(in) :: i_flv, i_corr real(default), intent(inout), dimension(:) :: QB real(default) :: sqme_born_virt, es_scale2 integer :: i if (allocated (virt%es_scale2)) then es_scale2 = virt%es_scale2 else if (allocated (virt%ren_scale)) then es_scale2 = virt%ren_scale**2 else es_scale2 = virt%fac_scale**2 end if end if sqme_born_virt = zero if (reg_data%nlo_correction_type == "EW" .and. i_corr == 1 & .and. qcd_ew_interferences (reg_data%flv_born(i_flv)%flst)) then do i = 1, size (reg_data%flv_born(i_flv)%flst) if (is_quark (reg_data%flv_born(i_flv)%flst (i))) then sqme_born_virt = -virt%sqme_color_c (i, i, i_flv)/CF exit end if end do else sqme_born_virt = virt%sqme_born (i_flv) end if if (virt%n_in == 2) then do i = 1, virt%n_in QB(i_flv) = QB(i_flv) - (virt%gamma_0 (i, i_flv, i_corr) & + two * virt%c_flv(i, i_flv, i_corr) & * log (virt%settings%fks_template%xi_cut)) & * log(virt%fac_scale**2 / es_scale2) * sqme_born_virt end do end if end subroutine virtual_evaluate_initial_state @ %def virtual_evaluate_initial_state @ Same as above, but for final-state particles. The collinear limit for final-state particles follows from the integral \begin{equation*} I_{+,\alpha_r} = \int d\Phi_{n+1} \frac{\xi_+^{-1-2\epsilon}}{\xi^{-1-2\epsilon}} \mathcal{R}_{\alpha_r}. \end{equation*} We can distinguish three situations: \begin{enumerate} \item $\alpha_r$ contains a massive emitter. In this case, no collinear subtraction term is required and the integral above is irrelevant. \item $\alpha_r$ contains a massless emitter, but resonances are not taken into account in the subtraction. Here, $\xi_{max} = \frac{2E_{em}}{\sqrt{s}}$ is the upper bound on $\xi$. \item $\alpha_r$ contains a massless emitter and resonance-aware subtraction is used. Here, $\xi_{max} = \frac{2E_{em}}{\sqrt{k_{res}^2}}$. \end{enumerate} Before version 2.4, only situations 1 and 2 were covered. The difference between situation 2 and 3 comes from the expansion of the plus-distribution in the integral above, \begin{equation*} \xi_+^{-1-2\epsilon} = \xi^{-1-2\epsilon} + \frac{1}{2\epsilon}\delta(\xi) = \xi_{max}^{-1-2\epsilon}\left[(1-z)^{-1-2\epsilon} + \frac{\xi_{max}^{2\epsilon}}{2\epsilon}\delta(1-z)\right]. \end{equation*} The expression from the standard FKS literature is given by $\mathcal{Q}$ is given by \begin{equation} \label{eqn:virt_Q_fsr_old} \begin{split} \mathcal{Q} = \sum_{k=n_{in}}^{n_L^{(B)}} \left[\gamma'(\mathcal{I}_k) - \log\frac{s\delta_o}{2Q^2}\left(\gamma(\mathcal{I}_k) - 2C(\mathcal{I}_k) \log\frac{2E_k}{\xi_{\text{cut}}\sqrt{s}}\right) \right.\\ + \left. 2C(\mathcal{I}_k) \left( \log^2\frac{2E_k}{\sqrt{s}} - \log^2 \xi_{\text{cut}} \right) - 2\gamma(\mathcal{I}_k)\log\frac{2E_k}{\sqrt{s}}\right]. \end{split} \end{equation} $n_L^{(B)}$ is the number of legs at Born level. Here, $\xi_{max}$ is implicitly present in the ratios in the logarithms. Using the resonance-aware $\xi_{max}$ yields \begin{equation} \label{eqn:virt_Q_fsr} \begin{split} \mathcal{Q} = \sum_{k=n_{in}}^{n_L^{(B)}} \left[\gamma'(\mathcal{I}_k) + 2\left(\log\frac{\sqrt{s}}{2E_{em}} + \log\xi_{max}\right) \left(\log\frac{\sqrt{s}}{2E_{em}} + \log\xi_{max} + \log\frac{Q^2}{s}\right) C(\mathcal{I}_k) \right.\\ + \left. 2 \log\xi_{max} \left(\log\xi_{max} - \log\frac{Q^2}{k_{res}^2}\right) C(\mathcal{I}_k) + \left(\log\frac{Q^2}{k_{res}^2} - 2 \log\xi_{max}\right) \gamma(\mathcal{I}_k)\right]. \end{split} \end{equation} Equation \ref{eqn:virt_Q_fsr} leads to \ref{eqn:virt_Q_fsr_old} with the substitutions $\xi_{max} \rightarrow \frac{2E_{em}}{\sqrt{s}}$ and $k_{res}^2 \rightarrow s$. [[virtual_compute_collinear_contribution]] only implements the second one. <>= procedure :: compute_collinear_contribution & => virtual_compute_collinear_contribution <>= subroutine virtual_compute_collinear_contribution (virt, i_flv, i_corr, & p_born, sqrts, reg_data, QB) class(virtual_t), intent(inout) :: virt integer, intent(in) :: i_flv, i_corr type(vector4_t), dimension(:), intent(in) :: p_born real(default), intent(in) :: sqrts type(region_data_t), intent(in) :: reg_data real(default), intent(inout), dimension(:) :: QB real(default) :: s1, s2, s3, s4, s5 real(default) :: sqme_born_virt integer :: alr, em, i real(default) :: E_em, xi_max, log_xi_max, E_tot2, es_scale2 logical, dimension(virt%n_flv, virt%n_legs) :: evaluated integer :: i_contr type(vector4_t) :: k_res type(lorentz_transformation_t) :: L_to_resonance evaluated = .false. if (allocated (virt%es_scale2)) then es_scale2 = virt%es_scale2 else if (allocated (virt%ren_scale)) then es_scale2 = virt%ren_scale**2 else es_scale2 = virt%fac_scale**2 end if end if sqme_born_virt = zero if (reg_data%nlo_correction_type == "EW" .and. i_corr == 1 & .and. qcd_ew_interferences (reg_data%flv_born(i_flv)%flst)) then do i = 1, size (reg_data%flv_born(i_flv)%flst) if (is_quark (reg_data%flv_born(i_flv)%flst (i))) then sqme_born_virt = -virt%sqme_color_c (i, i, i_flv)/CF exit end if end do else sqme_born_virt = virt%sqme_born (i_flv) end if do alr = 1, reg_data%n_regions if (i_flv /= reg_data%regions(alr)%uborn_index) cycle em = reg_data%regions(alr)%emitter if (em <= virt%n_in) cycle if (evaluated(i_flv, em)) cycle !!! Collinear terms only for massless particles if (reg_data%regions(alr)%flst_uborn%massive(em)) cycle E_em = p_born(em)%p(0) if (allocated (reg_data%alr_contributors)) then i_contr = reg_data%alr_to_i_contributor (alr) k_res = get_resonance_momentum (p_born, reg_data%alr_contributors(i_contr)%c) E_tot2 = k_res%p(0)**2 L_to_resonance = inverse (boost (k_res, k_res**1)) xi_max = two * space_part_norm (L_to_resonance * p_born(em)) / k_res%p(0) else E_tot2 = sqrts**2 xi_max = two * E_em / sqrts end if log_xi_max = log (xi_max) associate (xi_cut => virt%settings%fks_template%xi_cut, delta_o => virt%settings%fks_template%delta_o) if (virt%settings%virtual_resonance_aware_collinear) then if (debug_active (D_VIRTUAL)) & call msg_debug (D_VIRTUAL, "Using resonance-aware collinear subtraction") s1 = virt%gamma_p(em, i_flv, i_corr) s2 = two * (log (sqrts / (two * E_em)) + log_xi_max) * & (log (sqrts / (two * E_em)) + log_xi_max + log (es_scale2 / sqrts**2)) & * virt%c_flv(em, i_flv, i_corr) s3 = two * log_xi_max * & (log_xi_max - log (es_scale2 / E_tot2)) * virt%c_flv(em, i_flv, i_corr) s4 = (log (es_scale2 / E_tot2) - two * log_xi_max) & * virt%gamma_0(em, i_flv, i_corr) QB(i_flv) = QB(i_flv) + (s1 + s2 + s3 + s4) * sqme_born_virt else if (debug_active (D_VIRTUAL)) & call msg_debug (D_VIRTUAL, "Using old-fashioned collinear subtraction") s1 = virt%gamma_p(em, i_flv, i_corr) s2 = log (delta_o * sqrts**2 / (two * es_scale2)) & * virt%gamma_0(em,i_flv, i_corr) s3 = log (delta_o * sqrts**2 / (two * es_scale2)) * two & * virt%c_flv(em,i_flv, i_corr) * log (two * E_em / (xi_cut * sqrts)) ! s4 = two * virt%c_flv(em,i_flv, i_corr) * (log (two * E_em / sqrts)**2 - log (xi_cut)**2) s4 = two * virt%c_flv(em,i_flv, i_corr) * & ! a**2 - b**2 = (a - b) * (a + b), for better numerical performance (log (two * E_em / sqrts) + log (xi_cut)) * (log (two * E_em / sqrts) - log (xi_cut)) s5 = two * virt%gamma_0(em,i_flv, i_corr) * log (two * E_em / sqrts) QB(i_flv) = QB(i_flv) + (s1 - s2 + s3 + s4 - s5) * sqme_born_virt end if end associate evaluated(i_flv, em) = .true. end do end subroutine virtual_compute_collinear_contribution @ %def virtual_compute_collinear_contribution @ For the massless-massive case and $i = j$ we get the massive self-eikonal of (A.10) in arXiv:0908.4272, given as \begin{equation} \mathcal{I}_{ii} = \log \frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{1}{\beta} \log \frac{1 + \beta}{1 - \beta}. \end{equation} <>= procedure :: compute_massive_self_eikonals => virtual_compute_massive_self_eikonals <>= subroutine virtual_compute_massive_self_eikonals (virt, i_flv, i_corr, & p_born, s_over_Q2, reg_data, QB) class(virtual_t), intent(inout) :: virt integer, intent(in) :: i_flv, i_corr type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in) :: s_over_Q2 type(region_data_t), intent(in) :: reg_data real(default), intent(inout), dimension(:) :: QB real(default) :: sqme_born_virt integer :: i logical :: massive sqme_born_virt = zero if (reg_data%nlo_correction_type == "EW" .and. i_corr == 1 & .and. qcd_ew_interferences (reg_data%flv_born(i_flv)%flst)) then do i = 1, size (reg_data%flv_born(i_flv)%flst) if (is_quark (reg_data%flv_born(i_flv)%flst (i))) then sqme_born_virt = -virt%sqme_color_c (i, i, i_flv)/CF exit end if end do else sqme_born_virt = virt%sqme_born (i_flv) end if do i = 1, virt%n_legs massive = reg_data%flv_born(i_flv)%massive(i) if (massive) then QB(i_flv) = QB(i_flv) - (virt%c_flv (i, i_flv, i_corr) & * (log (s_over_Q2) - 0.5_default * I_m_eps (p_born(i)))) & * sqme_born_virt end if end do end subroutine virtual_compute_massive_self_eikonals @ %def virtual_compute_massive_self_eikonals @ The following code implements the $\mathcal{I}_{ij}$-function. The complete formulas can be found in arXiv:0908.4272 (A.1-A.17) and are also discussed in arXiv:1002.2581 in Appendix A. The implementation may differ in the detail from the formulas presented in the above paper. The parameter $\xi_{\text{cut}}$ is unphysically and cancels with appropriate factors in the real subtraction. We keep the additional parameter for debug usage. The implemented formulas are then defined as follows: \begin{itemize} \item[massless-massless case] $p^2 = 0, k^2 = 0,$ \begin{equation} \begin{split} \mathcal{I}_{ij} &= \frac{1}{2}\log^2\frac{\xi^2_{\text{cut}}s}{Q^2} + \log\frac{\xi^2_{\text{cut}}s}{Q^2}\log\frac{k_ik_j}{2E_iE_j} - \rm{Li}_2\left(\frac{k_ik_j}{2E_iE_j}\right) \\ &+ \frac{1}{2}\log^2\frac{k_ik_j}{2E_iE_j} - \log\left(1-\frac{k_ik_j}{2E_iE_j}\right) \log\frac{k_ik_j}{2E_iE_j}. \end{split} \label{I_00} \end{equation} \item[massive-massive case] $p^2 \neq 0, k^2 \neq 0,$ \begin{equation} \mathcal{I}_{ij} = \frac{1}{2}I_0(k_i, k_j)\log\frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{1}{2}I_\epsilon(k_i,k_j) \label{I_mm} \end{equation} with \begin{equation} I_0(k_i, k_j) = \frac{1}{\beta}\log\frac{1+\beta}{1-\beta}, \qquad \beta = \sqrt{1-\frac{k_i^2k_j^2}{(k_i \cdot k_j)^2}} \end{equation} and a rather involved expression for $I_\epsilon$: \begin{align} \allowdisplaybreaks I_\epsilon(k_i, k_j) &= \left(K(z_j)-K(z_i)\right) \frac{1-\vec{\beta_i}\cdot\vec{\beta_j}}{\sqrt{a(1-b)}}, \\ \vec{\beta_i} &= \frac{\vec{k}_i}{k_i^0}, \\ a &= \beta_i^2 + \beta_j^2 - 2\vec{\beta}_i \cdot \vec{\beta}_j, \\ x_i &= \frac{\beta_i^2 -\vec{\beta}_i \cdot \vec{\beta}_j}{a}, \\ x_j &= \frac{\beta_j^2 -\vec{\beta}_i \cdot \vec{\beta}_j}{a} = 1-x_j, \\ b &= \frac{\beta_i^2\beta_j^2 - (\vec{\beta}_i\cdot\vec{\beta}_j)^2}{a}, \\ c &= \sqrt{\frac{b}{4a}}, \\ z_+ &= \frac{1+\sqrt{1-b}}{\sqrt{b}}, \\ z_- &= \frac{1-\sqrt{1-b}}{\sqrt{b}}, \\ z_i &= \frac{\sqrt{x_i^2 + 4c^2} - x_i}{2c}, \\ z_j &= \frac{\sqrt{x_j^2 + 4c^2} + x_j}{2c}, \\ K(z) = &-\frac{1}{2}\log^2\frac{(z-z_-)(z_+-z)}{(z_++z)(z_-+z)} - 2Li_2\left(\frac{2z_-(z_+-z)}{(z_+-z_-)(z_-+z)}\right) \\ &-2Li_2\left(-\frac{2z_+(z_-+z)}{(z_+-z_-)(z_+-z)}\right) \end{align} \item[massless-massive case] $p^2 = 0, k^2 \neq 0,$ \begin{equation} \mathcal{I}_{ij} = \frac{1}{2}\left[\frac{1}{2}\log^2\frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{\pi^2}{6}\right] + \frac{1}{2}I_0(k_i,k_j)\log\frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{1}{2}I_\epsilon(k_i,k_j) \label{I_0m} \end{equation} with \begin{align} I_0(p,k) &= \log\frac{(\hat{p}\cdot\hat{k})^2}{\hat{k}^2}, \\ I_\varepsilon(p,k) &= -2\left[\frac{1}{4}\log^2\frac{1-\beta}{1+\beta} + \log\frac{\hat{p}\cdot\hat{k}}{1+\beta}\log\frac{\hat{p}\cdot\hat{k}}{1-\beta} + \rm{Li}_2\left(1-\frac{\hat{p}\cdot\hat{k}}{1+\beta}\right) + \rm{Li}_2\left(1-\frac{\hat{p}\cdot\hat{k}}{1-\beta}\right)\right], \end{align} using \begin{align} \hat{p} = \frac{p}{p^0}, \quad \hat{k} = \frac{k}{k^0}, \quad \beta = \frac{|\vec{k}|}{k_0}, \\ \rm{Li}_2(1 - x) + \rm{Li}_2(1 - x^{-1}) = -\frac{1}{2} \log^2 x. \end{align} \end{itemize} <>= function compute_eikonal_factor (p_born, massive, i, j, s_o_Q2) result (I_ij) real(default) :: I_ij type(vector4_t), intent(in), dimension(:) :: p_born logical, dimension(:), intent(in) :: massive integer, intent(in) :: i, j real(default), intent(in) :: s_o_Q2 if (massive(i) .and. massive(j)) then I_ij = compute_Imm (p_born(i), p_born(j), s_o_Q2) else if (.not. massive(i) .and. massive(j)) then I_ij = compute_I0m (p_born(i), p_born(j), s_o_Q2) else if (massive(i) .and. .not. massive(j)) then I_ij = compute_I0m (p_born(j), p_born(i), s_o_Q2) else I_ij = compute_I00 (p_born(i), p_born(j), s_o_Q2) end if end function compute_eikonal_factor function compute_I00 (pi, pj, s_o_Q2) result (I) type(vector4_t), intent(in) :: pi, pj real(default), intent(in) :: s_o_Q2 real(default) :: I real(default) :: Ei, Ej real(default) :: pij, Eij real(default) :: s1, s2, s3, s4, s5 real(default) :: arglog real(default), parameter :: tiny_value = epsilon(1.0) s1 = 0; s2 = 0; s3 = 0; s4 = 0; s5 = 0 Ei = pi%p(0); Ej = pj%p(0) pij = pi * pj; Eij = Ei * Ej s1 = 0.5_default * log(s_o_Q2)**2 s2 = log(s_o_Q2) * log(pij / (two * Eij)) s3 = Li2 (pij / (two * Eij)) s4 = 0.5_default * log (pij / (two * Eij))**2 arglog = one - pij / (two * Eij) if (arglog > tiny_value) then s5 = log(arglog) * log(pij / (two * Eij)) else s5 = zero end if I = s1 + s2 - s3 + s4 - s5 end function compute_I00 function compute_I0m (ki, kj, s_o_Q2) result (I) type(vector4_t), intent(in) :: ki, kj real(default), intent(in) :: s_o_Q2 real(default) :: I real(default) :: logsomu real(default) :: s1, s2, s3 s1 = 0; s2 = 0; s3 = 0 logsomu = log(s_o_Q2) s1 = 0.5 * (0.5 * logsomu**2 - pi**2 / 6) s2 = 0.5 * I_0m_0 (ki, kj) * logsomu s3 = 0.5 * I_0m_eps (ki, kj) I = s1 + s2 - s3 end function compute_I0m function compute_Imm (pi, pj, s_o_Q2) result (I) type(vector4_t), intent(in) :: pi, pj real(default), intent(in) :: s_o_Q2 real(default) :: I real(default) :: s1, s2 s1 = 0.5 * log(s_o_Q2) * I_mm_0(pi, pj) s2 = 0.5 * I_mm_eps(pi, pj) I = s1 - s2 end function compute_Imm function I_m_eps (p) result (I) type(vector4_t), intent(in) :: p real(default) :: I real(default) :: beta beta = space_part_norm (p)/p%p(0) if (beta < tiny_07) then I = four * (one + beta**2/3 + beta**4/5 + beta**6/7) else I = two * log((one + beta) / (one - beta)) / beta end if end function I_m_eps function I_0m_eps (p, k) result (I) type(vector4_t), intent(in) :: p, k real(default) :: I type(vector4_t) :: pp, kp real(default) :: beta pp = p / p%p(0); kp = k / k%p(0) beta = sqrt (one - kp*kp) I = -2*(log((one - beta) / (one + beta))**2/4 + log((pp*kp) / (one + beta))*log((pp*kp) / (one - beta)) & + Li2(one - (pp*kp) / (one + beta)) + Li2(one - (pp*kp) / (one - beta))) end function I_0m_eps function I_0m_0 (p, k) result (I) type(vector4_t), intent(in) :: p, k real(default) :: I type(vector4_t) :: pp, kp pp = p / p%p(0); kp = k / k%p(0) I = log((pp*kp)**2 / kp**2) end function I_0m_0 function I_mm_eps (p1, p2) result (I) type(vector4_t), intent(in) :: p1, p2 real(default) :: I type(vector3_t) :: beta1, beta2 real(default) :: a, b, b2 real(default) :: zp, zm, z1, z2, x1, x2 real(default) :: zmb, z1b real(default) :: K1, K2 beta1 = space_part (p1) / energy(p1) beta2 = space_part (p2) / energy(p2) a = beta1**2 + beta2**2 - 2 * beta1 * beta2 b = beta1**2 * beta2**2 - (beta1 * beta2)**2 if (beta1**1 > beta2**1) call switch_beta (beta1, beta2) if (beta1 == vector3_null) then b2 = beta2**1 I = (-0.5 * log ((one - b2) / (one + b2))**2 - two * Li2 (-two * b2 / (one - b2))) & * one / sqrt (a - b) return end if x1 = beta1**2 - beta1 * beta2 x2 = beta2**2 - beta1 * beta2 zp = sqrt (a) + sqrt (a - b) zm = sqrt (a) - sqrt (a - b) zmb = one / zp z1 = sqrt (x1**2 + b) - x1 z2 = sqrt (x2**2 + b) + x2 z1b = one / (sqrt (x1**2 + b) + x1) K1 = - 0.5 * log (((z1b - zmb) * (zp - z1)) / ((zp + z1) * (z1b + zmb)))**2 & - two * Li2 ((two * zmb * (zp - z1)) / ((zp - zm) * (zmb + z1b))) & - two * Li2 ((-two * zp * (zm + z1)) / ((zp - zm) * (zp - z1))) K2 = - 0.5 * log ((( z2 - zm) * (zp - z2)) / ((zp + z2) * (z2 + zm)))**2 & - two * Li2 ((two * zm * (zp - z2)) / ((zp - zm) * (zm + z2))) & - two * Li2 ((-two * zp * (zm + z2)) / ((zp - zm) * (zp - z2))) I = (K2 - K1) * (one - beta1 * beta2) / sqrt (a - b) contains subroutine switch_beta (beta1, beta2) type(vector3_t), intent(inout) :: beta1, beta2 type(vector3_t) :: beta_tmp beta_tmp = beta1 beta1 = beta2 beta2 = beta_tmp end subroutine switch_beta end function I_mm_eps function I_mm_0 (k1, k2) result (I) type(vector4_t), intent(in) :: k1, k2 real(default) :: I real(default) :: beta beta = sqrt (one - k1**2 * k2**2 / (k1 * k2)**2) I = log ((one + beta) / (one - beta)) / beta end function I_mm_0 @ %def I_mm_0 @ <>= procedure :: final => virtual_final <>= subroutine virtual_final (virtual) class(virtual_t), intent(inout) :: virtual if (allocated (virtual%gamma_0)) deallocate (virtual%gamma_0) if (allocated (virtual%gamma_p)) deallocate (virtual%gamma_p) if (allocated (virtual%c_flv)) deallocate (virtual%c_flv) if (allocated (virtual%n_is_neutrinos)) deallocate (virtual%n_is_neutrinos) end subroutine virtual_final @ %def virtual_final @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Real Subtraction} <<[[real_subtraction.f90]]>>= <> module real_subtraction <> <> <> use io_units use format_defs, only: FMT_15 use string_utils use constants use numeric_utils use diagnostics use pdg_arrays use models use physics_defs use sm_physics use lorentz use flavors use phs_fks, only: real_kinematics_t, isr_kinematics_t use phs_fks, only: I_PLUS, I_MINUS use phs_fks, only: SQRTS_VAR, SQRTS_FIXED use phs_fks, only: phs_point_set_t use ttv_formfactors, only: m1s_to_mpole use fks_regions use nlo_data <> <> <> <> <> contains <> end module real_subtraction @ %def real_subtraction @ \subsubsection{Soft subtraction terms} <>= integer, parameter, public :: INTEGRATION = 0 integer, parameter, public :: FIXED_ORDER_EVENTS = 1 integer, parameter, public :: POWHEG = 2 @ %def real subtraction parameters @ Translates the purpose into a string. % However, purpose is never set and this routine is never used. <>= public :: this_purpose <>= function this_purpose (purpose) type(string_t) :: this_purpose integer, intent(in) :: purpose select case (purpose) case (INTEGRATION) this_purpose = var_str ("Integration") case (FIXED_ORDER_EVENTS) this_purpose = var_str ("Fixed order NLO events") case (POWHEG) this_purpose = var_str ("Powheg events") case default this_purpose = var_str ("Undefined!") end select end function this_purpose @ %def this_purpose @ In the soft limit, the real matrix element behaves as \begin{equation*} \mathcal{R}_{\rm{soft}} = 4\pi\alpha_s \left[\sum_{i \neq j} \mathcal{B}_{ij} \frac{k_i \cdot k_j}{(k_i \cdot k)(k_j \cdot k)} - \mathcal{B} \sum_{i} \frac{k_i^2}{(k_i \cdot k)^2}C_i\right], \end{equation*} where $k$ denotes the momentum of the emitted parton. The quantity $\mathcal{B}_{ij}$ is called the color-correlated Born matrix element defined as \begin{equation*} \mathcal{B}_{ij} = \frac{1}{2s} \sum_{\stackrel{colors}{spins}} \mathcal{M}_{\{c_k\}}\left(\mathcal{M}^\dagger_{\{c_k\}}\right)_{\stackrel{c_i \rightarrow c_i'}{c_j \rightarrow c_j'}} T^a_{c_i,c_i'} T^a_{c_j,c_j'}. \end{equation*} <>= type :: soft_subtraction_t type(region_data_t), pointer :: reg_data => null () real(default), dimension(:,:), allocatable :: momentum_matrix logical :: use_resonance_mappings = .false. type(vector4_t) :: p_soft = vector4_null logical :: use_internal_color_correlations = .true. logical :: use_internal_spin_correlations = .false. logical :: xi2_expanded = .true. integer :: factorization_mode = NO_FACTORIZATION contains <> end type soft_subtraction_t @ %def soft_subtraction_t @ <>= procedure :: init => soft_subtraction_init <>= subroutine soft_subtraction_init (sub_soft, reg_data) class(soft_subtraction_t), intent(inout) :: sub_soft type(region_data_t), intent(in), target :: reg_data sub_soft%reg_data => reg_data allocate (sub_soft%momentum_matrix (reg_data%n_legs_born, & reg_data%n_legs_born)) end subroutine soft_subtraction_init @ %def soft_subtraction_init @ <>= procedure :: requires_boost => soft_subtraction_requires_boost <>= function soft_subtraction_requires_boost (sub_soft, sqrts) result (requires_boost) logical :: requires_boost class(soft_subtraction_t), intent(in) :: sub_soft real(default), intent(in) :: sqrts real(default) :: mtop logical :: above_threshold if (sub_soft%factorization_mode == FACTORIZATION_THRESHOLD) then mtop = m1s_to_mpole (sqrts) above_threshold = sqrts**2 - four * mtop**2 > zero else above_threshold = .false. end if requires_boost = sub_soft%use_resonance_mappings .or. above_threshold end function soft_subtraction_requires_boost @ %def soft_subtraction_requires_boost @ The treatment of the momentum $k$ follows the discussion about the soft limit of the partition functions (see [1002.2581], p. 29 and C. Weiss' PhD Thesis, p. 24). The parton momentum is pulled out, $k = E \hat{k}$. In fact, we will substitute $\hat{k}$ for $k$ throughout the code, because the energy will factor out of the equation when the soft $\mathcal{S}$-function is multiplied. The momentum [[p_soft]] represents the soft limit of the radiated particle divided by its energy. It is a unit vector, because $k^2 = \left(k^0\right)^2 - \left(k^0\right)^2\hat{\vec{k}}^2 = 0$. The soft momentum is constructed by first creating a unit vector parallel to the emitter's Born momentum. This unit vector is then rotated about the corresponding angles $y$ and $\phi$ to match the direction of the real radiation in the soft limit. <>= procedure :: create_softvec_fsr => soft_subtraction_create_softvec_fsr <>= subroutine soft_subtraction_create_softvec_fsr & (sub_soft, p_born, y, phi, emitter, xi_ref_momentum) class(soft_subtraction_t), intent(inout) :: sub_soft type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in) :: y, phi integer, intent(in) :: emitter type(vector4_t), intent(in) :: xi_ref_momentum type(vector3_t) :: dir type(vector4_t) :: p_em type(lorentz_transformation_t) :: rot type(lorentz_transformation_t) :: boost_to_rest_frame logical :: requires_boost associate (p_soft => sub_soft%p_soft) p_soft%p(0) = one requires_boost = sub_soft%requires_boost (two * p_born(1)%p(0)) if (requires_boost) then boost_to_rest_frame = inverse (boost (xi_ref_momentum, xi_ref_momentum**1)) p_em = boost_to_rest_frame * p_born(emitter) else p_em = p_born(emitter) end if p_soft%p(1:3) = p_em%p(1:3) / space_part_norm (p_em) dir = create_orthogonal (space_part (p_em)) rot = rotation (y, sqrt(one - y**2), dir) p_soft = rot * p_soft if (.not. vanishes (phi)) then dir = space_part (p_em) / space_part_norm (p_em) rot = rotation (cos(phi), sin(phi), dir) p_soft = rot * p_soft end if if (requires_boost) p_soft = inverse (boost_to_rest_frame) * p_soft end associate end subroutine soft_subtraction_create_softvec_fsr @ %def soft_subtraction_create_softvec_fsr @ For initial-state emissions, the soft vector is just a unit vector with the same direction as the radiated particle. As $y$ for ISR is defined independently of the emitter, also [[p_soft]] is the same for all initial state emitters. <>= procedure :: create_softvec_isr => soft_subtraction_create_softvec_isr <>= subroutine soft_subtraction_create_softvec_isr (sub_soft, y, phi) class(soft_subtraction_t), intent(inout) :: sub_soft real(default), intent(in) :: y, phi real(default) :: sin_theta sin_theta = sqrt(one - y**2) associate (p => sub_soft%p_soft%p) p(0) = one p(1) = sin_theta * sin(phi) p(2) = sin_theta * cos(phi) p(3) = y end associate end subroutine soft_subtraction_create_softvec_isr @ %def soft_subtraction_create_softvec_isr @ The soft vector for the real mismatch is basically the same as for usual FSR, except for the scaling with the total gluon energy. Moreover, the resulting vector is rotated into the frame where the 3-axis points along the direction of the emitter. This is necessary because in the collinear limit, the approximation \begin{equation*} k_i = \frac{k_i^0}{\bar{k}_j^0} \bar{k}_j = \frac{\xi\sqrt{s}}{2\bar{k}_j^0}\bar{k}_j \end{equation*} is used. The collinear limit is not included in the soft mismatch yet, but we keep the rotation for future usage here already (the performance loss is negligible). <>= procedure :: create_softvec_mismatch => & soft_subtraction_create_softvec_mismatch <>= subroutine soft_subtraction_create_softvec_mismatch (sub_soft, E, y, phi, p_em) class(soft_subtraction_t), intent(inout) :: sub_soft real(default), intent(in) :: E, phi, y type(vector4_t), intent(in) :: p_em real(default) :: sin_theta type(lorentz_transformation_t) :: rot_em_off_3_axis sin_theta = sqrt (one - y**2) associate (p => sub_soft%p_soft%p) p(0) = E p(1) = E * sin_theta * sin(phi) p(2) = E * sin_theta * cos(phi) p(3) = E * y end associate rot_em_off_3_axis = rotation_to_2nd (3, space_part (p_em)) sub_soft%p_soft = rot_em_off_3_axis * sub_soft%p_soft end subroutine soft_subtraction_create_softvec_mismatch @ %def soft_subtraction_create_softvec_mismatch @ Computation of the soft limit of $R_\alpha$. Note that what we are actually integrating (in the case of final-state radiation) is the quantity $f(0,y) / \xi$, where \begin{equation*} f(\xi,y) = \frac{J(\xi,y,\phi)}{\xi} \xi^2 R_\alpha. \end{equation*} $J/\xi$ is computed by the phase space generator. The additional factor of $\xi^{-1}$ is supplied in the [[evaluate_region_fsr]]-routine. Thus, we are left with a factor of $\xi^2$. A look on the expression for the soft limit of $R_\alpha$ below reveals that we are factoring out the gluon energy $E_i$ in the denominator. Therefore, we have a factor $\xi^2 / E_i^2 = 4 / q^2$.\\ Note that the same routine is used also for the computation of the soft mismatch. There, the gluon energy is not factored out from the soft vector, so that we are left with the $\xi^2$-factor, which will eventually be cancelled out again. So, we just multiply with 1. Both cases are distinguished by the flag [[xi2_expanded]]. Note that for the soft subtraction term, also the S functions are computed in the soft limit. The input momenta are thus the real momenta in the soft limit, i.e. the Born momenta given by [[p_born]]. <>= procedure :: compute => soft_subtraction_compute <>= function soft_subtraction_compute (sub_soft, p_born, & born_ij, y, q2, alpha_coupling, alr, emitter, i_res) result (sqme) real(default) :: sqme class(soft_subtraction_t), intent(inout) :: sub_soft type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in), dimension(:,:) :: born_ij real(default), intent(in) :: y real(default), intent(in) :: q2, alpha_coupling integer, intent(in) :: alr, emitter, i_res real(default) :: s_alpha_soft real(default) :: kb real(default) :: xi2_factor if (.not. vector_set_is_cms (p_born, sub_soft%reg_data%n_in)) then call vector4_write_set (p_born, show_mass = .true., & check_conservation = .true.) call msg_fatal ("Soft subtraction: phase space point must be in CMS") end if if (debug2_active (D_SUBTRACTION)) then select case (char (sub_soft%reg_data%regions(alr)%nlo_correction_type)) case ("QCD") print *, 'Compute soft subtraction using alpha_s = ', alpha_coupling case ("EW") print *, 'Compute soft subtraction using alpha_qed = ', alpha_coupling end select end if s_alpha_soft = sub_soft%reg_data%get_svalue_soft (p_born, & sub_soft%p_soft, alr, emitter, i_res) if (s_alpha_soft > one + tiny_07) call msg_fatal ("s_alpha_soft > 1!") if (debug2_active (D_SUBTRACTION)) & call msg_print_color ('s_alpha_soft', s_alpha_soft, COL_YELLOW) select case (sub_soft%factorization_mode) case (NO_FACTORIZATION) kb = sub_soft%evaluate_factorization_default (p_born, born_ij) case (FACTORIZATION_THRESHOLD) kb = sub_soft%evaluate_factorization_threshold (thr_leg(emitter), p_born, born_ij) end select if (debug_on) call msg_debug2 (D_SUBTRACTION, 'KB', kb) sqme = four * pi * alpha_coupling * s_alpha_soft * kb if (sub_soft%xi2_expanded) then xi2_factor = four / q2 else xi2_factor = one end if if (emitter <= sub_soft%reg_data%n_in) then sqme = xi2_factor * (one - y**2) * sqme else sqme = xi2_factor * (one - y) * sqme end if if (sub_soft%reg_data%regions(alr)%double_fsr) sqme = sqme * two end function soft_subtraction_compute @ %def soft_subtraction_compute @ We loop over all external legs and do not take care to leave out non-colored ones because [[born_ij]] is constructed in such a way that it is only non-zero for colored entries. <>= procedure :: evaluate_factorization_default => & soft_subtraction_evaluate_factorization_default <>= function soft_subtraction_evaluate_factorization_default & (sub_soft, p, born_ij) result (kb) real(default) :: kb class(soft_subtraction_t), intent(inout) :: sub_soft type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in), dimension(:,:) :: born_ij integer :: i, j kb = zero call sub_soft%compute_momentum_matrix (p) do i = 1, size (p) do j = 1, size (p) kb = kb + sub_soft%momentum_matrix (i, j) * born_ij (i, j) end do end do end function soft_subtraction_evaluate_factorization_default @ %def soft_subtraction_evaluate_factorization_default @ We have to multiply this with $\xi^2(1-y)$. Further, when applying the soft $\mathcal{S}$-function, the energy of the radiated particle is factored out. Thus we have $\xi^2/E_{em}^2(1-y) = 4/q_0^2(1-y)$. Computes the quantity $\mathcal{K}_{ij} = \frac{k_i \cdot k_j}{(k_i\cdot k)(k_j\cdot k)}$. <>= procedure :: compute_momentum_matrix => & soft_subtraction_compute_momentum_matrix <>= subroutine soft_subtraction_compute_momentum_matrix & (sub_soft, p_born) class(soft_subtraction_t), intent(inout) :: sub_soft type(vector4_t), intent(in), dimension(:) :: p_born real(default) :: num, deno1, deno2 integer :: i, j do i = 1, sub_soft%reg_data%n_legs_born do j = 1, sub_soft%reg_data%n_legs_born if (i <= j) then num = p_born(i) * p_born(j) deno1 = p_born(i) * sub_soft%p_soft deno2 = p_born(j) * sub_soft%p_soft sub_soft%momentum_matrix(i, j) = num / (deno1 * deno2) else !!! momentum matrix is symmetric. sub_soft%momentum_matrix(i, j) = sub_soft%momentum_matrix(j, i) end if end do end do end subroutine soft_subtraction_compute_momentum_matrix @ %def soft_subtraction_compute_momentum_matrx @ <>= procedure :: evaluate_factorization_threshold => & soft_subtraction_evaluate_factorization_threshold <>= function soft_subtraction_evaluate_factorization_threshold & (sub_soft, leg, p_born, born_ij) result (kb) real(default) :: kb class(soft_subtraction_t), intent(inout) :: sub_soft integer, intent(in) :: leg type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in), dimension(:,:) :: born_ij type(vector4_t), dimension(4) :: p p = get_threshold_momenta (p_born) kb = evaluate_leg_pair (ASSOCIATED_LEG_PAIR (leg)) if (debug2_active (D_SUBTRACTION)) call show_debug () contains function evaluate_leg_pair (i_start) result (kbb) real(default) :: kbb integer, intent(in) :: i_start integer :: i1, i2 real(default) :: numerator, deno1, deno2 kbb = zero do i1 = i_start, i_start + 1 do i2 = i_start, i_start + 1 numerator = p(i1) * p(i2) deno1 = p(i1) * sub_soft%p_soft deno2 = p(i2) * sub_soft%p_soft kbb = kbb + numerator * born_ij (i1, i2) / deno1 / deno2 end do end do if (debug2_active (D_SUBTRACTION)) then do i1 = i_start, i_start + 1 do i2 = i_start, i_start + 1 call msg_print_color('i1', i1, COL_PEACH) call msg_print_color('i2', i2, COL_PEACH) call msg_print_color('born_ij (i1,i2)', born_ij (i1,i2), COL_PINK) print *, 'Top momentum: ', p(1)%p end do end do end if end function evaluate_leg_pair subroutine show_debug () integer :: i call msg_print_color ('soft_subtraction_evaluate_factorization_threshold', COL_GREEN) do i = 1, 4 print *, 'sqrt(p(i)**2) = ', sqrt(p(i)**2) end do end subroutine show_debug end function soft_subtraction_evaluate_factorization_threshold @ %def soft_subtraction_evaluate_factorization_threshold @ <>= procedure :: i_xi_ref => soft_subtraction_i_xi_ref <>= function soft_subtraction_i_xi_ref (sub_soft, alr, i_phs) result (i_xi_ref) integer :: i_xi_ref class(soft_subtraction_t), intent(in) :: sub_soft integer, intent(in) :: alr, i_phs if (sub_soft%use_resonance_mappings) then i_xi_ref = sub_soft%reg_data%alr_to_i_contributor (alr) else if (sub_soft%factorization_mode == FACTORIZATION_THRESHOLD) then i_xi_ref = i_phs else i_xi_ref = 1 end if end function soft_subtraction_i_xi_ref @ %def soft_subtraction_i_xi_ref @ <>= procedure :: final => soft_subtraction_final <>= subroutine soft_subtraction_final (sub_soft) class(soft_subtraction_t), intent(inout) :: sub_soft if (associated (sub_soft%reg_data)) nullify (sub_soft%reg_data) if (allocated (sub_soft%momentum_matrix)) deallocate (sub_soft%momentum_matrix) end subroutine soft_subtraction_final @ %def soft_subtraction_final @ \subsection{Soft mismatch} <>= public :: soft_mismatch_t <>= type :: soft_mismatch_t type(region_data_t), pointer :: reg_data => null () real(default), dimension(:), allocatable :: sqme_born real(default), dimension(:,:,:), allocatable :: sqme_born_color_c real(default), dimension(:,:,:), allocatable :: sqme_born_charge_c type(real_kinematics_t), pointer :: real_kinematics => null () type(soft_subtraction_t) :: sub_soft contains <> end type soft_mismatch_t @ %def soft_mismatch_t @ <>= procedure :: init => soft_mismatch_init <>= subroutine soft_mismatch_init (soft_mismatch, reg_data, & real_kinematics, factorization_mode) class(soft_mismatch_t), intent(inout) :: soft_mismatch type(region_data_t), intent(in), target :: reg_data type(real_kinematics_t), intent(in), target :: real_kinematics integer, intent(in) :: factorization_mode soft_mismatch%reg_data => reg_data allocate (soft_mismatch%sqme_born (reg_data%n_flv_born)) allocate (soft_mismatch%sqme_born_color_c (reg_data%n_legs_born, & reg_data%n_legs_born, reg_data%n_flv_born)) allocate (soft_mismatch%sqme_born_charge_c (reg_data%n_legs_born, & reg_data%n_legs_born, reg_data%n_flv_born)) call soft_mismatch%sub_soft%init (reg_data) soft_mismatch%sub_soft%xi2_expanded = .false. soft_mismatch%real_kinematics => real_kinematics soft_mismatch%sub_soft%factorization_mode = factorization_mode end subroutine soft_mismatch_init @ %def soft_mismatch_init @ Main routine to compute the soft mismatch. Loops over all singular regions. There, it first creates the soft vector, then the necessary soft real matrix element. These inputs are then used to get the numerical value of the soft mismatch. <>= procedure :: evaluate => soft_mismatch_evaluate <>= function soft_mismatch_evaluate (soft_mismatch, alpha_s) result (sqme_mismatch) real(default) :: sqme_mismatch class(soft_mismatch_t), intent(inout) :: soft_mismatch real(default), intent(in) :: alpha_s integer :: alr, i_born, emitter, i_res, i_phs, i_con real(default) :: xi, y, q2, s real(default) :: E_gluon type(vector4_t) :: p_em real(default) :: sqme_alr, sqme_soft type(vector4_t), dimension(:), allocatable :: p_born sqme_mismatch = zero associate (real_kinematics => soft_mismatch%real_kinematics) xi = real_kinematics%xi_mismatch y = real_kinematics%y_mismatch s = real_kinematics%cms_energy2 E_gluon = sqrt (s) * xi / two if (debug_active (D_MISMATCH)) then print *, 'Evaluating soft mismatch: ' print *, 'Phase space: ' call vector4_write_set (real_kinematics%p_born_cms%get_momenta(1), & show_mass = .true.) print *, 'xi: ', xi, 'y: ', y, 's: ', s, 'E_gluon: ', E_gluon end if allocate (p_born (soft_mismatch%reg_data%n_legs_born)) do alr = 1, soft_mismatch%reg_data%n_regions i_phs = real_kinematics%alr_to_i_phs (alr) if (soft_mismatch%reg_data%has_pseudo_isr ()) then i_con = 1 p_born = soft_mismatch%real_kinematics%p_born_onshell%get_momenta(1) else i_con = soft_mismatch%reg_data%alr_to_i_contributor (alr) p_born = soft_mismatch%real_kinematics%p_born_cms%get_momenta(1) end if q2 = real_kinematics%xi_ref_momenta(i_con)**2 emitter = soft_mismatch%reg_data%regions(alr)%emitter p_em = p_born (emitter) i_res = soft_mismatch%reg_data%regions(alr)%i_res i_born = soft_mismatch%reg_data%regions(alr)%uborn_index call print_debug_alr () call soft_mismatch%sub_soft%create_softvec_mismatch & (E_gluon, y, real_kinematics%phi, p_em) if (debug_active (D_MISMATCH)) & print *, 'Created soft vector: ', soft_mismatch%sub_soft%p_soft%p select type (fks_mapping => soft_mismatch%reg_data%fks_mapping) type is (fks_mapping_resonances_t) call fks_mapping%set_resonance_momentum & (real_kinematics%xi_ref_momenta(i_con)) end select sqme_soft = soft_mismatch%sub_soft%compute & (p_born, soft_mismatch%sqme_born_color_c(:,:,i_born), y, & q2, alpha_s, alr, emitter, i_res) sqme_alr = soft_mismatch%compute (alr, xi, y, p_em, & real_kinematics%xi_ref_momenta(i_con), soft_mismatch%sub_soft%p_soft, & soft_mismatch%sqme_born(i_born), sqme_soft, & alpha_s, s) if (debug_on) call msg_debug (D_MISMATCH, 'sqme_alr: ', sqme_alr) sqme_mismatch = sqme_mismatch + sqme_alr end do end associate contains subroutine print_debug_alr () if (debug_active (D_MISMATCH)) then print *, 'alr: ', alr print *, 'i_phs: ', i_phs, 'i_con: ', i_con, 'i_res: ', i_res print *, 'emitter: ', emitter, 'i_born: ', i_born print *, 'emitter momentum: ', p_em%p print *, 'resonance momentum: ', & soft_mismatch%real_kinematics%xi_ref_momenta(i_con)%p print *, 'q2: ', q2 end if end subroutine print_debug_alr end function soft_mismatch_evaluate @ %def soft_mismatch_evaluate @ Computes the soft mismatch in a given $\alpha_r$, \begin{align*} I_{s+,\alpha_r} &= \int d\Phi_B \int_0^\infty d\xi \int_{-1}^1 dy \int_0^{2\pi} d\phi \frac{s\xi}{(4\pi)^3} \\ &\times \left\lbrace\tilde{R}_{\alpha_r} \left(e^{-\frac{2k_\gamma \cdot k_{res}}{k_{res}}^2} - e^{-\xi}\right) - \frac{32 \pi \alpha_s C_{em}}{s\xi^2} B_{f_b(\alpha_r)} (1-y)^{-1} \left[e^{-\frac{2\bar{k}_{em} \cdot k_{res}}{k_{res}^2} \frac{k_\gamma^0}{k_{em}^0}} - e^{-\xi}\right]\right\rbrace. \end{align*} <>= procedure :: compute => soft_mismatch_compute <>= function soft_mismatch_compute (soft_mismatch, alr, xi, y, p_em, p_res, p_soft, & sqme_born, sqme_soft, alpha_s, s) result (sqme_mismatch) real(default) :: sqme_mismatch class(soft_mismatch_t), intent(in) :: soft_mismatch integer, intent(in) :: alr real(default), intent(in) :: xi, y type(vector4_t), intent(in) :: p_em, p_res, p_soft real(default), intent(in) :: sqme_born, sqme_soft real(default), intent(in) :: alpha_s, s real(default) :: q2, expo, sm1, sm2, jacobian q2 = p_res**2 expo = - two * p_soft * p_res / q2 !!! Divide by 1 - y to factor out the corresponding !!! factor in the soft matrix element sm1 = sqme_soft / (one - y) * ( exp(expo) - exp(- xi) ) if (debug_on) call msg_debug2 (D_MISMATCH, 'sqme_soft in mismatch ', sqme_soft) sm2 = zero if (soft_mismatch%reg_data%regions(alr)%has_collinear_divergence ()) then expo = - two * p_em * p_res / q2 * & p_soft%p(0) / p_em%p(0) sm2 = 32 * pi * alpha_s * cf / (s * xi**2) * sqme_born * & ( exp(expo) - exp(- xi) ) / (one - y) end if jacobian = soft_mismatch%real_kinematics%jac_mismatch * s * xi / (8 * twopi3) sqme_mismatch = (sm1 - sm2) * jacobian end function soft_mismatch_compute @ %def soft_mismatch_compute @ <>= procedure :: final => soft_mismatch_final <>= subroutine soft_mismatch_final (soft_mismatch) class(soft_mismatch_t), intent(inout) :: soft_mismatch call soft_mismatch%sub_soft%final () if (associated (soft_mismatch%reg_data)) nullify (soft_mismatch%reg_data) if (allocated (soft_mismatch%sqme_born)) deallocate (soft_mismatch%sqme_born) if (allocated (soft_mismatch%sqme_born_color_c)) deallocate (soft_mismatch%sqme_born_color_c) if (allocated (soft_mismatch%sqme_born_charge_c)) deallocate (soft_mismatch%sqme_born_charge_c) if (associated (soft_mismatch%real_kinematics)) nullify (soft_mismatch%real_kinematics) end subroutine soft_mismatch_final @ %def soft_mismatch_final @ \subsection{Collinear and soft-collinear subtraction terms} This data type deals with the calculation of the collinear and soft-collinear contribution to the cross section. <>= public :: coll_subtraction_t <>= type :: coll_subtraction_t integer :: n_in, n_alr logical :: use_resonance_mappings = .false. real(default) :: CA = 0, CF = 0, TR = 0 contains <> end type coll_subtraction_t @ %def coll_subtraction_t @ <>= procedure :: init => coll_subtraction_init <>= subroutine coll_subtraction_init (coll_sub, n_alr, n_in) class(coll_subtraction_t), intent(inout) :: coll_sub integer, intent(in) :: n_alr, n_in coll_sub%n_in = n_in coll_sub%n_alr = n_alr end subroutine coll_subtraction_init @ %def coll_subtraction_init @ Set the corresponding algebra parameters of the underlying gauge group of the correction. <>= procedure :: set_parameters => coll_subtraction_set_parameters <>= subroutine coll_subtraction_set_parameters (coll_sub, CA, CF, TR) class(coll_subtraction_t), intent(inout) :: coll_sub real(default), intent(in) :: CA, CF, TR coll_sub%CA = CA coll_sub%CF = CF coll_sub%TR = TR end subroutine coll_subtraction_set_parameters @ %def coll_subtraction_set_parameters @ This subroutine computes the collinear limit of $g^\alpha(\xi,y)$ introduced in eq.~\ref{fks: sub: real}. Care is given to also enable the usage for the soft-collinear limit. This, we write all formulas in terms of soft-finite quantities. We have to compute \begin{equation*} \frac{J(\Phi_n,\xi,y,\phi)}{\xi} \left[(1-y)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]|_{y = 1}. \end{equation*} The Jacobian $J$ is proportional to $\xi$, due to the $d^3 k_{n+1} / k_{n+1}^0$ factor in the integration measure. It cancels the factor of $\xi$ in the denominator. The remaining part of the Jacobian is multiplied in [[evaluate_region_fsr]] and is not relevant here. Inserting the splitting functions exemplarily for $q \to qg$ yields \begin{equation*} g^\alpha = \frac{8\pi\alpha_s}{k_{\mathrm{em}}^2} C_F (1-y) \xi^2 \frac{1+(1-z)^2}{z} \mathcal{B}, \end{equation*} where we have chosen $z = E_\mathrm{rad} / \bar{E}_\mathrm{em}$ and $\bar{E}_\mathrm{em}$ denotes the emitter energy in the Born frame. The collinear final state imposes $\bar{k}_n = k_{n} + k_{n + 1}$ for the connection between $\Phi_n$- and $\Phi_{n+1}$-phasepace and we get $1 - z = E_\mathrm{em} / \bar{E}_\mathrm{em}$. The denominator can be rewritten by the constraint $\bar{k}_n^2 = (k_n + k_{n+1})^2 = 0$ to \begin{equation*} k_{\mathrm{em}}^2 = 2 E_\mathrm{rad} E_\mathrm{em} (1-y) \end{equation*} which cancels the $(1-y)$ factor in the numerator, thus showing that the whole expression is indeed collinear-finite. We can further transform \begin{equation*} E_\mathrm{rad} E_\mathrm{em} = z (1-z) \bar{E}_\mathrm{em}^2 \end{equation*} so that in total we have \begin{equation*} g^\alpha = \frac{4\pi\alpha_s}{1-z} \frac{1}{\bar{k}_{\text{em}}^2} C_F \left(\frac{\xi}{z}\right)^2 (1 + (1-z)^2) \mathcal{B} \end{equation*} Follow up calculations give us \begin{align*} g^{\alpha, g \rightarrow gg} & = \frac{4\pi\alpha_s}{1-z}\frac{1}{\bar{k}_{\text{em}}^2} C_{\mathrm{A}} \frac{\xi}{z} \left\lbrace 2 \left( \frac{z}{1 - z} \xi + \frac{1 - z}{\frac{z}{\xi}} \right) \mathcal{B} + 4\xi z(1 - z) \hat{k}_{\perp}^{\mu} \hat{k}_{\perp}^{\nu} \mathcal{B}_{\mu\nu} \right\rbrace, \\ g^{\alpha, g \rightarrow qq} & = \frac{4\pi\alpha_s}{1-z} \frac{1}{\bar{k}_{\text{em}}^2} T_{\mathrm{R}} \frac{\xi}{z} \left\lbrace \xi \mathcal{B} - 4\xi z(1 - z) \hat{k}_{\perp}^{\mu} \hat{k}_{\perp}^{\nu} \mathcal{B}_{\mu\nu} \right\rbrace. \end{align*} The ratio $z / \xi$ is finite in the soft limit \begin{equation*} \frac{z}{\xi} = \frac{q^0}{2\bar{E}_\mathrm{em}} \end{equation*} so that $\xi$ does not appear explicitly in the computation. The argumentation above is valid for $q \to qg$--splittings, but the general factorization is valid for general splittings, also for those involving spin correlations and QED splittings. Note that care has to be given to the definition of $z$. Further, we have factored out a factor of $z$ to include in the ratio $z/\xi$, which has to be taken into account in the implementation of the splitting functions. <>= procedure :: compute_fsr => coll_subtraction_compute_fsr <>= function coll_subtraction_compute_fsr & (coll_sub, emitter, flst, p_res, p_born, sqme_born, mom_times_sqme_spin_c, & xi, alpha_coupling, double_fsr) result (sqme) real(default) :: sqme class(coll_subtraction_t), intent(in) :: coll_sub integer, intent(in) :: emitter integer, dimension(:), intent(in) :: flst type(vector4_t), intent(in) :: p_res type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in) :: sqme_born, mom_times_sqme_spin_c real(default), intent(in) :: xi, alpha_coupling logical, intent(in) :: double_fsr real(default) :: q0, z, p0, z_o_xi, onemz integer :: nlegs, flv_em, flv_rad nlegs = size (flst) flv_rad = flst(nlegs); flv_em = flst(emitter) q0 = p_res**1 p0 = p_res * p_born(emitter) / q0 !!! Here, z corresponds to 1-z in the formulas of arXiv:1002.2581; !!! the integrand is symmetric under this variable change z_o_xi = q0 / (two * p0) z = xi * z_o_xi; onemz = one - z if (is_gluon (flv_em) .and. is_gluon (flv_rad)) then sqme = coll_sub%CA * ( two * ( z / onemz * xi + onemz / z_o_xi ) * sqme_born & + four * xi * z * onemz * mom_times_sqme_spin_c ) else if (is_fermion (flv_em) .and. is_fermion (flv_rad)) then sqme = coll_sub%TR * xi * (sqme_born - four * z * onemz * mom_times_sqme_spin_c) else if (is_fermion (flv_em) .and. is_massless_vector (flv_rad)) then sqme = sqme_born * coll_sub%CF * (one + onemz**2) / z_o_xi else sqme = zero end if sqme = sqme / (p0**2 * onemz * z_o_xi) sqme = sqme * four * pi * alpha_coupling if (double_fsr) sqme = sqme * onemz * two end function coll_subtraction_compute_fsr @ %def coll_subtraction_compute_fsr @ Like in the context of [[coll_subtraction_compute_fsr]] we compute the quantity \begin{equation*} \lim_{y\to\pm1}{\left\{\frac{J(\Phi_n,\xi,y,\phi)}{\xi} \left[(1-y^2)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]\right\}}, \end{equation*} where the $(1-y^2)$ accounts for both $y=\pm1$. Again, the Jacobian is proportional to $\xi$, so we drop the $J / \xi$ factor. Note that it is important to take into account this missing factor of $\xi$ in the computation of the Jacobian during phase-space generation both for fixed-beam and structure ISR. We consider only a $q \to qg$ splitting arguing that other splittings are identical in terms of the factors which cancel. It is given by \begin{equation*} g^\alpha = \frac{8\pi\alpha_s}{-k_{\mathrm{em}}^2} C_F (1-y^2) \xi^2 \frac{1+z^2}{1-z} \mathcal{B}, \end{equation*} where $g^\alpha$ is defined akin to the one for FSR in eq.~\ref{fks: sub: real}. Note the negative sign of $k_\mathrm{em}^2$ to compensate the negative virtuality of the initial-state emitter. For ISR, $z$ is defined with respect to the emitter energy entering the hard interaction, i.e. \begin{equation*} z = \frac{E_\mathrm{beam} - E_\mathrm{rad}}{E_\mathrm{beam}} = 1 - \frac{E_\mathrm{rad}}{E_\mathrm{beam}}. \end{equation*} Because $E_\mathrm{rad} = E_\mathrm{beam} \cdot \xi$, it is $z = 1 - \xi$, thus one factor of $\xi$ is cancelled by $(1-z)$ in the denominator of $g^\alpha$. The factor $k_\mathrm{em}^2$ in the denominator is rewritten as \begin{equation*} k_\mathrm{em}^2 = \left(p_\mathrm{beam} - p_\mathrm{rad}\right)^2 = - 2 p_\mathrm{beam} \cdot p_\mathrm{rad} = - 2 E_\mathrm{beam} E_\mathrm{rad} (1\pm y) = - 2 E_\mathrm{beam}^2 (1-z) (1\pm y), \end{equation*} where we used \begin{equation*} E_\mathrm{beam} E_\mathrm{rad} = E_\mathrm{beam}^2 (1-z). \end{equation*} This leads to the cancellation of the corresponding $(1\pm y)$ factor in $(1-y^2)$, with the other factor becoming a simple factor of $2$, and the remaining factor of $\xi$ in the numerator. We thus end up with \begin{equation*} g^\alpha = \frac{8\pi\alpha_s}{E_\mathrm{beam}^2} C_F \left(1 + z^2\right)\mathcal{B}, \end{equation*} which is soft-finite. Note that here in [[compute_isr]], [[sqme_born]] is supposed to be the squared Born matrix element convoluted with the real PDF. <>= procedure :: compute_isr => coll_subtraction_compute_isr <>= function coll_subtraction_compute_isr & (coll_sub, emitter, flst, p_born, sqme_born, mom_times_sqme_spin_c, & xi, alpha_coupling, isr_mode) result (sqme) real(default) :: sqme class(coll_subtraction_t), intent(in) :: coll_sub integer, intent(in) :: emitter integer, dimension(:), intent(in) :: flst type(vector4_t), intent(in), dimension(:) :: p_born real(default), intent(in) :: sqme_born real(default), intent(in) :: mom_times_sqme_spin_c real(default), intent(in) :: xi, alpha_coupling integer, intent(in) :: isr_mode real(default) :: z, onemz, p02 integer :: nlegs, flv_em, flv_rad !!! p_born must be in lab frame. nlegs = size (flst) flv_rad = flst(nlegs); flv_em = flst(emitter) !!! No need to pay attention to n_in = 1, because this case always has a !!! massive initial-state particle and thus no collinear divergence. p02 = p_born(1)%p(0) * p_born(2)%p(0) / two z = one - xi; onemz = xi if (is_massless_vector (flv_em) .and. is_massless_vector (flv_rad)) then sqme = coll_sub%CA * (two * (z + z * onemz**2) * sqme_born + four * onemz**2 & / z * mom_times_sqme_spin_c) else if (is_fermion (flv_em) .and. is_massless_vector (flv_rad)) then sqme = coll_sub%CF * (one + z**2) * sqme_born else if (is_fermion (flv_em) .and. is_fermion (flv_rad)) then sqme = coll_sub%CF * (z * onemz * sqme_born + four * onemz**2 / z * mom_times_sqme_spin_c) else if (is_massless_vector (flv_em) .and. is_fermion (flv_rad)) then sqme = coll_sub%TR * (z**2 + onemz**2) * onemz * sqme_born else sqme = zero end if if (isr_mode == SQRTS_VAR) then sqme = sqme / p02 * z else !!! We have no idea why this seems to work as there should be no factor !!! of z for the fixed-beam settings. This should definitely be understood in the !!! future! sqme = sqme / p02 / z end if sqme = sqme * four * pi * alpha_coupling end function coll_subtraction_compute_isr @ %def coll_subtraction_compute_isr @ <>= procedure :: final => coll_subtraction_final <>= subroutine coll_subtraction_final (sub_coll) class(coll_subtraction_t), intent(inout) :: sub_coll sub_coll%use_resonance_mappings = .false. end subroutine coll_subtraction_final @ %def coll_subtraction_final @ \subsection{Real Subtraction} We store a pointer to the [[nlo_settings_t]] object which holds tuning parameters, e.g. cutoffs for the subtraction terms. <>= public :: real_subtraction_t <>= type :: real_subtraction_t type(nlo_settings_t), pointer :: settings => null () type(region_data_t), pointer :: reg_data => null () type(real_kinematics_t), pointer :: real_kinematics => null () type(isr_kinematics_t), pointer :: isr_kinematics => null () real(default), dimension(:,:), allocatable :: sqme_real_non_sub real(default), dimension(:), allocatable :: sqme_born real(default), dimension(:,:), allocatable :: sf_factors real(default), dimension(:,:,:), allocatable :: sqme_born_color_c real(default), dimension(:,:,:), allocatable :: sqme_born_charge_c real(default), dimension(:,:,:,:), allocatable :: sqme_born_spin_c type(soft_subtraction_t) :: sub_soft type(coll_subtraction_t) :: sub_coll logical, dimension(:), allocatable :: sc_required logical :: subtraction_deactivated = .false. integer :: purpose = INTEGRATION logical :: radiation_event = .true. logical :: subtraction_event = .false. integer, dimension(:), allocatable :: selected_alr contains <> end type real_subtraction_t @ %def real_subtraction_t @ Initializer <>= procedure :: init => real_subtraction_init <>= subroutine real_subtraction_init (rsub, reg_data, settings) class(real_subtraction_t), intent(inout), target :: rsub type(region_data_t), intent(in), target :: reg_data type(nlo_settings_t), intent(in), target :: settings integer :: alr if (debug_on) call msg_debug (D_SUBTRACTION, "real_subtraction_init") if (debug_on) call msg_debug (D_SUBTRACTION, "n_in", reg_data%n_in) if (debug_on) call msg_debug (D_SUBTRACTION, "nlegs_born", reg_data%n_legs_born) if (debug_on) call msg_debug (D_SUBTRACTION, "nlegs_real", reg_data%n_legs_real) if (debug_on) call msg_debug (D_SUBTRACTION, "reg_data%n_regions", reg_data%n_regions) if (debug2_active (D_SUBTRACTION)) call reg_data%write () rsub%reg_data => reg_data allocate (rsub%sqme_born (reg_data%n_flv_born)) rsub%sqme_born = zero allocate (rsub%sf_factors (reg_data%n_regions, 0:reg_data%n_in)) rsub%sf_factors = zero allocate (rsub%sqme_born_color_c (reg_data%n_legs_born, reg_data%n_legs_born, & reg_data%n_flv_born)) rsub%sqme_born_color_c = zero allocate (rsub%sqme_born_charge_c (reg_data%n_legs_born, reg_data%n_legs_born, & reg_data%n_flv_born)) rsub%sqme_born_charge_c = zero allocate (rsub%sqme_real_non_sub (reg_data%n_flv_real, reg_data%n_phs)) rsub%sqme_real_non_sub = zero allocate (rsub%sc_required (reg_data%n_regions)) do alr = 1, reg_data%n_regions rsub%sc_required(alr) = reg_data%regions(alr)%sc_required end do if (rsub%requires_spin_correlations ()) then allocate (rsub%sqme_born_spin_c (1:3, 1:3, reg_data%n_legs_born, reg_data%n_flv_born)) rsub%sqme_born_spin_c = zero end if call rsub%sub_soft%init (reg_data) call rsub%sub_coll%init (reg_data%n_regions, reg_data%n_in) rsub%settings => settings rsub%sub_soft%use_resonance_mappings = settings%use_resonance_mappings rsub%sub_coll%use_resonance_mappings = settings%use_resonance_mappings rsub%sub_soft%factorization_mode = settings%factorization_mode end subroutine real_subtraction_init @ %def real_subtraction_init @ <>= procedure :: set_real_kinematics => real_subtraction_set_real_kinematics <>= subroutine real_subtraction_set_real_kinematics (rsub, real_kinematics) class(real_subtraction_t), intent(inout) :: rsub type(real_kinematics_t), intent(in), target :: real_kinematics rsub%real_kinematics => real_kinematics end subroutine real_subtraction_set_real_kinematics @ %def real_subtraction_set_real_kinematics @ <>= procedure :: set_isr_kinematics => real_subtraction_set_isr_kinematics <>= subroutine real_subtraction_set_isr_kinematics (rsub, fractions) class(real_subtraction_t), intent(inout) :: rsub type(isr_kinematics_t), intent(in), target :: fractions rsub%isr_kinematics => fractions end subroutine real_subtraction_set_isr_kinematics @ %def real_subtraction_set_isr_kinematics @ <>= procedure :: get_i_res => real_subtraction_get_i_res <>= function real_subtraction_get_i_res (rsub, alr) result (i_res) integer :: i_res class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr select type (fks_mapping => rsub%reg_data%fks_mapping) type is (fks_mapping_resonances_t) i_res = fks_mapping%res_map%alr_to_i_res (alr) class default i_res = 0 end select end function real_subtraction_get_i_res @ %def real_subtraction_get_i_res @ \subsection{The real contribution to the cross section} In each singular region $\alpha$, the real contribution to $\sigma$ is given by the second summand of eqn. \ref{fks: sub: complete}, \begin{equation} \label{fks: sub: real} \sigma^\alpha_{\text{real}} = \int d\Phi_n \int_0^{2\pi} d\phi \int_{-1}^1 dy \int_0^{\xi_{\text{max}}} d\xi \left(\frac{1}{\xi}\right)_+ \left(\frac{1}{1-y}\right)_+ \underbrace{\frac{J(\Phi_n, \xi, y, \phi)}{\xi} \left[(1-y)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]}_{g^\alpha(\xi,y)}. \end{equation} Writing out the plus-distribution and introducing $\tilde{\xi} = \xi/\xi_{\text{max}}$ to set the upper integration limit to 1, this turns out to be equal to \begin{equation} \begin{split} \sigma^\alpha_{\rm{real}} &= \int d\Phi_n \int_0^{2\pi}d\phi \int_{-1}^1 \frac{dy}{1-y} \Bigg\{\int_0^1 d\tilde{\xi}\Bigg[\frac{g^\alpha(\tilde{\xi}\xi_{\rm{max}},y)}{\tilde{\xi}} - \underbrace{\frac{g^\alpha(0,y)}{\tilde{\xi}}}_{\text{soft}} - \underbrace{\frac{g^\alpha(\tilde{\xi}\xi_{\rm{max}},1)}{\tilde{\xi}}}_{\text{coll.}} + \underbrace{\frac{g^\alpha(0,1)}{\tilde{\xi}}}_{\text{coll.+soft}}\Bigg] \\ &+ \left[\log\xi_{\rm{max}}(y)g^\alpha(0,y) - \log\xi_{\rm{max}}(1)g^\alpha(0,1)\right]\Bigg\}. \end{split} \end{equation} This formula is implemented in \texttt{compute\_sqme\_real\_fin} If two or more singular regions would produce the same amplitude we only compute one and use the [[eqv_index]] to copy the result to the others (if [[reuse_amplitudes_fks]] is true). <>= procedure :: compute => real_subtraction_compute <>= subroutine real_subtraction_compute (rsub, emitter, i_phs, alpha_s, & alpha_qed, separate_alrs, sqme) class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: emitter, i_phs logical, intent(in) :: separate_alrs real(default), intent(inout), dimension(:) :: sqme real(default), dimension(:), allocatable :: sqme_alr_arr real(default), intent(in) :: alpha_s, alpha_qed real(default) :: sqme_alr, alpha_coupling integer :: alr, i_con, i_res, this_emitter logical :: same_emitter logical, dimension(:), allocatable :: alr_evaluated allocate (alr_evaluated(rsub%reg_data%n_regions)) allocate (sqme_alr_arr(rsub%reg_data%n_regions)) sqme_alr_arr = zero alr_evaluated = .false. do alr = 1, rsub%reg_data%n_regions if (.not. alr_evaluated(rsub%reg_data%regions(alr)%eqv_index)) then if (allocated (rsub%selected_alr)) then if (.not. any (rsub%selected_alr == alr)) cycle end if sqme_alr = zero if (emitter > rsub%isr_kinematics%n_in) then same_emitter = emitter == rsub%reg_data%regions(alr)%emitter else same_emitter = rsub%reg_data%regions(alr)%emitter <= rsub%isr_kinematics%n_in end if select case (char(rsub%reg_data%regions(alr)%nlo_correction_type)) case ("QCD") alpha_coupling = alpha_s case ("EW") alpha_coupling = alpha_qed end select if (same_emitter .and. i_phs == rsub%real_kinematics%alr_to_i_phs (alr)) then i_res = rsub%get_i_res (alr) this_emitter = rsub%reg_data%regions(alr)%emitter sqme_alr = rsub%evaluate_emitter_region (alr, this_emitter, i_phs, i_res, & alpha_coupling) if (rsub%purpose == INTEGRATION .or. rsub%purpose == FIXED_ORDER_EVENTS) then !!! (PS-2021-09-13) This is always executed as purpose is never set. i_con = rsub%get_i_contributor (alr) sqme_alr = sqme_alr * rsub%get_phs_factor (i_con) end if end if sqme_alr_arr(alr) = sqme_alr_arr(alr) + sqme_alr if (.not. (debug_active (D_SUBTRACTION) .or. debug2_active (D_SUBTRACTION))) then if (.not. allocated (rsub%selected_alr)) & alr_evaluated(rsub%reg_data%regions(alr)%eqv_index) = .true. end if else sqme_alr_arr(alr) = sqme_alr_arr(rsub%reg_data%regions(alr)%eqv_index) end if if (separate_alrs) then sqme(alr) = sqme(alr) + sqme_alr_arr(alr) else sqme(1) = sqme(1) + sqme_alr_arr(alr) end if end do if (debug_on) then if (debug2_active (D_SUBTRACTION)) call check_s_alpha_consistency () end if contains subroutine check_s_alpha_consistency () real(default) :: sum_s_alpha, sum_s_alpha_soft integer :: i_ftuple if (debug_on) call msg_debug2 (D_SUBTRACTION, "Check consistency of s_alpha: ") do alr = 1, rsub%reg_data%n_regions sum_s_alpha = rsub%sum_up_s_alpha(alr, i_phs) call msg_debug2 (D_SUBTRACTION, 'sum_s_alpha', sum_s_alpha) if (.not. nearly_equal(sum_s_alpha, one)) then call msg_bug ("The sum of all S functions should be equal to one!") end if sum_s_alpha_soft = rsub%sum_up_s_alpha_soft(alr, i_phs) call msg_debug2 (D_SUBTRACTION, 'sum_s_alpha_soft', sum_s_alpha_soft) if (.not. nearly_equal(sum_s_alpha_soft, one)) then call msg_bug ("The sum of all soft S functions should be equal to one!") end if end do end subroutine check_s_alpha_consistency end subroutine real_subtraction_compute @ %def real_subtraction_compute @ The emitter is fixed. We now have to decide whether we evaluate in ISR or FSR region, and also if resonances are used. <>= procedure :: evaluate_emitter_region => real_subtraction_evaluate_emitter_region <>= function real_subtraction_evaluate_emitter_region (rsub, alr, emitter, & i_phs, i_res, alpha_coupling) result (sqme) real(default) :: sqme class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, emitter, i_phs, i_res real(default), intent(in) :: alpha_coupling if (emitter <= rsub%isr_kinematics%n_in) then sqme = rsub%evaluate_region_isr (alr, emitter, i_phs, i_res, alpha_coupling) else select type (fks_mapping => rsub%reg_data%fks_mapping) type is (fks_mapping_resonances_t) call fks_mapping%set_resonance_momenta & (rsub%real_kinematics%xi_ref_momenta) end select sqme = rsub%evaluate_region_fsr (alr, emitter, i_phs, i_res, alpha_coupling) end if end function real_subtraction_evaluate_emitter_region @ %def real_subtraction_evaluate_emitter_region @ Sums up $\sum_{i_1, i_2} S_{i_1 i_2}$ for the given [[alr]]. <>= procedure :: sum_up_s_alpha => real_subtraction_sum_up_s_alpha <>= function real_subtraction_sum_up_s_alpha (rsub, alr, i_phs) result (sum_s_alpha) real(default) :: sum_s_alpha class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, i_phs type(vector4_t), dimension(:), allocatable :: p_real integer :: i_res, i_ftuple, i1, i2 allocate (p_real (rsub%reg_data%n_legs_real)) if (rsub%reg_data%has_pseudo_isr ()) then p_real = rsub%real_kinematics%p_real_onshell(i_phs)%get_momenta (i_phs) else p_real = rsub%real_kinematics%p_real_cms%get_momenta (i_phs) end if i_res = rsub%get_i_res (alr) sum_s_alpha = zero do i_ftuple = 1, rsub%reg_data%regions(alr)%nregions call rsub%reg_data%regions(alr)%ftuples(i_ftuple)%get (i1, i2) sum_s_alpha = sum_s_alpha + rsub%reg_data%get_svalue (p_real, alr, i1, i2, i_res) end do end function real_subtraction_sum_up_s_alpha @ %def real_subtraction_sum_up_s_alpha @ Sums up $\sum_{i_1, i_2} S_{i_1 i_2}$ for the given [[alr]]. The soft S functions take the real momenta in the soft limit, i.e. the Born momenta. For each summand of [[sum_s_alpha_soft]] we take [[p_soft]] constructed from the emitter of the given alpha region also for ftuples in which the first integer [[i1]] does not coincide with the emitter. This is necessary because only if we keep [[p_soft]] fixed, all soft S functions are computed with the same denominator and thus add up to 1. <>= procedure :: sum_up_s_alpha_soft => real_subtraction_sum_up_s_alpha_soft <>= function real_subtraction_sum_up_s_alpha_soft (rsub, alr, i_phs) result (sum_s_alpha_soft) real(default) :: sum_s_alpha_soft class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, i_phs type(vector4_t), dimension(:), allocatable :: p_born integer :: i_res, i_ftuple, i1, i2, emitter, nlegs allocate (p_born (rsub%reg_data%n_legs_born)) if (rsub%reg_data%has_pseudo_isr ()) then p_born = rsub%real_kinematics%p_born_onshell%get_momenta (1) else p_born = rsub%real_kinematics%p_born_cms%get_momenta (1) end if i_res = rsub%get_i_res (alr) emitter = rsub%reg_data%regions(alr)%emitter associate (r => rsub%real_kinematics) if (emitter > rsub%sub_soft%reg_data%n_in) then call rsub%sub_soft%create_softvec_fsr (p_born, r%y_soft(i_phs), r%phi, & emitter, r%xi_ref_momenta(rsub%sub_soft%i_xi_ref (alr, i_phs))) else call rsub%sub_soft%create_softvec_isr (r%y_soft(i_phs), r%phi) end if end associate nlegs = rsub%reg_data%n_legs_real sum_s_alpha_soft = zero do i_ftuple = 1, rsub%reg_data%regions(alr)%nregions call rsub%reg_data%regions(alr)%ftuples(i_ftuple)%get (i1, i2) if (i2 == nlegs) then sum_s_alpha_soft = sum_s_alpha_soft + rsub%reg_data%get_svalue_soft & (p_born, rsub%sub_soft%p_soft, alr, i1, i_res) end if end do end function real_subtraction_sum_up_s_alpha_soft @ %def real_subtraction_sum_up_s_alpha_soft @ This subroutine computes the finite part of the real matrix element in an individual singular region. First, the radiation variables are fetched and $\mathcal{R}$ is multiplied by the appropriate $S_\alpha$-factors, region multiplicities and double-FSR factors. Then, it computes the soft, collinear, soft-collinear and remnant matrix elements and supplies the corresponding factor $1/\xi/(1-y)$ as well as the corresponding Jacobians. <>= procedure :: evaluate_region_fsr => real_subtraction_evaluate_region_fsr <>= function real_subtraction_evaluate_region_fsr (rsub, alr, emitter, i_phs, & i_res, alpha_coupling) result (sqme_tot) real(default) :: sqme_tot class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, emitter, i_phs, i_res real(default), intent(in) :: alpha_coupling real(default) :: sqme_rad, sqme_soft, sqme_coll, sqme_cs, sqme_remn sqme_rad = zero; sqme_soft = zero; sqme_coll = zero sqme_cs = zero; sqme_remn = zero associate (region => rsub%reg_data%regions(alr), template => rsub%settings%fks_template) if (rsub%radiation_event) then sqme_rad = rsub%sqme_real_non_sub (rsub%reg_data%get_matrix_element_index (alr), i_phs) call evaluate_fks_factors (sqme_rad, rsub%reg_data, rsub%real_kinematics, & alr, i_phs, emitter, i_res) call apply_kinematic_factors_radiation (sqme_rad, rsub%purpose, & rsub%real_kinematics, i_phs, .false., rsub%reg_data%has_pseudo_isr (), & emitter) end if if (rsub%subtraction_event .and. .not. (rsub%subtraction_deactivated & .or. region%nlo_correction_type == "none")) then if (debug2_active (D_SUBTRACTION)) then print *, "[real_subtraction_evaluate_region_fsr]" print *, "xi: ", rsub%real_kinematics%xi_max(i_phs) * rsub%real_kinematics%xi_tilde print *, "y: ", rsub%real_kinematics%y(i_phs) end if call rsub%evaluate_subtraction_terms_fsr (alr, emitter, i_phs, i_res, alpha_coupling, & sqme_soft, sqme_coll, sqme_cs) call apply_kinematic_factors_subtraction_fsr (sqme_soft, sqme_coll, sqme_cs, & rsub%real_kinematics, i_phs) associate (symm_factor_fs => rsub%reg_data%born_to_real_symm_factor_fs (alr)) sqme_soft = sqme_soft * symm_factor_fs sqme_coll = sqme_coll * symm_factor_fs sqme_cs = sqme_cs * symm_factor_fs end associate sqme_remn = compute_sqme_remnant_fsr (sqme_soft, sqme_cs, & rsub%real_kinematics%xi_max(i_phs), template%xi_cut, rsub%real_kinematics%xi_tilde) select case (rsub%purpose) case (INTEGRATION) sqme_tot = sqme_rad - sqme_soft - sqme_coll + sqme_cs + sqme_remn case (FIXED_ORDER_EVENTS) sqme_tot = - sqme_soft - sqme_coll + sqme_cs + sqme_remn case default sqme_tot = zero call msg_bug ("real_subtraction_evaluate_region_fsr: " // & "Undefined rsub%purpose") end select else sqme_tot = sqme_rad end if sqme_tot = sqme_tot * rsub%real_kinematics%jac_rand(i_phs) sqme_tot = sqme_tot * rsub%reg_data%regions(alr)%mult end associate if (debug_active (D_SUBTRACTION) .and. .not. debug2_active (D_SUBTRACTION)) then call real_subtraction_register_debug_sqme (rsub, alr, emitter, i_phs, sqme_rad, sqme_soft, & sqme_coll=sqme_coll, sqme_cs=sqme_cs) else if (debug2_active (D_SUBTRACTION)) then call write_computation_status_fsr () end if contains <> subroutine write_computation_status_fsr (passed, total, region_type, full) integer, intent(in), optional :: passed, total character(*), intent(in), optional :: region_type integer :: i_born integer :: u real(default) :: xi logical :: yorn logical, intent(in), optional :: full yorn = .true. if (present (full)) yorn = full if (debug_on) call msg_debug (D_SUBTRACTION, "real_subtraction_evaluate_region_fsr") u = given_output_unit (); if (u < 0) return i_born = rsub%reg_data%regions(alr)%uborn_index xi = rsub%real_kinematics%xi_max (i_phs) * rsub%real_kinematics%xi_tilde write (u,'(A,I2)') 'rsub%purpose: ', rsub%purpose write (u,'(A,I4)') 'alr: ', alr write (u,'(A,I3)') 'emitter: ', emitter write (u,'(A,I3)') 'i_phs: ', i_phs write (u,'(A,F6.4)') 'xi_max: ', rsub%real_kinematics%xi_max (i_phs) write (u,'(A,F6.4)') 'xi_cut: ', rsub%real_kinematics%xi_max(i_phs) * rsub%settings%fks_template%xi_cut write (u,'(A,F6.4,2X,A,F6.4)') 'xi: ', xi, 'y: ', rsub%real_kinematics%y (i_phs) if (yorn) then write (u,'(A,ES16.9)') 'sqme_born: ', rsub%sqme_born(i_born) write (u,'(A,ES16.9)') 'sqme_real: ', sqme_rad write (u,'(A,ES16.9)') 'sqme_soft: ', sqme_soft write (u,'(A,ES16.9)') 'sqme_coll: ', sqme_coll write (u,'(A,ES16.9)') 'sqme_coll-soft: ', sqme_cs write (u,'(A,ES16.9)') 'sqme_remn: ', sqme_remn write (u,'(A,ES16.9)') 'sqme_tot: ', sqme_tot if (present (passed) .and. present (total) .and. & present (region_type)) & write (u,'(A)') char (str (passed) // " of " // str (total) // & " " // region_type // " points passed in total") end if write (u,'(A,ES16.9)') 'jacobian - real: ', rsub%real_kinematics%jac(i_phs)%jac(1) write (u,'(A,ES16.9)') 'jacobian - soft: ', rsub%real_kinematics%jac(i_phs)%jac(2) write (u,'(A,ES16.9)') 'jacobian - coll: ', rsub%real_kinematics%jac(i_phs)%jac(3) end subroutine write_computation_status_fsr end function real_subtraction_evaluate_region_fsr @ %def real_subtraction_evalute_region_fsr @ Compares the real matrix element to the subtraction terms in the soft, the collinear or the soft-collinear limits. Used for debug purposes if [[?test_anti_coll_limit]], [[?test_coll_limit]] and/or [[?test_soft_limit]] are set in the Sindarin. [[sqme_soft]] and [[sqme_cs]] need to be provided if called for FSR and [[sqme_coll_plus]], [[sqme_coll_minus]], [[sqme_cs_plus]] as well as [[sqme_cs_minus]] need to be provided if called for ISR. <>= subroutine real_subtraction_register_debug_sqme (rsub, alr, emitter, i_phs, sqme_rad, sqme_soft,& sqme_coll, sqme_cs, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, sqme_cs_minus) class(real_subtraction_t), intent(in) :: rsub integer, intent(in) :: alr, emitter, i_phs real(default), intent(in) :: sqme_rad, sqme_soft real(default), intent(in), optional :: sqme_coll, sqme_cs, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, sqme_cs_minus real(default), dimension(:), allocatable, save :: sqme_rad_store logical :: is_soft, is_collinear_plus, is_collinear_minus, is_fsr real(default), parameter :: soft_threshold = 0.001_default real(default), parameter :: coll_threshold = 0.99_default real(default), parameter :: rel_smallness = 0.01_default real(default) :: sqme_dummy, this_sqme_rad, y, xi_tilde logical, dimension(:), allocatable, save :: count_alr if (.not. allocated (sqme_rad_store)) then allocate (sqme_rad_store (rsub%reg_data%n_regions)) sqme_rad_store = zero end if if (rsub%radiation_event) then sqme_rad_store(alr) = sqme_rad else if (.not. allocated (count_alr)) then allocate (count_alr (rsub%reg_data%n_regions)) count_alr = .false. end if if (is_massless_vector (rsub%reg_data%regions(alr)%flst_real%flst(rsub%reg_data%n_legs_real))) then xi_tilde = rsub%real_kinematics%xi_tilde is_soft = xi_tilde < soft_threshold else is_soft = .false. end if y = rsub%real_kinematics%y(i_phs) is_collinear_plus = y > coll_threshold .and. & rsub%reg_data%regions(alr)%has_collinear_divergence() is_collinear_minus = -y > coll_threshold .and. & rsub%reg_data%regions(alr)%has_collinear_divergence() is_fsr = emitter > rsub%isr_kinematics%n_in if (is_fsr) then if (.not. present(sqme_coll) .or. .not. present(sqme_cs)) & call msg_error ("real_subtraction_register_debug_sqme: Wrong arguments for FSR") else if (.not. present(sqme_coll_plus) .or. .not. present(sqme_coll_minus) & .or. .not. present(sqme_cs_plus) .or. .not. present(sqme_cs_minus)) & call msg_error ("real_subtraction_register_debug_sqme: Wrong arguments for ISR") end if this_sqme_rad = sqme_rad_store(alr) if (is_soft .and. .not. is_collinear_plus .and. .not. is_collinear_minus) then if ( .not. nearly_equal (this_sqme_rad, sqme_soft, & abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then call msg_print_color (char ("Soft MEs do not match in region " // str (alr)), COL_RED) else call msg_print_color (char ("sqme_soft OK in region " // str (alr)), COL_GREEN) end if print *, 'this_sqme_rad, sqme_soft = ', this_sqme_rad, sqme_soft end if if (is_collinear_plus .and. .not. is_soft) then if (is_fsr) then if ( .not. nearly_equal (this_sqme_rad, sqme_coll, & abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then call msg_print_color (char ("Collinear MEs do not match in region " // str (alr)), COL_RED) else call msg_print_color (char ("sqme_coll OK in region " // str (alr)), COL_GREEN) end if print *, 'this_sqme_rad, sqme_coll = ', this_sqme_rad, sqme_coll else if ( .not. nearly_equal (this_sqme_rad, sqme_coll_plus, & abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then call msg_print_color (char ("Collinear MEs do not match in region " // str (alr)), COL_RED) else call msg_print_color (char ("sqme_coll_plus OK in region " // str (alr)), COL_GREEN) end if print *, 'this_sqme_rad, sqme_coll_plus = ', this_sqme_rad, sqme_coll_plus end if end if if (is_collinear_minus .and. .not. is_soft) then if (.not. is_fsr) then if ( .not. nearly_equal (this_sqme_rad, sqme_coll_minus, & abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then call msg_print_color (char ("Collinear MEs do not match in region " // str (alr)), COL_RED) else call msg_print_color (char ("sqme_coll_minus OK in region " // str (alr)), COL_GREEN) end if print *, 'this_sqme_rad, sqme_coll_minus = ', this_sqme_rad, sqme_coll_minus end if end if if (is_soft .and. is_collinear_plus) then if (is_fsr) then if ( .not. nearly_equal (this_sqme_rad, sqme_cs, & abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then call msg_print_color (char ("Soft-collinear MEs do not match in region " // str (alr)), COL_RED) else call msg_print_color (char ("sqme_cs OK in region " // str (alr)), COL_GREEN) end if print *, 'this_sqme_rad, sqme_cs = ', this_sqme_rad, sqme_cs else if ( .not. nearly_equal (this_sqme_rad, sqme_cs_plus, & abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then call msg_print_color (char ("Soft-collinear MEs do not match in region " // str (alr)), COL_RED) else call msg_print_color (char ("sqme_cs_plus OK in region " // str (alr)), COL_GREEN) end if print *, 'this_sqme_rad, sqme_cs_plus = ', this_sqme_rad, sqme_cs_plus end if end if if (is_soft .and. is_collinear_minus) then if (.not. is_fsr) then if ( .not. nearly_equal (this_sqme_rad, sqme_cs_minus, & abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then call msg_print_color (char ("Soft-collinear MEs do not match in region " // str (alr)), COL_RED) else call msg_print_color (char ("sqme_cs_minus OK in region " // str (alr)), COL_GREEN) end if print *, 'this_sqme_rad, sqme_cs_minus = ', this_sqme_rad, sqme_cs_minus end if end if count_alr (alr) = .true. if (all (count_alr)) then deallocate (count_alr) deallocate (sqme_rad_store) end if end if end subroutine real_subtraction_register_debug_sqme @ %def real_subtraction_register_debug_sqme @ For final state radiation, the subtraction remnant cross section is \begin{equation} \sigma_{\text{remn}} = \left(\sigma_{\text{soft}} - \sigma_{\text{soft-coll}}\right) \log (\xi_{\text{max}}) \cdot \frac{\tilde{\xi}}{\xi_{\text{cut}}}. \end{equation} There is only one factor of $\log (\xi_{\text{max}})$ for both limits as $\xi_{\text{max}}$ does not depend on $y$ in the case of FSR. We use the already computed [[sqme_soft]] and [[sqme_cs]] with a factor of $\tilde{\xi}$ which we have to compensate. We also need a factor $1/\xi_{\text{cut}}$ here to assure that the cross section is independent of this free cutoff parameter. However, it still remains to be motivated analytically. <>= function compute_sqme_remnant_fsr (sqme_soft, sqme_cs, xi_max, xi_cut, xi_tilde) result (sqme_remn) real(default) :: sqme_remn real(default), intent(in) :: sqme_soft, sqme_cs, xi_max, xi_cut, xi_tilde if (debug_on) call msg_debug (D_SUBTRACTION, "compute_sqme_remnant_fsr") sqme_remn = (sqme_soft - sqme_cs) * log (xi_max) * xi_tilde / xi_cut end function compute_sqme_remnant_fsr @ %def compute_sqme_remnant_fsr @ <>= procedure :: evaluate_region_isr => real_subtraction_evaluate_region_isr <>= function real_subtraction_evaluate_region_isr (rsub, alr, emitter, i_phs, i_res, alpha_coupling) & result (sqme_tot) real(default) :: sqme_tot class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, emitter, i_phs, i_res real(default), intent(in) :: alpha_coupling real(default) :: sqme_rad, sqme_soft, sqme_coll_plus, sqme_coll_minus real(default) :: sqme_cs_plus, sqme_cs_minus real(default) :: sqme_remn sqme_rad = zero; sqme_soft = zero; sqme_coll_plus = zero; sqme_coll_minus = zero sqme_cs_plus = zero; sqme_cs_minus = zero sqme_remn = zero associate (region => rsub%reg_data%regions(alr), template => rsub%settings%fks_template) if (rsub%radiation_event) then sqme_rad = rsub%sqme_real_non_sub (rsub%reg_data%get_matrix_element_index (alr), i_phs) call evaluate_fks_factors (sqme_rad, rsub%reg_data, rsub%real_kinematics, & alr, i_phs, emitter, i_res) call apply_kinematic_factors_radiation (sqme_rad, rsub%purpose, rsub%real_kinematics, & i_phs, .true., .false.) end if if (rsub%subtraction_event .and. .not. (rsub%subtraction_deactivated & .or. region%nlo_correction_type == "none")) then call rsub%evaluate_subtraction_terms_isr (alr, emitter, i_phs, i_res, alpha_coupling, & sqme_soft, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, sqme_cs_minus) call apply_kinematic_factors_subtraction_isr (sqme_soft, sqme_coll_plus, & sqme_coll_minus, sqme_cs_plus, sqme_cs_minus, rsub%real_kinematics, i_phs) associate (symm_factor_fs => rsub%reg_data%born_to_real_symm_factor_fs (alr)) sqme_soft = sqme_soft * symm_factor_fs sqme_coll_plus = sqme_coll_plus * symm_factor_fs sqme_coll_minus = sqme_coll_minus * symm_factor_fs sqme_cs_plus = sqme_cs_plus * symm_factor_fs sqme_cs_minus = sqme_cs_minus * symm_factor_fs end associate sqme_remn = compute_sqme_remnant_isr (rsub%isr_kinematics%isr_mode, & sqme_soft, sqme_cs_plus, sqme_cs_minus, & rsub%isr_kinematics, rsub%real_kinematics, i_phs, template%xi_cut) sqme_tot = sqme_rad - sqme_soft - sqme_coll_plus - sqme_coll_minus & + sqme_cs_plus + sqme_cs_minus + sqme_remn else sqme_tot = sqme_rad end if end associate sqme_tot = sqme_tot * rsub%real_kinematics%jac_rand (i_phs) sqme_tot = sqme_tot * rsub%reg_data%regions(alr)%mult if (debug_active (D_SUBTRACTION) .and. .not. debug2_active (D_SUBTRACTION)) then call real_subtraction_register_debug_sqme (rsub, alr, emitter, i_phs, sqme_rad,& sqme_soft, sqme_coll_plus=sqme_coll_plus, sqme_coll_minus=sqme_coll_minus,& sqme_cs_plus=sqme_cs_plus, sqme_cs_minus=sqme_cs_minus) else if (debug2_active (D_SUBTRACTION)) then call write_computation_status_isr () end if contains <> subroutine write_computation_status_isr (unit) integer, intent(in), optional :: unit integer :: i_born integer :: u real(default) :: xi u = given_output_unit (unit); if (u < 0) return i_born = rsub%reg_data%regions(alr)%uborn_index xi = rsub%real_kinematics%xi_max (i_phs) * rsub%real_kinematics%xi_tilde write (u,'(A,I4)') 'alr: ', alr write (u,'(A,I2)') 'emitter: ', emitter write (u,'(A,F4.2)') 'xi_max: ', rsub%real_kinematics%xi_max (i_phs) print *, 'xi: ', xi, 'y: ', rsub%real_kinematics%y (i_phs) print *, 'xb1: ', rsub%isr_kinematics%x(1), 'xb2: ', rsub%isr_kinematics%x(2) print *, 'random jacobian: ', rsub%real_kinematics%jac_rand (i_phs) write (u,'(A,ES16.9)') 'sqme_born: ', rsub%sqme_born(i_born) write (u,'(A,ES16.9)') 'sqme_real: ', sqme_rad write (u,'(A,ES16.9)') 'sqme_soft: ', sqme_soft write (u,'(A,ES16.9)') 'sqme_coll_plus: ', sqme_coll_plus write (u,'(A,ES16.9)') 'sqme_coll_minus: ', sqme_coll_minus write (u,'(A,ES16.9)') 'sqme_cs_plus: ', sqme_cs_plus write (u,'(A,ES16.9)') 'sqme_cs_minus: ', sqme_cs_minus write (u,'(A,ES16.9)') 'sqme_remn: ', sqme_remn write (u,'(A,ES16.9)') 'sqme_tot: ', sqme_tot write (u,'(A,ES16.9)') 'jacobian - real: ', rsub%real_kinematics%jac(i_phs)%jac(1) write (u,'(A,ES16.9)') 'jacobian - soft: ', rsub%real_kinematics%jac(i_phs)%jac(2) write (u,'(A,ES16.9)') 'jacobian - collplus: ', rsub%real_kinematics%jac(i_phs)%jac(3) write (u,'(A,ES16.9)') 'jacobian - collminus: ', rsub%real_kinematics%jac(i_phs)%jac(4) end subroutine write_computation_status_isr end function real_subtraction_evaluate_region_isr @ %def real_subtraction_evaluate_region_isr @ Computes the soft remnant for ISR. The formulas can be found in arXiv:1002.2581, eq. 4.21. and arXiv:0709.2092, sec. 5.1.2. This results in \begin{equation} \sigma_{\text{remn}}^{\text{ISR}} = \log(\xi_{\text{max}}(y)) \sigma_{\text{soft}} - \frac{1}{2} \log(\xi_{\text{max}}(1)) \sigma^{\text{soft-coll}}_{\oplus} - \frac{1}{2} \log(\xi_{\text{max}}(-1)) \sigma^{\text{soft-coll}}_{\ominus} \end{equation} where for ISR, $\xi_{\text{max}}$ does explicitly depend on $y$ due to the rescaling of the $x$ values from the Born to the real partonic system 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} As $\xi_{\text{max}}$ is determined by the fact that the real $x_\oplus,x_\ominus$ have to stay in a physically meaningful regime, i.e. $x_\oplus,x_\ominus < 1$, this leads to \begin{align} \label{eqn:xi_max_isr} \xi_\text{max} = 1 - \text{max} &\left\{\frac{2(1+y)\overline{x}_\oplus^2}{\sqrt{(1+\overline{x}_\oplus^2)^2(1-y)^2 + 16y\overline{x}_\oplus^2} + (1-y)(1-\overline{x}_\oplus^2)}\right., \\ &\left.\frac{2(1-y)\overline{x}_\oplus^2}{\sqrt{(1+\overline{x}_\oplus^2)^2(1+y)^2 - 16y\overline{x}_\oplus^2} + (1+y)(1-\overline{x}_\oplus^2)}\right\} \end{align} and thus \begin{align} \xi_{\text{max}}(y=1) &= 1 - \overline{x}_\oplus \\ \xi_{\text{max}}(y=-1) &= 1 - \overline{x}_\ominus \end{align} So we need to use the unrescaled $\overline{x}_\oplus,\overline{x}_\ominus$ here. Factors of $\frac{1}{2}$ and $\frac{1}{\tilde{\xi}}$ are already included in the matrix elements from [[apply_kinematic_factors_subtraction_isr]]. We keep the former and remove the latter by multiplying with $\tilde{\xi}$. The factor $1/\xi_{\text{cut}}$ is probably needed to assure that the cross section is independent of this free cutoff parameter in analogy to the FSR case. However, it still remains to be motivated analytically and to be validated. <>= function compute_sqme_remnant_isr (isr_mode, sqme_soft, sqme_cs_plus, sqme_cs_minus, & isr_kinematics, real_kinematics, i_phs, xi_cut) result (sqme_remn) real(default) :: sqme_remn integer, intent(in) :: isr_mode real(default), intent(in) :: sqme_soft, sqme_cs_plus, sqme_cs_minus type(isr_kinematics_t), intent(in) :: isr_kinematics type(real_kinematics_t), intent(in) :: real_kinematics integer, intent(in) :: i_phs real(default), intent(in) :: xi_cut real(default) :: xi_tilde, xi_max, xi_max_plus, xi_max_minus, xb_plus, xb_minus xi_max = real_kinematics%xi_max (i_phs) xi_tilde = real_kinematics%xi_tilde select case (isr_mode) case (SQRTS_VAR) xb_plus = isr_kinematics%x(I_PLUS) xb_minus = isr_kinematics%x(I_MINUS) xi_max_plus = one - xb_plus xi_max_minus = one - xb_minus case (SQRTS_FIXED) xi_max_plus = real_kinematics%xi_max (i_phs) xi_max_minus = real_kinematics%xi_max (i_phs) end select sqme_remn = log (xi_max) * xi_tilde * sqme_soft & - log (xi_max_plus) * xi_tilde * sqme_cs_plus & - log (xi_max_minus) * xi_tilde * sqme_cs_minus sqme_remn = sqme_remn / xi_cut end function compute_sqme_remnant_isr @ %def compute_sqme_remnant_isr @ <>= procedure :: evaluate_subtraction_terms_fsr => & real_subtraction_evaluate_subtraction_terms_fsr <>= subroutine real_subtraction_evaluate_subtraction_terms_fsr (rsub, & alr, emitter, i_phs, i_res, alpha_coupling, sqme_soft, sqme_coll, sqme_cs) class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, emitter, i_phs, i_res real(default), intent(in) :: alpha_coupling real(default), intent(out) :: sqme_soft, sqme_coll, sqme_cs if (debug_on) call msg_debug (D_SUBTRACTION, "real_subtraction_evaluate_subtraction_terms_fsr") sqme_soft = zero; sqme_coll = zero; sqme_cs = zero associate (xi_tilde => rsub%real_kinematics%xi_tilde, & y => rsub%real_kinematics%y(i_phs), template => rsub%settings%fks_template) if (template%xi_cut > xi_tilde) & sqme_soft = rsub%compute_sub_soft (alr, emitter, i_phs, i_res, alpha_coupling) if (y - 1 + template%delta_o > 0) & sqme_coll = rsub%compute_sub_coll (alr, emitter, i_phs, alpha_coupling) if (template%xi_cut > xi_tilde .and. y - 1 + template%delta_o > 0) & sqme_cs = rsub%compute_sub_coll_soft (alr, emitter, i_phs, alpha_coupling) if (debug2_active (D_SUBTRACTION)) then print *, "FSR Cutoff:" print *, "sub_soft: ", template%xi_cut > xi_tilde, "(ME: ", sqme_soft, ")" print *, "sub_coll: ", (y - 1 + template%delta_o) > 0, "(ME: ", sqme_coll, ")" print *, "sub_coll_soft: ", template%xi_cut > xi_tilde .and. (y - 1 + template%delta_o) > 0, & "(ME: ", sqme_cs, ")" end if end associate end subroutine real_subtraction_evaluate_subtraction_terms_fsr @ %def real_subtraction_evaluate_subtraction_terms_fsr @ <>= subroutine evaluate_fks_factors (sqme, reg_data, real_kinematics, & alr, i_phs, emitter, i_res) real(default), intent(inout) :: sqme type(region_data_t), intent(inout) :: reg_data type(real_kinematics_t), intent(in), target :: real_kinematics integer, intent(in) :: alr, i_phs, emitter, i_res real(default) :: s_alpha type(phs_point_set_t), pointer :: p_real => null () if (reg_data%has_pseudo_isr ()) then p_real => real_kinematics%p_real_onshell (i_phs) else p_real => real_kinematics%p_real_cms end if s_alpha = reg_data%get_svalue (p_real%get_momenta(i_phs), alr, emitter, i_res) if (debug2_active (D_SUBTRACTION)) call msg_print_color('s_alpha', s_alpha, COL_YELLOW) if (s_alpha > one + tiny_07) call msg_fatal ("s_alpha > 1!") sqme = sqme * s_alpha associate (region => reg_data%regions(alr)) if (emitter > reg_data%n_in) then if (debug2_active (D_SUBTRACTION)) & print *, 'Double FSR: ', region%double_fsr_factor (p_real%get_momenta(i_phs)) sqme = sqme * region%double_fsr_factor (p_real%get_momenta(i_phs)) end if end associate end subroutine evaluate_fks_factors @ %def evaluate_fks_factors @ <>= subroutine apply_kinematic_factors_radiation (sqme, purpose, real_kinematics, & i_phs, isr, threshold, emitter) real(default), intent(inout) :: sqme integer, intent(in) :: purpose type(real_kinematics_t), intent(in) :: real_kinematics integer, intent(in) :: i_phs logical, intent(in) :: isr, threshold integer, intent(in), optional :: emitter real(default) :: xi, xi_tilde, s xi_tilde = real_kinematics%xi_tilde xi = xi_tilde * real_kinematics%xi_max (i_phs) select case (purpose) case (INTEGRATION, FIXED_ORDER_EVENTS) sqme = sqme * xi**2 / xi_tilde * real_kinematics%jac(i_phs)%jac(1) case (POWHEG) !!! (PS 2021-09-21) This has been implemented but is never executed so far. if (.not. isr) then s = real_kinematics%cms_energy2 sqme = sqme * real_kinematics%jac(i_phs)%jac(1) * s / (8 * twopi3) * xi else call msg_fatal ("POWHEG with initial-state radiation not implemented yet") end if end select end subroutine apply_kinematic_factors_radiation @ %def apply_kinematics_factors_radiation @ This routine applies the factors in the integrand of eq. 4.20 in arXiv:1002.2581 to the matrix elements. <>= subroutine apply_kinematic_factors_subtraction_fsr & (sqme_soft, sqme_coll, sqme_cs, real_kinematics, i_phs) real(default), intent(inout) :: sqme_soft, sqme_coll, sqme_cs type(real_kinematics_t), intent(in) :: real_kinematics integer, intent(in) :: i_phs real(default) :: xi_tilde, onemy xi_tilde = real_kinematics%xi_tilde onemy = one - real_kinematics%y(i_phs) sqme_soft = sqme_soft / onemy / xi_tilde sqme_coll = sqme_coll / onemy / xi_tilde sqme_cs = sqme_cs / onemy / xi_tilde associate (jac => real_kinematics%jac(i_phs)%jac) sqme_soft = sqme_soft * jac(2) sqme_coll = sqme_coll * jac(3) sqme_cs = sqme_cs * jac(2) end associate end subroutine apply_kinematic_factors_subtraction_fsr @ %def apply_kinematic_factors_subtraction_fsr @ This routine applies the factors in the integrand of eq. 4.21 in arXiv:1002.2581 to the matrix elements. <>= subroutine apply_kinematic_factors_subtraction_isr & (sqme_soft, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, & sqme_cs_minus, real_kinematics, i_phs) real(default), intent(inout) :: sqme_soft, sqme_coll_plus, sqme_coll_minus real(default), intent(inout) :: sqme_cs_plus, sqme_cs_minus type(real_kinematics_t), intent(in) :: real_kinematics integer, intent(in) :: i_phs real(default) :: xi_tilde, y, onemy, onepy xi_tilde = real_kinematics%xi_tilde y = real_kinematics%y (i_phs) onemy = one - y; onepy = one + y associate (jac => real_kinematics%jac(i_phs)%jac) sqme_soft = sqme_soft / (one - y**2) / xi_tilde * jac(2) sqme_coll_plus = sqme_coll_plus / onemy / xi_tilde / two * jac(3) sqme_coll_minus = sqme_coll_minus / onepy / xi_tilde / two * jac(4) sqme_cs_plus = sqme_cs_plus / onemy / xi_tilde / two * jac(2) sqme_cs_minus = sqme_cs_minus / onepy / xi_tilde / two * jac(2) end associate end subroutine apply_kinematic_factors_subtraction_isr @ %def apply_kinematic_factors_subtraction_isr @ This subroutine evaluates the soft and collinear subtraction terms for ISR. References: \begin{itemize} \item arXiv:0709.2092, sec. 2.4.2 \item arXiv:0908.4272, sec. 4.2 \end{itemize} For the collinear terms, the procedure is as follows: If the emitter is 0, then a gluon was radiated from one of the incoming partons. Gluon emissions require two counter terms: One for emission in the direction of the first incoming parton $\oplus$ and a second for emission in the direction of the second incoming parton $\ominus$ because in both cases, there are divergent diagrams contributing to the matrix element. So in this case both, [[sqme_coll_plus]] and [[sqme_coll_minus]], are non-zero. If the emitter is 1 or 2, then a quark was emitted instead of a gluon. This only leads to a divergence collinear to the emitter because for anti-collinear quark emission, there are simply no divergent diagrams in the same region as two collinear quarks that cannot originate in the same splitting are non-divergent. This means that in case the emitter is 1, we need non-zero [[sqme_coll_plus]] and in case the emitter is 2, we need non-zero [[sqme_coll_minus]]. At this point, we want to remind ourselves that in case of initial state divergences, $y$ is just the polar angle, so the [[sqme_coll_minus]] terms are there to counter emissions in the direction of the second incoming parton $\ominus$ and \textbf{not} to counter in general anti-collinear divergences. <>= procedure :: evaluate_subtraction_terms_isr => & real_subtraction_evaluate_subtraction_terms_isr <>= subroutine real_subtraction_evaluate_subtraction_terms_isr (rsub, & alr, emitter, i_phs, i_res, alpha_coupling, sqme_soft, sqme_coll_plus, & sqme_coll_minus, sqme_cs_plus, sqme_cs_minus) class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, emitter, i_phs, i_res real(default), intent(in) :: alpha_coupling real(default), intent(out) :: sqme_soft real(default), intent(out) :: sqme_coll_plus, sqme_coll_minus real(default), intent(out) :: sqme_cs_plus, sqme_cs_minus sqme_coll_plus = zero; sqme_cs_plus = zero sqme_coll_minus = zero; sqme_cs_minus = zero associate (xi_tilde => rsub%real_kinematics%xi_tilde, & y => rsub%real_kinematics%y(i_phs), template => rsub%settings%fks_template) if (template%xi_cut > xi_tilde) & sqme_soft = rsub%compute_sub_soft (alr, emitter, i_phs, i_res, alpha_coupling) if (emitter /= 2) then if (y - 1 + template%delta_i > 0) then sqme_coll_plus = rsub%compute_sub_coll (alr, 1, i_phs, alpha_coupling) if (template%xi_cut > xi_tilde) then sqme_cs_plus = rsub%compute_sub_coll_soft (alr, 1, i_phs, alpha_coupling) end if end if end if if (emitter /= 1) then if (-y - 1 + template%delta_i > 0) then sqme_coll_minus = rsub%compute_sub_coll (alr, 2, i_phs, alpha_coupling) if (template%xi_cut > xi_tilde) then sqme_cs_minus = rsub%compute_sub_coll_soft (alr, 2, i_phs, alpha_coupling) end if end if end if if (debug2_active (D_SUBTRACTION)) then print *, "ISR Cutoff:" print *, "y: ", y print *, "delta_i: ", template%delta_i print *, "emitter: ", emitter print *, "sub_soft: ", template%xi_cut > xi_tilde, "(ME: ", sqme_soft, ")" print *, "sub_coll_plus: ", (y - 1 + template%delta_i) > 0, "(ME: ", sqme_coll_plus, ")" print *, "sub_coll_minus: ", (-y - 1 + template%delta_i) > 0, "(ME: ", sqme_coll_minus, ")" print *, "sub_coll_soft_plus: ", template%xi_cut > xi_tilde .and. (y - 1 + template%delta_i) > 0, & "(ME: ", sqme_cs_plus, ")" print *, "sub_coll_soft_minus: ", template%xi_cut > xi_tilde .and. (-y - 1 + template%delta_i) > 0, & "(ME: ", sqme_cs_minus, ")" end if end associate end subroutine real_subtraction_evaluate_subtraction_terms_isr @ %def real_subtraction_evaluate_subtraction_terms_isr @ This is basically the global part of the real Jacobian corresponding to \begin{equation*} \frac{q^2}{8 (2\pi)^3}. \end{equation*} We interpret it as the additional phase space factor of the real component, to be more consistent with the evaluation of the Born phase space. We specifically use the Born center-of-mass energy here. The real center-of-mass energy is only different from the Born center-of-mass energy in case of ISR. The missing factor $\frac{1}{1 - \xi}$ for this conversion is supplied in [[apply_kinematic_factors_radiation]] and [[phs_fks_generator_generate_isr]]. <>= procedure :: get_phs_factor => real_subtraction_get_phs_factor <>= function real_subtraction_get_phs_factor (rsub, i_con) result (factor) real(default) :: factor class(real_subtraction_t), intent(in) :: rsub integer, intent(in) :: i_con real(default) :: s s = rsub%real_kinematics%xi_ref_momenta (i_con)**2 factor = s / (8 * twopi3) end function real_subtraction_get_phs_factor @ %def real_subtraction_get_phs_factor @ <>= procedure :: get_i_contributor => real_subtraction_get_i_contributor <>= function real_subtraction_get_i_contributor (rsub, alr) result (i_con) integer :: i_con class(real_subtraction_t), intent(in) :: rsub integer, intent(in) :: alr if (allocated (rsub%reg_data%alr_to_i_contributor)) then i_con = rsub%reg_data%alr_to_i_contributor (alr) else i_con = 1 end if end function real_subtraction_get_i_contributor @ %def real_subtraction_get_i_contributor @ Computes the soft subtraction term. If there is an initial state emission having a soft divergence, then a gluon has to have been emitted. A gluon can always be emitted from both IS partons and thus, we can take the [[sf_factor]] for emitter $0$ in this case. Be aware that this approach will not work for $pe$ collisions. <>= procedure :: compute_sub_soft => real_subtraction_compute_sub_soft <>= function real_subtraction_compute_sub_soft (rsub, alr, emitter, & i_phs, i_res, alpha_coupling) result (sqme_soft) real(default) :: sqme_soft class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, emitter, i_phs, i_res real(default), intent(in) :: alpha_coupling integer :: i_xi_ref, i_born real(default) :: q2, sf_factor type(vector4_t), dimension(:), allocatable :: p_born associate (real_kinematics => rsub%real_kinematics, & nlo_corr_type => rsub%reg_data%regions(alr)%nlo_correction_type, & sregion => rsub%reg_data%regions(alr)) sqme_soft = zero if (sregion%has_soft_divergence ()) then i_xi_ref = rsub%sub_soft%i_xi_ref (alr, i_phs) q2 = real_kinematics%xi_ref_momenta (i_xi_ref)**2 allocate (p_born (rsub%reg_data%n_legs_born)) if (rsub%reg_data%has_pseudo_isr ()) then p_born = real_kinematics%p_born_onshell%get_momenta (1) else p_born = real_kinematics%p_born_cms%get_momenta (1) end if if (emitter > rsub%sub_soft%reg_data%n_in) then call rsub%sub_soft%create_softvec_fsr & (p_born, real_kinematics%y_soft(i_phs), & real_kinematics%phi, emitter, & real_kinematics%xi_ref_momenta(i_xi_ref)) sf_factor = one else call rsub%sub_soft%create_softvec_isr & (real_kinematics%y_soft(i_phs), real_kinematics%phi) sf_factor = rsub%sf_factors(alr, 0) end if i_born = sregion%uborn_index select case (char (nlo_corr_type)) case ("QCD") sqme_soft = rsub%sub_soft%compute & (p_born, rsub%sqme_born_color_c(:,:,i_born) * & sf_factor, real_kinematics%y(i_phs), & q2, alpha_coupling, alr, emitter, i_res) case ("EW") sqme_soft = rsub%sub_soft%compute & (p_born, rsub%sqme_born_charge_c(:,:,i_born) * & sf_factor, real_kinematics%y(i_phs), & q2, alpha_coupling, alr, emitter, i_res) end select end if end associate if (debug2_active (D_SUBTRACTION)) call check_soft_vector () contains subroutine check_soft_vector () !!! p_soft = p_gluon / E_gluon only in the soft limit !!! This check only has to be passed for ISR or for FSR if ?test_soft_limit = true is set. type(vector4_t) :: p_gluon if (debug_on) call msg_debug2 (D_SUBTRACTION, "Compare soft vector: ") print *, 'p_soft: ', rsub%sub_soft%p_soft%p print *, 'Normalized gluon momentum: ' if (rsub%reg_data%has_pseudo_isr ()) then p_gluon = rsub%real_kinematics%p_real_onshell(thr_leg(emitter))%get_momentum & (i_phs, rsub%reg_data%n_legs_real) else p_gluon = rsub%real_kinematics%p_real_cms%get_momentum & (i_phs, rsub%reg_data%n_legs_real) end if call vector4_write (p_gluon / p_gluon%p(0), show_mass = .true.) end subroutine check_soft_vector end function real_subtraction_compute_sub_soft @ %def real_subtraction_compute_sub_soft @ <>= procedure :: get_spin_correlation_term => real_subtraction_get_spin_correlation_term <>= function real_subtraction_get_spin_correlation_term (rsub, alr, i_born, emitter) & result (mom_times_sqme) real(default) :: mom_times_sqme class(real_subtraction_t), intent(in) :: rsub integer, intent(in) :: alr, i_born, emitter real(default), dimension(0:3) :: k_perp integer :: mu, nu if (rsub%sc_required(alr)) then if (debug2_active(D_SUBTRACTION)) call check_me_consistency () associate (real_kin => rsub%real_kinematics) if (emitter > rsub%reg_data%n_in) then k_perp = real_subtraction_compute_k_perp_fsr ( & real_kin%p_born_lab%get_momentum(1, emitter), & rsub%real_kinematics%phi) else k_perp = real_subtraction_compute_k_perp_isr ( & real_kin%p_born_lab%get_momentum(1, emitter), & rsub%real_kinematics%phi) end if end associate mom_times_sqme = zero do mu = 1, 3 do nu = 1, 3 mom_times_sqme = mom_times_sqme + & k_perp(mu) * k_perp(nu) * rsub%sqme_born_spin_c (mu, nu, emitter, i_born) end do end do else mom_times_sqme = zero end if contains subroutine check_me_consistency () real(default) :: sqme_sum if (debug_on) call msg_debug2 (D_SUBTRACTION, "Spin-correlation: Consistency check") sqme_sum = & - rsub%sqme_born_spin_c(1,1,emitter,i_born) & - rsub%sqme_born_spin_c(2,2,emitter,i_born) & - rsub%sqme_born_spin_c(3,3,emitter,i_born) if (.not. nearly_equal (sqme_sum, -rsub%sqme_born(i_born))) then print *, 'Spin-correlated matrix elements are not consistent: ' print *, 'emitter: ', emitter print *, 'g^{mu,nu} B_{mu,nu}: ', -sqme_sum print *, 'all Born matrix elements: ', rsub%sqme_born call msg_fatal ("FAIL") else call msg_print_color ("Success", COL_GREEN) end if end subroutine check_me_consistency end function real_subtraction_get_spin_correlation_term @ %def real_subtraction_get_spin_correlation_term @ Construct a normalised momentum perpendicular to momentum [[p]] and rotate by an arbitrary angle [[phi]]. The angular conventions we use here are equivalent to those used by POWHEG. <>= public :: real_subtraction_compute_k_perp_fsr, & real_subtraction_compute_k_perp_isr <>= function real_subtraction_compute_k_perp_fsr (p, phi) result (k_perp_fsr) real(default), dimension(0:3) :: k_perp_fsr type(vector4_t), intent(in) :: p real(default), intent(in) :: phi type(vector4_t) :: k type(vector3_t) :: vec type(lorentz_transformation_t) :: rot vec = p%p(1:3) / p%p(0) k%p(0) = zero k%p(1) = p%p(1); k%p(2) = p%p(2) k%p(3) = - (p%p(1)**2 + p%p(2)**2) / p%p(3) rot = rotation (cos(phi), sin(phi), vec) k = rot * k k%p(1:3) = k%p(1:3) / space_part_norm (k) k_perp_fsr = k%p end function real_subtraction_compute_k_perp_fsr function real_subtraction_compute_k_perp_isr (p, phi) result (k_perp_isr) real(default), dimension(0:3) :: k_perp_isr type(vector4_t), intent(in) :: p real(default), intent(in) :: phi k_perp_isr(0) = zero k_perp_isr(1) = sin(phi) k_perp_isr(2) = cos(phi) k_perp_isr(3) = zero end function real_subtraction_compute_k_perp_isr @ %def real_subtraction_compute_k_perp_fsr, real_subtraction_compute_k_perp_isr @ <>= procedure :: compute_sub_coll => real_subtraction_compute_sub_coll <>= function real_subtraction_compute_sub_coll (rsub, alr, em, i_phs, alpha_coupling) & result (sqme_coll) real(default) :: sqme_coll class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, em, i_phs real(default), intent(in) :: alpha_coupling real(default) :: xi, xi_max real(default) :: mom_times_sqme_spin_c, sqme_born_coll real(default) :: N_col integer :: i_con, i real(default) :: pfr associate (sregion => rsub%reg_data%regions(alr)) sqme_coll = zero sqme_born_coll = zero N_col = 1 if (sregion%has_collinear_divergence ()) then xi = rsub%real_kinematics%xi_tilde * rsub%real_kinematics%xi_max(i_phs) if (rsub%sub_coll%use_resonance_mappings) then i_con = rsub%reg_data%alr_to_i_contributor (alr) else i_con = 1 end if mom_times_sqme_spin_c = rsub%get_spin_correlation_term (alr, sregion%uborn_index, em) if (rsub%reg_data%nlo_correction_type == "EW" .and. & sregion%nlo_correction_type == "QCD" .and. & qcd_ew_interferences (sregion%flst_uborn%flst)) then do i = 1, size (sregion%flst_uborn%flst) if (is_quark (sregion%flst_uborn%flst (i))) then sqme_born_coll = -rsub%sqme_born_color_c (i, i, sregion%uborn_index)/CF exit end if end do else sqme_born_coll = rsub%sqme_born(sregion%uborn_index) end if if (em <= rsub%sub_coll%n_in) then select case (rsub%isr_kinematics%isr_mode) case (SQRTS_FIXED) xi_max = rsub%real_kinematics%xi_max(i_phs) case (SQRTS_VAR) xi_max = one - rsub%isr_kinematics%x(em) end select xi = rsub%real_kinematics%xi_tilde * xi_max if (sregion%nlo_correction_type == "QCD") then call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR) else if (sregion%nlo_correction_type == "EW") then if (is_quark (sregion%flst_real%flst(size(sregion%flst_real%flst)))) N_col = 3 call rsub%sub_coll%set_parameters (CA = zero, & CF = sregion%flst_real%charge(em)**2, & TR = N_col*sregion%flst_real%charge(size(sregion%flst_real%flst))**2) end if sqme_coll = rsub%sub_coll%compute_isr (em, sregion%flst_real%flst, & rsub%real_kinematics%p_born_lab%phs_point(1)%get (), & sqme_born_coll * rsub%sf_factors(alr, em), & mom_times_sqme_spin_c * rsub%sf_factors(alr, em), & xi, alpha_coupling, rsub%isr_kinematics%isr_mode) else if (sregion%nlo_correction_type == "QCD") then call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR) else if (sregion%nlo_correction_type == "EW") then if (is_quark (sregion%flst_real%flst(sregion%emitter))) N_col = 3 call rsub%sub_coll%set_parameters (CA = zero, & CF = sregion%flst_real%charge(sregion%emitter)**2, & TR = N_col*sregion%flst_real%charge(sregion%emitter)**2) end if sqme_coll = rsub%sub_coll%compute_fsr (sregion%emitter, sregion%flst_real%flst, & rsub%real_kinematics%xi_ref_momenta (i_con), & rsub%real_kinematics%p_born_lab%get_momenta(1), & sqme_born_coll, & mom_times_sqme_spin_c, & xi, alpha_coupling, sregion%double_fsr) if (rsub%sub_coll%use_resonance_mappings) then select type (fks_mapping => rsub%reg_data%fks_mapping) type is (fks_mapping_resonances_t) pfr = fks_mapping%get_resonance_weight (alr, & rsub%real_kinematics%p_born_cms%get_momenta(1)) end select sqme_coll = sqme_coll * pfr end if end if end if end associate end function real_subtraction_compute_sub_coll @ %def real_subtraction_compute_sub_coll @ Computes the soft-collinear subtraction term. For alpha regions with emitter $0$, this routine is called with [[em == 1]] and [[em == 2]] separately. To still be able to use the unrescaled pdf factors stored in [[sf_factors(alr, 0)]] in this case, we need to differentiate between [[em]] and [[em_pdf = 0]]. <>= procedure :: compute_sub_coll_soft => real_subtraction_compute_sub_coll_soft <>= function real_subtraction_compute_sub_coll_soft (rsub, alr, em, i_phs, alpha_coupling) & result (sqme_cs) real(default) :: sqme_cs class(real_subtraction_t), intent(inout) :: rsub integer, intent(in) :: alr, em, i_phs real(default), intent(in) :: alpha_coupling real(default) :: mom_times_sqme_spin_c, sqme_born_coll real(default) :: N_col integer :: i_con, em_pdf, i associate (sregion => rsub%reg_data%regions(alr)) sqme_cs = zero sqme_born_coll = zero N_col = 1 if (sregion%has_collinear_divergence ()) then if (rsub%sub_coll%use_resonance_mappings) then i_con = rsub%reg_data%alr_to_i_contributor (alr) else i_con = 1 end if mom_times_sqme_spin_c = rsub%get_spin_correlation_term (alr, sregion%uborn_index, em) if (rsub%reg_data%nlo_correction_type == "EW" .and. & sregion%nlo_correction_type == "QCD" .and. & qcd_ew_interferences (sregion%flst_uborn%flst)) then do i = 1, size (sregion%flst_uborn%flst) if (is_quark (sregion%flst_uborn%flst (i))) then sqme_born_coll = -rsub%sqme_born_color_c (i, i, sregion%uborn_index)/CF exit end if end do else sqme_born_coll = rsub%sqme_born(sregion%uborn_index) end if if (em <= rsub%sub_coll%n_in) then em_pdf = 0 if (sregion%nlo_correction_type == "QCD") then call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR) else if (sregion%nlo_correction_type == "EW") then if (is_quark (sregion%flst_real%flst(size(sregion%flst_real%flst)))) N_col = 3 call rsub%sub_coll%set_parameters (CA = zero, & CF = sregion%flst_real%charge(em)**2, & TR = N_col*sregion%flst_real%charge(size(sregion%flst_real%flst))**2) end if sqme_cs = rsub%sub_coll%compute_isr (em, sregion%flst_real%flst, & rsub%real_kinematics%p_born_lab%phs_point(1)%get (), & sqme_born_coll * rsub%sf_factors(alr, em_pdf), & mom_times_sqme_spin_c * rsub%sf_factors(alr, em_pdf), & zero, alpha_coupling, rsub%isr_kinematics%isr_mode) else if (sregion%nlo_correction_type == "QCD") then call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR) else if (sregion%nlo_correction_type == "EW") then if (is_quark (sregion%flst_real%flst(sregion%emitter))) N_col = 3 call rsub%sub_coll%set_parameters (CA = zero, & CF = sregion%flst_real%charge(sregion%emitter)**2, & TR = N_col*sregion%flst_real%charge(sregion%emitter)**2) end if sqme_cs = rsub%sub_coll%compute_fsr (sregion%emitter, sregion%flst_real%flst, & rsub%real_kinematics%xi_ref_momenta(i_con), & rsub%real_kinematics%p_born_lab%phs_point(1)%get (), & sqme_born_coll, & mom_times_sqme_spin_c, & zero, alpha_coupling, sregion%double_fsr) end if end if end associate end function real_subtraction_compute_sub_coll_soft @ %def real_subtraction_compute_sub_coll_soft <>= procedure :: requires_spin_correlations => & real_subtraction_requires_spin_correlations <>= function real_subtraction_requires_spin_correlations (rsub) result (val) logical :: val class(real_subtraction_t), intent(in) :: rsub val = any (rsub%sc_required) end function real_subtraction_requires_spin_correlations @ %def real_subtraction_requires_spin_correlations @ <>= procedure :: final => real_subtraction_final <>= subroutine real_subtraction_final (rsub) class(real_subtraction_t), intent(inout) :: rsub call rsub%sub_soft%final () call rsub%sub_coll%final () !!! Finalization of region data is done in pcm_nlo_final if (associated (rsub%reg_data)) nullify (rsub%reg_data) !!! Finalization of real kinematics is done in pcm_instance_nlo_final if (associated (rsub%real_kinematics)) nullify (rsub%real_kinematics) if (associated (rsub%isr_kinematics)) nullify (rsub%isr_kinematics) if (allocated (rsub%sqme_real_non_sub)) deallocate (rsub%sqme_real_non_sub) if (allocated (rsub%sqme_born)) deallocate (rsub%sqme_born) if (allocated (rsub%sf_factors)) deallocate (rsub%sf_factors) if (allocated (rsub%sqme_born_color_c)) deallocate (rsub%sqme_born_color_c) if (allocated (rsub%sqme_born_charge_c)) deallocate (rsub%sqme_born_charge_c) if (allocated (rsub%sc_required)) deallocate (rsub%sc_required) if (allocated (rsub%selected_alr)) deallocate (rsub%selected_alr) end subroutine real_subtraction_final @ %def real_subtraction_final @ \subsubsection{Partitions of the real matrix element and Powheg damping} <>= public :: real_partition_t <>= type, abstract :: real_partition_t contains <> end type real_partition_t @ %def real partition_t @ <>= procedure (real_partition_init), deferred :: init <>= abstract interface subroutine real_partition_init (partition, scale, reg_data) import class(real_partition_t), intent(out) :: partition real(default), intent(in) :: scale type(region_data_t), intent(in) :: reg_data end subroutine real_partition_init end interface @ %def real_partition_init @ <>= procedure (real_partition_write), deferred :: write <>= abstract interface subroutine real_partition_write (partition, unit) import class(real_partition_t), intent(in) :: partition integer, intent(in), optional :: unit end subroutine real_partition_write end interface @ %def real_partition_write @ To allow really arbitrary damping functions, [[get_f]] should get the full real phase space as argument and not just some [[pt2]] that is extracted higher up. <>= procedure (real_partition_get_f), deferred :: get_f <>= abstract interface function real_partition_get_f (partition, p) result (f) import real(default) :: f class(real_partition_t), intent(in) :: partition type(vector4_t), intent(in), dimension(:) :: p end function real_partition_get_f end interface @ %def real_partition_get_f @ <>= public :: powheg_damping_simple_t <>= type, extends (real_partition_t) :: powheg_damping_simple_t real(default) :: h2 = 5._default integer :: emitter contains <> end type powheg_damping_simple_t @ %def powheg_damping_simple_t @ <>= procedure :: get_f => powheg_damping_simple_get_f <>= function powheg_damping_simple_get_f (partition, p) result (f) real(default) :: f class(powheg_damping_simple_t), intent(in) :: partition type(vector4_t), intent(in), dimension(:) :: p !!! real(default) :: pt2 f = 1 call msg_bug ("Simple damping currently not available") !!! TODO (cw-2017-03-01) Compute pt2 from emitter) !!! f = partition%h2 / (pt2 + partition%h2) end function powheg_damping_simple_get_f @ %def powheg_damping_simple_get_f @ <>= procedure :: init => powheg_damping_simple_init <>= subroutine powheg_damping_simple_init (partition, scale, reg_data) class(powheg_damping_simple_t), intent(out) :: partition real(default), intent(in) :: scale type(region_data_t), intent(in) :: reg_data partition%h2 = scale**2 end subroutine powheg_damping_simple_init @ %def powheg_damping_simple_init @ <>= procedure :: write => powheg_damping_simple_write <>= subroutine powheg_damping_simple_write (partition, unit) class(powheg_damping_simple_t), intent(in) :: partition integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "Powheg damping simple: " write (u, "(1x,A, "// FMT_15 // ")") "scale h2: ", partition%h2 end subroutine powheg_damping_simple_write @ %def powheg_damping_simple_write @ <>= public :: real_partition_fixed_order_t <>= type, extends (real_partition_t) :: real_partition_fixed_order_t real(default) :: scale type(ftuple_t), dimension(:), allocatable :: fks_pairs contains <> end type real_partition_fixed_order_t @ %def real_partition_fixed_order_t @ <>= procedure :: init => real_partition_fixed_order_init <>= subroutine real_partition_fixed_order_init (partition, scale, reg_data) class(real_partition_fixed_order_t), intent(out) :: partition real(default), intent(in) :: scale type(region_data_t), intent(in) :: reg_data end subroutine real_partition_fixed_order_init @ %def real_partition_fixed_order_init @ <>= procedure :: write => real_partition_fixed_order_write <>= subroutine real_partition_fixed_order_write (partition, unit) class(real_partition_fixed_order_t), intent(in) :: partition integer, intent(in), optional :: unit end subroutine real_partition_fixed_order_write @ %def real_partition_fixed_order_write @ Implements the suppression factor \begin{equation} F(\Phi_{n+1}) = 1 - \prod_{(i,j) \in P_{FKS}} \theta \left[ m_i + m_j + h - \sqrt{(p_j + p_j)^2} \right] \end{equation} to split the real matrix element into singular and finite part. <>= procedure :: get_f => real_partition_fixed_order_get_f <>= function real_partition_fixed_order_get_f (partition, p) result (f) real(default) :: f class(real_partition_fixed_order_t), intent(in) :: partition type(vector4_t), intent(in), dimension(:) :: p integer :: i, em f = zero PAIRS: do i = 1, size (partition%fks_pairs) associate (ii => partition%fks_pairs(i)%ireg) if (ii(1) == 0) then IS: do em = 1, 2 if ((p(em) + p(ii(2)))**1 < p(em)**1 + p(ii(2))**1 + partition%scale) then f = one exit PAIRS end if end do IS else if ((p(ii(1)) + p(ii(2)))**1 < p(ii(1))**1 + p(ii(2))**1 + partition%scale) then f = one exit PAIRS end if end if end associate end do PAIRS end function real_partition_fixed_order_get_f @ %def real_partition_fixed_order_get_f @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[real_subtraction_ut.f90]]>>= <> module real_subtraction_ut use unit_tests use real_subtraction_uti <> <> contains <> end module real_subtraction_ut @ %def real_subtraction_ut @ <<[[real_subtraction_uti.f90]]>>= <> module real_subtraction_uti <> use physics_defs use lorentz use numeric_utils use real_subtraction <> <> contains <> end module real_subtraction_uti @ %def real_subtraction_ut @ API: driver for the unit tests below. <>= public :: real_subtraction_test <>= subroutine real_subtraction_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine real_subtraction_test @ %def real_subtraction_test @ Test the final-state collinear subtraction. <>= call test (real_subtraction_1, "real_subtraction_1", & "final-state collinear subtraction", & u, results) <>= public :: real_subtraction_1 <>= subroutine real_subtraction_1 (u) integer, intent(in) :: u type(coll_subtraction_t) :: coll_sub real(default) :: sqme_coll type(vector4_t) :: p_res type(vector4_t), dimension(5) :: p_born real(default), dimension(4) :: k_perp real(default), dimension(4,4) :: b_munu integer :: mu, nu real(default) :: born, born_c integer, dimension(6) :: flst p_born(1)%p = [500, 0, 0, 500] p_born(2)%p = [500, 0, 0, -500] p_born(3)%p = [3.7755E+02, 2.2716E+02, -95.4172, 2.8608E+02] p_born(4)%p = [4.9529E+02, -2.739E+02, 84.8535, -4.0385E+02] p_born(5)%p = [1.2715E+02, 46.7375, 10.5637, 1.1778E+02] p_res = p_born(1) + p_born(2) flst = [11, -11 , -2, 2, -2, 2] b_munu(1, :) = [0., 0., 0., 0.] b_munu(2, :) = [0., 1., 1., 1.] b_munu(3, :) = [0., 1., 1., 1.] b_munu(4, :) = [0., 1., 1., 1.] k_perp = real_subtraction_compute_k_perp_fsr (p = p_born(5), phi = 0.5_default) born = - b_munu(1, 1) + b_munu(2, 2) + b_munu(3, 3) + b_munu(4, 4) born_c = 0. do mu = 1, 4 do nu = 1, 4 born_c = born_c + k_perp(mu) * k_perp(nu) * b_munu(mu, nu) end do end do write (u, "(A)") "* Test output: real_subtraction_1" write (u, "(A)") "* Purpose: final-state collinear subtraction" write (u, "(A)") write (u, "(A, L1)") "* vanishing scalar-product of 3-momenta k_perp and p_born(emitter): ", & nearly_equal (dot_product (p_born(5)%p(1:3), k_perp(2:4)), 0._default) call coll_sub%init (n_alr = 1, n_in = 2) call coll_sub%set_parameters (CA, CF, TR) write (u, "(A)") write (u, "(A)") "* g -> qq splitting" write (u, "(A)") sqme_coll = coll_sub%compute_fsr(5, flst, p_res, p_born, & born, born_c, 0.5_default, 0.25_default, .false.) write (u, "(A,F15.12)") "ME: ", sqme_coll write (u, "(A)") write (u, "(A)") "* g -> gg splitting" write (u, "(A)") b_munu(1, :) = [0., 0., 0., 0.] b_munu(2, :) = [0., 0., 0., 1.] b_munu(3, :) = [0., 0., 1., 1.] b_munu(4, :) = [0., 0., 1., 1.] k_perp = real_subtraction_compute_k_perp_fsr (p = p_born(5), phi = 0.5_default) born = - b_munu(1, 1) + b_munu(2, 2) + b_munu(3, 3) + b_munu(4, 4) born_c = 0. do mu = 1, 4 do nu = 1, 4 born_c = born_c + k_perp(mu) * k_perp(nu) * b_munu(mu, nu) end do end do flst = [11, -11, 2, -2, 21, 21] sqme_coll = coll_sub%compute_fsr(5, flst, p_res, p_born, & born, born_c, 0.5_default, 0.25_default, .true.) write (u, "(A,F15.12)") "ME: ", sqme_coll write (u, "(A)") write (u, "(A)") "* Test output end: real_subtraction_1" write (u, "(A)") end subroutine real_subtraction_1 @ %def real_subtraction_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Combining the FKS Pieces} <<[[nlo_data.f90]]>>= <> module nlo_data <> <> use diagnostics use constants, only: zero use string_utils, only: split_string, read_ival, string_contains_word use io_units use lorentz use variables, only: var_list_t use format_defs, only: FMT_15 use physics_defs, only: THR_POS_WP, THR_POS_WM use physics_defs, only: THR_POS_B, THR_POS_BBAR use physics_defs, only: NO_FACTORIZATION, FACTORIZATION_THRESHOLD <> <> <> <> <> contains <> end module nlo_data @ %def nlo_data @ <>= integer, parameter, public :: FKS_DEFAULT = 1 integer, parameter, public :: FKS_RESONANCES = 2 integer, dimension(2), parameter, public :: ASSOCIATED_LEG_PAIR = [1, 3] @ %def parameters @ <>= public :: fks_template_t <>= type :: fks_template_t logical :: subtraction_disabled = .false. integer :: mapping_type = FKS_DEFAULT logical :: count_kinematics = .false. real(default) :: fks_dij_exp1 real(default) :: fks_dij_exp2 real(default) :: xi_min real(default) :: y_max real(default) :: xi_cut, delta_o, delta_i type(string_t), dimension(:), allocatable :: excluded_resonances integer :: n_f contains <> end type fks_template_t @ %def fks_template_t @ <>= procedure :: write => fks_template_write <>= subroutine fks_template_write (template, unit) class(fks_template_t), intent(in) :: template integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u,'(1x,A)') 'FKS Template: ' write (u,'(1x,A)', advance = 'no') 'Mapping Type: ' select case (template%mapping_type) case (FKS_DEFAULT) write (u,'(A)') 'Default' case (FKS_RESONANCES) write (u,'(A)') 'Resonances' case default write (u,'(A)') 'Unkown' end select write (u,'(1x,A,ES4.3,ES4.3)') 'd_ij exponentials: ', & template%fks_dij_exp1, template%fks_dij_exp2 write (u, '(1x,A,ES4.3,ES4.3)') 'xi_cut: ', & template%xi_cut write (u, '(1x,A,ES4.3,ES4.3)') 'delta_o: ', & template%delta_o write (u, '(1x,A,ES4.3,ES4.3)') 'delta_i: ', & template%delta_i end subroutine fks_template_write @ %def fks_template_write @ Set FKS parameters. $\xi_{\text{cut}}, \delta_o$ and $\delta_{\mathrm{I}}$ steer the ratio of the integrated and real subtraction. <>= procedure :: set_parameters => fks_template_set_parameters <>= subroutine fks_template_set_parameters (template, exp1, exp2, xi_min, & y_max, xi_cut, delta_o, delta_i) class(fks_template_t), intent(inout) :: template real(default), intent(in) :: exp1, exp2 real(default), intent(in) :: xi_min, y_max, & xi_cut, delta_o, delta_i template%fks_dij_exp1 = exp1 template%fks_dij_exp2 = exp2 template%xi_min = xi_min template%y_max = y_max template%xi_cut = xi_cut template%delta_o = delta_o template%delta_i = delta_i end subroutine fks_template_set_parameters @ %def fks_template_set_parameters <>= procedure :: set_mapping_type => fks_template_set_mapping_type <>= subroutine fks_template_set_mapping_type (template, val) class(fks_template_t), intent(inout) :: template integer, intent(in) :: val template%mapping_type = val end subroutine fks_template_set_mapping_type @ %def fks_template_set_mapping_type @ <>= procedure :: set_counter => fks_template_set_counter <>= subroutine fks_template_set_counter (template) class(fks_template_t), intent(inout) :: template template%count_kinematics = .true. end subroutine fks_template_set_counter @ %def fks_template_set_counter @ <>= public :: get_threshold_momenta <>= function get_threshold_momenta (p) result (p_thr) type(vector4_t), dimension(4) :: p_thr type(vector4_t), intent(in), dimension(:) :: p p_thr(1) = p(THR_POS_WP) + p(THR_POS_B) p_thr(2) = p(THR_POS_B) p_thr(3) = p(THR_POS_WM) + p(THR_POS_BBAR) p_thr(4) = p(THR_POS_BBAR) end function get_threshold_momenta @ %def get_threshold_momenta @ \subsection{Putting it together} <>= public :: nlo_settings_t <>= type :: nlo_settings_t logical :: use_internal_color_correlations = .true. logical :: use_internal_spin_correlations = .false. logical :: use_resonance_mappings = .false. logical :: combined_integration = .false. logical :: fixed_order_nlo = .false. logical :: test_soft_limit = .false. logical :: test_coll_limit = .false. logical :: test_anti_coll_limit = .false. integer, dimension(:), allocatable :: selected_alr integer :: factorization_mode = NO_FACTORIZATION !!! Probably not the right place for this. Revisit after refactoring real(default) :: powheg_damping_scale = zero type(fks_template_t) :: fks_template type(string_t) :: virtual_selection logical :: virtual_resonance_aware_collinear = .true. logical :: use_born_scale = .false. logical :: cut_all_real_sqmes = .false. type(string_t) :: nlo_correction_type logical :: reuse_amplitudes_fks = .false. contains <> end type nlo_settings_t @ %def nlo_settings_t @ <>= procedure :: init => nlo_settings_init <>= subroutine nlo_settings_init (nlo_settings, var_list, fks_template) class(nlo_settings_t), intent(inout) :: nlo_settings type(var_list_t), intent(in) :: var_list type(fks_template_t), intent(in), optional :: fks_template type(string_t) :: color_method if (present (fks_template)) nlo_settings%fks_template = fks_template color_method = var_list%get_sval (var_str ('$correlation_me_method')) if (color_method == "") color_method = var_list%get_sval (var_str ('$method')) nlo_settings%use_internal_color_correlations = color_method == 'omega' & .or. color_method == 'threshold' nlo_settings%combined_integration = var_list%get_lval & (var_str ("?combined_nlo_integration")) nlo_settings%fixed_order_nlo = var_list%get_lval & (var_str ("?fixed_order_nlo_events")) nlo_settings%test_soft_limit = var_list%get_lval (var_str ('?test_soft_limit')) nlo_settings%test_coll_limit = var_list%get_lval (var_str ('?test_coll_limit')) nlo_settings%test_anti_coll_limit = var_list%get_lval (var_str ('?test_anti_coll_limit')) call setup_alr_selection () nlo_settings%virtual_selection = var_list%get_sval (var_str ('$virtual_selection')) nlo_settings%virtual_resonance_aware_collinear = & var_list%get_lval (var_str ('?virtual_collinear_resonance_aware')) nlo_settings%powheg_damping_scale = & var_list%get_rval (var_str ('powheg_damping_scale')) nlo_settings%use_born_scale = & var_list%get_lval (var_str ("?nlo_use_born_scale")) nlo_settings%cut_all_real_sqmes = & var_list%get_lval (var_str ("?nlo_cut_all_real_sqmes")) nlo_settings%nlo_correction_type = var_list%get_sval (var_str ('$nlo_correction_type')) nlo_settings%reuse_amplitudes_fks = var_list%get_lval (var_str ('?nlo_reuse_amplitudes_fks')) contains subroutine setup_alr_selection () type(string_t) :: alr_selection type(string_t), dimension(:), allocatable :: alr_split integer :: i, i1, i2 alr_selection = var_list%get_sval (var_str ('$select_alpha_regions')) if (string_contains_word (alr_selection, var_str (","))) then call split_string (alr_selection, var_str (","), alr_split) allocate (nlo_settings%selected_alr (size (alr_split))) do i = 1, size (alr_split) nlo_settings%selected_alr(i) = read_ival(alr_split(i)) end do else if (string_contains_word (alr_selection, var_str (":"))) then call split_string (alr_selection, var_str (":"), alr_split) if (size (alr_split) == 2) then i1 = read_ival (alr_split(1)) i2 = read_ival (alr_split(2)) allocate (nlo_settings%selected_alr (i2 - i1 + 1)) do i = 1, i2 - i1 + 1 nlo_settings%selected_alr(i) = read_ival (alr_split(i)) end do else call msg_fatal ("select_alpha_regions: ':' specifies a range!") end if else if (len(alr_selection) == 1) then allocate (nlo_settings%selected_alr (1)) nlo_settings%selected_alr(1) = read_ival (alr_selection) end if if (allocated (alr_split)) deallocate (alr_split) end subroutine setup_alr_selection end subroutine nlo_settings_init @ %def nlo_settings_init @ <>= procedure :: write => nlo_settings_write <>= subroutine nlo_settings_write (nlo_settings, unit) class(nlo_settings_t), intent(in) :: nlo_settings integer, intent(in), optional :: unit integer :: i, u u = given_output_unit (unit); if (u < 0) return write (u, '(A)') 'nlo_settings:' write (u, '(3X,A,L1)') 'internal_color_correlations = ', & nlo_settings%use_internal_color_correlations write (u, '(3X,A,L1)') 'internal_spin_correlations = ', & nlo_settings%use_internal_spin_correlations write (u, '(3X,A,L1)') 'use_resonance_mappings = ', & nlo_settings%use_resonance_mappings write (u, '(3X,A,L1)') 'combined_integration = ', & nlo_settings%combined_integration write (u, '(3X,A,L1)') 'test_soft_limit = ', & nlo_settings%test_soft_limit write (u, '(3X,A,L1)') 'test_coll_limit = ', & nlo_settings%test_coll_limit write (u, '(3X,A,L1)') 'test_anti_coll_limit = ', & nlo_settings%test_anti_coll_limit if (allocated (nlo_settings%selected_alr)) then write (u, '(3x,A)', advance = "no") 'selected alpha regions = [' do i = 1, size (nlo_settings%selected_alr) write (u, '(A,I0)', advance = "no") ",", nlo_settings%selected_alr(i) end do write (u, '(A)') "]" end if write (u, '(3X,A,' // FMT_15 // ')') 'powheg_damping_scale = ', & nlo_settings%powheg_damping_scale write (u, '(3X,A,A)') 'virtual_selection = ', & char (nlo_settings%virtual_selection) write (u, '(3X,A,A)') 'Real factorization mode = ', & char (factorization_mode (nlo_settings%factorization_mode)) contains function factorization_mode (fm) type(string_t) :: factorization_mode integer, intent(in) :: fm select case (fm) case (NO_FACTORIZATION) factorization_mode = var_str ("None") case (FACTORIZATION_THRESHOLD) factorization_mode = var_str ("Threshold") case default factorization_mode = var_str ("Undefined!") end select end function factorization_mode end subroutine nlo_settings_write @ %def nlo_settings_write @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Contribution of divergencies due to PDF Evolution} References: \begin{itemize} \item arXiv:hep-ph/9512328, (2.1)-(2.5), (4.29)-(4.53) \item arXiv:0709.2092, (2.102)-(2.106) \end{itemize} The parton distrubition densities have to be evaluated at NLO, too. The NLO PDF evolution is given by \begin{equation} \label{eqn:pdf_nlo} f (\bar{x}) = \int_0^1 \int_0^1 dx dz f(x) \Gamma(z) \delta (\bar{x} - x z), \end{equation} where $\Gamma$ are the DGLAP evolution kernels for an $a \to d$ splitting, \begin{equation} \label{eqn:dglap} \Gamma_a^{(d)} = \delta_{ad}\delta(1-x) - \frac{\alpha_s}{2\pi} \left(\frac{1}{\epsilon} P_{ad}(x,0) - K_{ad}(x)\right) + \mathcal{O}(\alpha_s^2). \end{equation} $K_{ad}$ is a renormalization scheme matching factor, which is exactly zero in $\overline{\text{MS}}$. Let the leading-order hadronic cross section be given by \begin{equation} \label{eqn:xsec_hadro_lo} d\sigma^{(0)}(s) = \int dx_\oplus dx_\ominus f_\oplus (x_\oplus) f_\ominus (x_\ominus) d\tilde{\sigma}^{(0)} (x_\oplus x_\ominus s), \end{equation} then the NLO hadronic cross section is \begin{equation} \label{eqn:xsec_hadro_nlo} d\sigma^{(1)}(s) = \int dx_\oplus dx_\ominus dz_\oplus dz_\ominus f_\oplus (x_\oplus) f_\ominus (x_\ominus) \underbrace{\Gamma_\oplus (z_\oplus) \Gamma_\ominus (z_\ominus) d\tilde{\sigma}^{(1)} (z_\oplus z_\ominus s)}_{d\hat{\sigma}^{(1)}}. \end{equation} $d\hat{\sigma}$ is called the subtracted partonic cross section. Expanding in $\alpha_s$ we find \begin{align} d\hat{\sigma}^{(0)}_{ab}(k_1, k_2) &= d\tilde{\sigma}_{ab}^{(0)} (k_1, k_2), \\ d\hat{\sigma}^{(1)}_{ab}(k_1, k_2) &= d\tilde{\sigma}_{ab}^{(1)} (k_1, k_2) \\ &+ \frac{\alpha_s}{2\pi} \sum_d \int dx \left (\frac{1}{\epsilon} P_{da}(x,0) - K_{da}(x)\right) d\tilde{\sigma}_{db}^{(0)}(xk_1, k_2)\\ &+ \frac{\alpha_s}{2\pi} \sum_d \int \left (\frac{1}{\epsilon} P_{db} (x, 0) - K_{db}(x)\right) d\tilde{\sigma}_{ad}^{(0)}(k_1, xk_2).\\ &= d\tilde{\sigma}_{ab}^{(1)} + d\tilde{\sigma}_{ab}^{(cnt,+)} + d\tilde{\sigma}_{ab}^{(cnt,-)} \end{align} Let us now turn to the soft-subtracted real part of the cross section. For ease of notation, it is constrained to one singular region, \begin{align*} \label{eqn:R-in} d\sigma^{(in)}_\alpha &= \left[\left(\frac{1}{\xi}\right)_{c} - 2\epsilon\left(\frac{\log \xi}{\xi}\right)_{c}\right] (1-y^2)\xi^2 \mathcal{R}_\alpha \mathcal{S}_\alpha \\ &\times \frac{1}{2(2\pi)^{3-2\epsilon}} \left(\frac{\sqrt{s}}{2}\right)^{2-2\epsilon} \left( 1 - y^2\right)^{-1-\epsilon} d\phi d\xi dy d\Omega^{2-2\epsilon}, \end{align*} where we regularize collinear divergencies using the identity \begin{equation*} \left (1 - y^2 \right)^{-1-\epsilon} = -\frac{2^{-\epsilon}}{2\epsilon} \left (\delta(1-y) + \delta(1+y)\right) + \underbrace{\frac{1}{2} \left[ \left (\frac {1}{1-y}\right)_{c} + \left (\frac{1}{1+y}\right)_{c} \right]}_{\mathcal{P}(y)}. \end{equation*} This enables us to split the cross section into a finite and a singular part. The latter can further be separated into a contribution of the incoming and of the outgoing particles, \begin{equation*} d\sigma^{(in)}_\alpha = d\sigma^{(in,+)}_\alpha + d\sigma^{(in,-)}_\alpha + d\sigma^{(in,f)}_\alpha. \end{equation*} They are given by \begin{align} d\sigma^{(in,f)}_\alpha = & \mathcal{P}(y) \left[\left(\frac{1}{\xi}\right)_{c} - 2\epsilon \left(\frac{\log\xi}{\xi}\right)_{c}\right] \frac{1}{2(2\pi)^{3-2\epsilon}} \left(\frac{\sqrt{s}}{2}\right)^{2-2\epsilon} \nonumber\\ & \times (1-y^2)\xi^2 \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy d\Omega^{2-2\epsilon} \label{eqn:sigma-f} \end{align} and \begin{align} d\sigma^{(in,\pm)}_\alpha &= -\frac{2^{-\epsilon}}{2\epsilon} \delta (1 \mp y) \left[ \left( \frac{1}{\xi}\right)_{c} - 2\epsilon \left(\frac{\log\xi}{\xi}\right)_{c}\right] \nonumber\\ & \times \frac{1}{2(2\pi)^{3-2\epsilon}} \left( \frac{\sqrt{s}}{2}\right)^{2-2\epsilon} (1-y^2)\xi^2 \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy d\Omega^{2-2\epsilon}. \label{eqn:sigma-pm} \end{align} Equation \ref{eqn:sigma-f} is the contribution to the real cross section which is computed in [[evaluate_region_isr]]. It is regularized both in the soft and collinear limit via the plus distributions. Equation \ref{eqn:sigma-pm} is a different contribution. It is only present exactly in the collinear limit, due to the delta function. The divergences present in this term do not completely cancel out divergences in the virtual matrix element, because the beam axis is distinguished. Thus, the conditions in which the KLN theorem applies are not met. To see this, we carry out the collinear limit, obtaining \begin{equation*} \lim_{y \to 1} (1-y^2)\xi^2\mathcal{R}_\alpha = 8\pi\alpha_s \mu^{2\epsilon} \left(\frac{2}{\sqrt{s}}\right)^2 \xi P^<(1-\xi, \epsilon) \mathcal{R}_\alpha, \end{equation*} with the Altarelli-Parisi splitting kernel for $z < 1$, $P^<(z,\epsilon)$. Moreover, $\lim_{\vec{k} \parallel \vec{k}_1} d\phi = d\phi_3$ violates spatial averaging. The integration over the spherical angle $d\Omega$ can be carried out easily, yielding a factor of $2\pi^{1-\epsilon} / \Gamma(1-\epsilon)$. This allows us to redefine $\epsilon$, \begin{equation} \frac{1}{\epsilon} - \gamma_E + \log(4\pi) \to \frac{1}{\epsilon}. \end{equation} Coming back to $d\tilde{\sigma}_{ab}^{(cnt,+)}$ in order to make a connection to $d{\sigma}^{(in,+)}_\alpha$, we relate $P_{ab}(z,0)$ to $P^<_{ab}(z,0)$ via the equation \begin{equation*} P_{ab}(z,0) = (1-z)P_{ab}^<(z,0)\left(\frac{1}{1-z}\right)_+ + \gamma(a)\delta_{ab}\delta(1-z), \end{equation*} which yields \begin{equation} \label{eqn:sigma-cnt} d\tilde{\sigma}^{(cnt,+)}_{\alpha} = \frac{\alpha_s}{2\pi} \sum_d \left\lbrace -K_{da}(1-\xi) + \frac{1}{\epsilon} \left[\left(\frac{1}{\xi}\right)_+ \xi P_{da}^<(1-\xi,0) + \delta_{da}\delta(\xi)\gamma(d)\right]\right\rbrace \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy. \end{equation} This term has the same pole structure as eqn. \ref{eqn:sigma-pm}. This makes clear that the quantity \begin{equation} d\hat{\sigma}^{(in,+)} = d\tilde{\sigma}^{(in,+)} + d\tilde{\sigma}^{(cnt,+)} \end{equation} has no collinear poles. Therefore, our task is to add up eqns. \ref{eqn:sigma-pm} and \ref{eqn:sigma-cnt} in order to compute the finite remainder. This is the integrand which is evaluated in the [[dglap_remnant]] component.\\ So, we have to perform an expansion of $d\hat{\sigma}^{(in,+)}$ in $\epsilon$. Hereby, we must not neglect the implicit $\epsilon$-dependence of $P^<$, which leads to additional terms involving the first derivative, \begin{equation*} P_{ab}^<(z,\epsilon) = P_{ab}^<(z,0) + \epsilon \frac{\partial P_{ab}^<(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} + \mathcal{O}(\alpha_s^2). \end{equation*} This finally gives us the equation for the collinear remnant. Note that there is still one soft $1/\epsilon$-pole, which cancels out with the corresponding expression in the soft-virtual terms. \begin{align} \label{eqn:sigma-in-p-final} d\hat{\sigma}^{(in,+)} &= \frac{\alpha_s}{2\pi} \frac{1}{\epsilon} \gamma(a) \mathcal{R}_\alpha \mathcal{S}_\alpha \nonumber\\ &+ \frac{\alpha_s}{2\pi} \sum_d \left\lbrace (1-z) P_{da}^<(z,0)\left[\left(\frac{1}{1-z}\right)_{c} \log\frac{s\delta_{\mathrm{I}}}{2\mu^2} + 2 \left(\frac{\log(1-z)}{1-z}\right)_{c}\right] \right. \nonumber\\ &\left . -(1-z)\frac{\partial P_{da}^<(z,\epsilon)}{\partial \epsilon} \left(\frac{1}{1-z}\right)_{c} - K_{da}(z)\right\rbrace \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy \end{align} <<[[dglap_remnant.f90]]>>= <> module dglap_remnant <> <> use numeric_utils use diagnostics use constants use physics_defs use pdg_arrays use phs_fks, only: isr_kinematics_t use fks_regions, only: region_data_t use nlo_data <> <> <> contains <> end module dglap_remnant @ %def module dglap_remnant @ <>= public :: dglap_remnant_t <>= type :: dglap_remnant_t type(nlo_settings_t), pointer :: settings => null () type(region_data_t), pointer :: reg_data => null () type(isr_kinematics_t), pointer :: isr_kinematics => null () real(default) :: CA = 0, CF = 0, TR = 0 real(default), dimension(:), allocatable :: sqme_born real(default), dimension(:,:), allocatable :: sf_factors real(default), dimension(:,:,:), allocatable :: sqme_color_c_extra contains <> end type dglap_remnant_t @ %def dglap_remnant_t @ <>= procedure :: init => dglap_remnant_init <>= subroutine dglap_remnant_init (dglap, settings, reg_data, isr_kinematics) class(dglap_remnant_t), intent(inout) :: dglap type(nlo_settings_t), intent(in), target :: settings type(region_data_t), intent(in), target :: reg_data integer :: n_flv_born type(isr_kinematics_t), intent(in), target :: isr_kinematics dglap%reg_data => reg_data n_flv_born = reg_data%get_n_flv_born () allocate (dglap%sf_factors (reg_data%n_regions, 0:reg_data%n_in)) dglap%sf_factors = zero dglap%settings => settings allocate (dglap%sqme_born(n_flv_born)) dglap%sqme_born = zero allocate (dglap%sqme_color_c_extra (reg_data%n_legs_born, reg_data%n_legs_born, & reg_data%n_flv_born)) dglap%sqme_color_c_extra = zero dglap%isr_kinematics => isr_kinematics end subroutine dglap_remnant_init @ %def dglap_remnant_init <>= procedure :: set_parameters => dglap_remnant_set_parameters <>= subroutine dglap_remnant_set_parameters (dglap, CA, CF, TR) class(dglap_remnant_t), intent(inout) :: dglap real(default), intent(in) :: CA, CF, TR dglap%CA = CA dglap%CF = CF dglap%TR = TR end subroutine dglap_remnant_set_parameters @ %def dglap_remnant_set_parameters @ Evaluates formula \ref{eqn:sigma-in-p-final}. Note that, as also in the case for the real subtraction, we have to take into account an additional term, occuring because the integral the plus distribution is evaluated over is not constrained on the interval $[0,1]$. Explicitly, this means (see JHEP 06(2010)043, (4.11)-(4.12)) \begin{align} \int_{\bar{x}_\oplus}^1 dz \left( \frac{1}{1-z} \right)_{\xi_{\text{cut}}} & = \log \frac{1-\bar{x}_\oplus}{\xi_{\text{cut}}} f(1) + \int_{\bar{x}_\oplus}^1 \frac{f(z) - f(1)}{1-z}, \\ \int_{\bar{x}_\oplus}^1 dz \left(\frac{\log(1-z)}{1-z}\right)_{\xi_{\text{cut}}} f(z) & = \frac{1}{2}\left( \log^2(1-\bar{x}_\oplus) - \log^2 (\xi_{\text{cut}}) \right)f(1) + \int_{\bar{x}_\oplus}^1 \frac{\log(1-z)[f(z) - f(1)]}{1-z}, \end{align} and the same of course for $\bar{x}_\ominus$. These two terms are stored in the [[plus_dist_remnant]] variable below. The option [[separate_uborns]] allows to compute the contribution of the DGLAP remnant separately for each underlying Born flavor structure. We need this option during event generation to generate counter events with a specific Born flavor structure. <>= procedure :: evaluate => dglap_remnant_evaluate <>= subroutine dglap_remnant_evaluate (dglap, alpha_coupling, separate_uborns, sqme_dglap) class(dglap_remnant_t), intent(inout) :: dglap real(default), dimension(2), intent(in) :: alpha_coupling logical, intent(in) :: separate_uborns real(default), intent(inout), dimension(:) :: sqme_dglap integer :: alr, emitter, i_corr real(default) :: sqme_alr logical, dimension(:,:,:), allocatable :: evaluated real(default) :: sb, fac_scale2 sb = dglap%isr_kinematics%sqrts_born**2 fac_scale2 = dglap%isr_kinematics%fac_scale**2 allocate (evaluated(dglap%reg_data%get_n_flv_born (), dglap%reg_data%get_n_flv_real (), & dglap%reg_data%n_in)) evaluated = .false. do alr = 1, dglap%reg_data%n_regions i_corr = 0 if (dglap%reg_data%regions(alr)%nlo_correction_type == "QCD") then i_corr = 1 else if (dglap%reg_data%regions(alr)%nlo_correction_type == "EW") then i_corr = 2 end if if (allocated (dglap%settings%selected_alr)) then if (.not. any (dglap%settings%selected_alr == alr)) cycle end if sqme_alr = zero emitter = dglap%reg_data%regions(alr)%emitter if (emitter > dglap%reg_data%n_in .or. i_corr == 0) cycle associate (i_flv_born => dglap%reg_data%regions(alr)%uborn_index, & i_flv_real => dglap%reg_data%regions(alr)%real_index) if (emitter == 0) then do emitter = 1, 2 if (evaluated(i_flv_born, i_flv_real, emitter)) cycle call evaluate_alr (alr, emitter, i_flv_born, i_flv_real, sqme_alr, evaluated) end do else if (emitter > 0) then if (evaluated(i_flv_born, i_flv_real, emitter)) cycle call evaluate_alr (alr, emitter, i_flv_born, i_flv_real, sqme_alr, evaluated) end if if (separate_uborns) then sqme_dglap(i_flv_born) = sqme_dglap(i_flv_born) & + alpha_coupling (i_corr)/ twopi * sqme_alr else sqme_dglap(1) = sqme_dglap(1) + alpha_coupling (i_corr)/ twopi * sqme_alr end if end associate end do contains <> end subroutine dglap_remnant_evaluate @ %def dglap_remnant_evaluate @ We introduce $\hat{P}(z, \epsilon) = (1 - z) P(z, \epsilon)$ and have \begin{align} \hat{P}_{g\to gg}(z) & = 2C_A \left[z + \frac{(1-z)^2}{z} + z(1-z)^2\right], \\ \hat{P}_{g\to qq}(z) & = C_F (1-z) \frac{1 + (1-z)^2}{z}, \\ \hat{P}_{q\to gq}(z) & = T_F (1 - z - 2z(1-z)^2), \\ \hat{P}_{q\to qg}(z) & = C_F (1 + z^2). \end{align} <>= function p_hat_gtogg (z) real(default) :: p_hat_gtogg <

> p_hat_gtogg = two * dglap%CA * (z + onemz**2 / z + z * onemz**2) end function p_hat_gtogg function p_hat_gtoqq (z) real(default) :: p_hat_gtoqq <

> p_hat_gtoqq = dglap%CF * onemz / z * (one + onemz**2) end function p_hat_gtoqq function p_hat_qtogq (z) real(default) :: p_hat_qtogq <

> p_hat_qtogq = dglap%TR * (onemz - two * z * onemz**2) end function p_hat_qtogq function p_hat_qtoqg (z) real(default) :: p_hat_qtoqg real(default), intent(in) :: z p_hat_qtoqg = dglap%CF * (one + z**2) end function p_hat_qtoqg @ %def p_hat_qtoqg, p_hat_qtogq, p_hat_gtoqq, p_hat_gtogg @ \begin{align} \frac{\partial P_{g\to gg}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = 0, \\ \frac{\partial P_{g\to qq}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -C_F z, \\ \frac{\partial P_{q\to gq}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = - 2 T_F z (1-z), \\ \frac{\partial P_{q\to qg}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -C_F (1-z).\\ \end{align} <>= function p_derived_gtogg (z) real(default) :: p_derived_gtogg real(default), intent(in) :: z p_derived_gtogg = zero end function p_derived_gtogg function p_derived_gtoqq (z) real(default) :: p_derived_gtoqq real(default), intent(in) :: z p_derived_gtoqq = -dglap%CF * z end function p_derived_gtoqq function p_derived_qtogq (z) real(default) :: p_derived_qtogq <

> p_derived_qtogq = -two * dglap%TR * z * onemz end function p_derived_qtogq function p_derived_qtoqg (z) real(default) :: p_derived_qtoqg <

> p_derived_qtoqg = -dglap%CF * onemz end function p_derived_qtoqg @ %def p_derived_gtogg, p_derived_gtoqq, p_derived_qtogq, p_derived_qtoqg @ <>= subroutine evaluate_alr (alr, emitter, i_flv_born, i_flv_real, sqme_alr, evaluated) integer, intent(in) :: alr, emitter, i_flv_born, i_flv_real real(default), intent(inout) :: sqme_alr logical, intent(inout), dimension(:,:,:) :: evaluated real(default) :: z, jac real(default) :: factor, factor_soft, plus_dist_remnant real(default) :: xb, onemz real(default) :: sqme_scaled, sqme_born_dglap real(default) :: charge_rad2, charge_em2 integer :: flv_em, flv_rad, N_col, i N_col = 1 sqme_born_dglap = zero associate (template => dglap%settings%fks_template) z = dglap%isr_kinematics%z(emitter) flv_rad = dglap%reg_data%regions(alr)%flst_real%flst(dglap%reg_data%n_legs_real) flv_em = dglap%reg_data%regions(alr)%flst_real%flst(emitter) charge_rad2 = dglap%reg_data%regions(alr)%flst_real%charge(dglap%reg_data%n_legs_real)**2 charge_em2 = dglap%reg_data%regions(alr)%flst_real%charge(emitter)**2 if (dglap%reg_data%regions(alr)%nlo_correction_type == "QCD") then call dglap%set_parameters (CA = CA, CF = CF, TR = TR) else if (dglap%reg_data%regions(alr)%nlo_correction_type == "EW") then if (is_quark(flv_rad)) N_col = NC call dglap%set_parameters (CA = zero, CF = charge_em2, TR = N_col*charge_rad2) end if jac = dglap%isr_kinematics%jacobian(emitter) onemz = one - z factor = log (sb * template%delta_i / two / z / fac_scale2) / & onemz + two * log (onemz) / onemz factor_soft = log (sb * template%delta_i / two / fac_scale2) / & onemz + two * log (onemz) / onemz xb = dglap%isr_kinematics%x(emitter) plus_dist_remnant = log ((one - xb) / template%xi_cut) * log (sb * template%delta_i / & two / fac_scale2) + (log (one - xb)**2 - log (template%xi_cut)**2) end associate if (dglap%reg_data%nlo_correction_type == "EW" .and. & dglap%reg_data%regions(alr)%nlo_correction_type == "QCD" .and. & qcd_ew_interferences (dglap%reg_data%regions(alr)%flst_uborn%flst)) then do i = 1, size (dglap%reg_data%regions(alr)%flst_uborn%flst) if (is_quark (dglap%reg_data%regions(alr)%flst_uborn%flst (i))) then sqme_born_dglap = -dglap%sqme_color_c_extra (i, i, i_flv_born)/CF exit end if end do else sqme_born_dglap = dglap%sqme_born(i_flv_born) end if sqme_scaled = sqme_born_dglap * dglap%sf_factors(alr, emitter) if (is_massless_vector (flv_em) .and. is_massless_vector (flv_rad)) then sqme_alr = sqme_alr + p_hat_gtogg(z) * factor / z * sqme_scaled * jac & - p_hat_gtogg(one) * factor_soft * sqme_born_dglap * jac & + p_hat_gtogg(one) * plus_dist_remnant * sqme_born_dglap else if (is_fermion (flv_em) .and. is_massless_vector (flv_rad)) then sqme_alr = sqme_alr + p_hat_qtoqg(z) * factor / z * sqme_scaled * jac & - p_derived_qtoqg(z) / z * sqme_scaled * jac & - p_hat_qtoqg(one) * factor_soft * sqme_born_dglap * jac & + p_hat_qtoqg(one) * plus_dist_remnant * sqme_born_dglap else if (is_fermion (flv_em) .and. is_fermion (flv_rad)) then sqme_alr = sqme_alr + (p_hat_gtoqq(z) * factor - p_derived_gtoqq(z)) / z * jac * & sqme_scaled else if (is_massless_vector (flv_em) .and. is_fermion (flv_rad)) then sqme_alr = sqme_alr + (p_hat_qtogq(z) * factor - p_derived_qtogq(z)) / z * sqme_scaled * jac else sqme_alr = sqme_alr + zero end if evaluated(i_flv_born, i_flv_real, emitter) = .true. end subroutine evaluate_alr @ %dglap_remnant_evaluate_alr @ <

>= real(default), intent(in) :: z real(default) :: onemz onemz = one - z @ %def variables @ <>= procedure :: final => dglap_remnant_final <>= subroutine dglap_remnant_final (dglap) class(dglap_remnant_t), intent(inout) :: dglap if (associated (dglap%isr_kinematics)) nullify (dglap%isr_kinematics) if (associated (dglap%reg_data)) nullify (dglap%reg_data) if (associated (dglap%settings)) nullify (dglap%settings) if (allocated (dglap%sqme_born)) deallocate (dglap%sqme_born) if (allocated (dglap%sf_factors)) deallocate (dglap%sf_factors) end subroutine dglap_remnant_final @ %def dglap_remnant_final @ \section{Dispatch} @ <<[[dispatch_fks.f90]]>>= <> module dispatch_fks <> <> use string_utils, only: split_string use variables, only: var_list_t use nlo_data, only: fks_template_t, FKS_DEFAULT, FKS_RESONANCES <> <> contains <> end module dispatch_fks @ %def dispatch_fks @ Initialize parameters used to optimize FKS calculations. <>= public :: dispatch_fks_s <>= subroutine dispatch_fks_s (fks_template, var_list) type(fks_template_t), intent(inout) :: fks_template type(var_list_t), intent(in) :: var_list real(default) :: fks_dij_exp1, fks_dij_exp2 type(string_t) :: fks_mapping_type logical :: subtraction_disabled type(string_t) :: exclude_from_resonance fks_dij_exp1 = & var_list%get_rval (var_str ("fks_dij_exp1")) fks_dij_exp2 = & var_list%get_rval (var_str ("fks_dij_exp2")) fks_mapping_type = & var_list%get_sval (var_str ("$fks_mapping_type")) subtraction_disabled = & var_list%get_lval (var_str ("?disable_subtraction")) exclude_from_resonance = & var_list%get_sval (var_str ("$resonances_exclude_particles")) if (exclude_from_resonance /= var_str ("default")) & call split_string (exclude_from_resonance, var_str (":"), & fks_template%excluded_resonances) call fks_template%set_parameters ( & exp1 = fks_dij_exp1, exp2 = fks_dij_exp2, & xi_min = var_list%get_rval (var_str ("fks_xi_min")), & y_max = var_list%get_rval (var_str ("fks_y_max")), & xi_cut = var_list%get_rval (var_str ("fks_xi_cut")), & delta_o = var_list%get_rval (var_str ("fks_delta_o")), & delta_i = var_list%get_rval (var_str ("fks_delta_i"))) select case (char (fks_mapping_type)) case ("default") call fks_template%set_mapping_type (FKS_DEFAULT) case ("resonances") call fks_template%set_mapping_type (FKS_RESONANCES) end select fks_template%subtraction_disabled = subtraction_disabled fks_template%n_f = var_list%get_ival (var_str ("alphas_nf")) end subroutine dispatch_fks_s @ %def dispatch_fks_s @ Index: trunk/src/blha/blha.nw =================================================================== --- trunk/src/blha/blha.nw (revision 8792) +++ trunk/src/blha/blha.nw (revision 8793) @@ -1,4255 +1,4260 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: matrix elements and process libraries %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{BLHA Interface} \includemodulegraph{blha} The code in this chapter implements support for the BLHA record that communicates data for NLO processes. These are the modules: \begin{description} \item[blha\_config] \item[blha\_olp\_interfaces] \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% The module is split into a configuration interface which manages configuration and handles the request and contract files, a module which interfaces the OLP matrix elements and a driver. <<[[blha_config.f90]]>>= <> module blha_config use kinds <> use variables, only: var_list_t use model_data use beam_structures, only: beam_structure_t <> <> <> <> <> <> interface <> end interface end module blha_config @ %def blha_config @ <<[[blha_config_sub.f90]]>>= <> submodule (blha_config) blha_config_s <> use io_units use constants use string_utils use physics_defs, only: PHOTON, PHOTON_OFFSHELL use diagnostics use flavors use pdg_arrays implicit none contains <> end submodule blha_config_s @ %def blha_config_s @ \section{Configuration} Parameters to enumerate the different options in the order. <>= integer, public, parameter :: & BLHA_CT_QCD = 1, BLHA_CT_EW = 2, BLHA_CT_OTHER = 3 integer, public, parameter :: & BLHA_IRREG_CDR = 1, BLHA_IRREG_DRED = 2, BLHA_IRREG_THV = 3, & BLHA_IRREG_MREG = 4, BLHA_IRREG_OTHER = 5 integer, public, parameter :: & BLHA_MPS_ONSHELL = 1, BLHA_MPS_OTHER = 2 integer, public, parameter :: & BLHA_MODE_GOSAM = 1, BLHA_MODE_FEYNARTS = 2, BLHA_MODE_GENERIC = 3, & BLHA_MODE_OPENLOOPS = 4 integer, public, parameter :: & BLHA_VERSION_1 = 1, BLHA_VERSION_2 = 2 integer, public, parameter :: & BLHA_AMP_LOOP = 1, BLHA_AMP_COLOR_C = 2, BLHA_AMP_SPIN_C = 3, & BLHA_AMP_TREE = 4, BLHA_AMP_LOOPINDUCED = 5 integer, public, parameter :: & BLHA_EW_INTERNAL = 0, & BLHA_EW_GF = 1, BLHA_EW_MZ = 2, BLHA_EW_MSBAR = 3, & BLHA_EW_0 = 4, BLHA_EW_RUN = 5 integer, public, parameter :: & BLHA_WIDTH_COMPLEX = 1, BLHA_WIDTH_FIXED = 2, & BLHA_WIDTH_RUNNING = 3, BLHA_WIDTH_POLE = 4, & BLHA_WIDTH_DEFAULT = 5 @ %def blha_ct_qcd blha_ct_ew blha_ct_other @ %def blha_irreg_cdr blha_irreg_dred blha_irreg_thv blha_irreg_mreg blha_irreg_other @ %def blha_mps_onshell blha_mps_other @ %def blha_mode_gosam blha_mode_feynarts blha_mode_generic @ %def blha version blha_amp blha_ew blha_width @ Those are the default pdg codes for massive particles in BLHA programs <>= integer, parameter, public :: OLP_N_MASSIVE_PARTICLES = 12 integer, dimension(OLP_N_MASSIVE_PARTICLES), public :: & OLP_MASSIVE_PARTICLES = [5, -5, 6, -6, 13, -13, 15, -15, 23, 24, -24, 25] integer, parameter :: OLP_HEL_UNPOLARIZED = 0 @ %def OLP_MASSIVE_PARTICLES @ The user might provide an extra command string for OpenLoops to apply special libraries instead of the default ones, such as signal-only amplitudes for off-shell top production. We check in this subroutine that the provided string is valid and print out the possible options to ease the user's memory. <>= integer, parameter :: N_KNOWN_SPECIAL_OL_METHODS = 3 <>= subroutine check_extra_cmd (extra_cmd) type(string_t), intent(in) :: extra_cmd type(string_t), dimension(N_KNOWN_SPECIAL_OL_METHODS) :: known_methods integer :: i logical :: found known_methods(1) = 'top' known_methods(2) = 'not' known_methods(3) = 'stop' if (extra_cmd == var_str ("")) return found = .false. do i = 1, N_KNOWN_SPECIAL_OL_METHODS found = found .or. & (extra_cmd == var_str ('extra approx ') // known_methods(i)) end do if (.not. found) & call msg_fatal ("The given extra OpenLoops method is not kown ", & [var_str ("Available commands are: "), & var_str ("extra approx top (only WbWb signal),"), & var_str ("extra approx stop (only WbWb singletop),"), & var_str ("extra approx not (no top in WbWb).")]) end subroutine check_extra_cmd @ %def check_extra_cmd @ This type contains the pdg code of the particle to be written in the process specification string and an optional additional information about the polarization of the particles. Note that the output can only be processed by OpenLoops. <>= type :: blha_particle_string_element_t integer :: pdg = 0 integer :: hel = OLP_HEL_UNPOLARIZED logical :: polarized = .false. contains <> end type blha_particle_string_element_t @ %def blha_particle_string_element_t @ <>= generic :: init => init_default generic :: init => init_polarized procedure :: init_default => blha_particle_string_element_init_default procedure :: init_polarized => blha_particle_string_element_init_polarized <>= module subroutine blha_particle_string_element_init_default (blha_p, id) class(blha_particle_string_element_t), intent(out) :: blha_p integer, intent(in) :: id end subroutine blha_particle_string_element_init_default module subroutine blha_particle_string_element_init_polarized (blha_p, id, hel) class(blha_particle_string_element_t), intent(out) :: blha_p integer, intent(in) :: id, hel end subroutine blha_particle_string_element_init_polarized <>= module subroutine blha_particle_string_element_init_default (blha_p, id) class(blha_particle_string_element_t), intent(out) :: blha_p integer, intent(in) :: id blha_p%pdg = id end subroutine blha_particle_string_element_init_default @ %def blha_particle_string_element_init_default @ <>= module subroutine blha_particle_string_element_init_polarized (blha_p, id, hel) class(blha_particle_string_element_t), intent(out) :: blha_p integer, intent(in) :: id, hel blha_p%polarized = .true. blha_p%pdg = id blha_p%hel = hel end subroutine blha_particle_string_element_init_polarized @ %def blha_particle_string_element_init_polarized @ <>= generic :: write_pdg => write_pdg_unit generic :: write_pdg => write_pdg_character procedure :: write_pdg_unit => blha_particle_string_element_write_pdg_unit procedure :: write_pdg_character & => blha_particle_string_element_write_pdg_character <>= module subroutine blha_particle_string_element_write_pdg_unit (blha_p, unit) class(blha_particle_string_element_t), intent(in) :: blha_p integer, intent(in), optional :: unit end subroutine blha_particle_string_element_write_pdg_unit module subroutine blha_particle_string_element_write_pdg_character (blha_p, c) class(blha_particle_string_element_t), intent(in) :: blha_p character(3), intent(inout) :: c end subroutine blha_particle_string_element_write_pdg_character <>= module subroutine blha_particle_string_element_write_pdg_unit (blha_p, unit) class(blha_particle_string_element_t), intent(in) :: blha_p integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, '(I3)') blha_p%pdg end subroutine blha_particle_string_element_write_pdg_unit @ %def blha_particle_string_element_write_pdg_unit @ <>= module subroutine blha_particle_string_element_write_pdg_character (blha_p, c) class(blha_particle_string_element_t), intent(in) :: blha_p character(3), intent(inout) :: c write (c, '(I3)') blha_p%pdg end subroutine blha_particle_string_element_write_pdg_character @ %def blha_particle_string_element_write_pdg_character @ <>= generic :: write_helicity => write_helicity_unit generic :: write_helicity => write_helicity_character procedure :: write_helicity_unit & => blha_particle_string_element_write_helicity_unit procedure :: write_helicity_character & => blha_particle_string_element_write_helicity_character <>= module subroutine blha_particle_string_element_write_helicity_unit (blha_p, unit) class(blha_particle_string_element_t), intent(in) :: blha_p integer, intent(in), optional :: unit end subroutine blha_particle_string_element_write_helicity_unit module subroutine blha_particle_string_element_write_helicity_character (blha_p, c) class(blha_particle_string_element_t), intent(in) :: blha_p character(4), intent(inout) :: c end subroutine blha_particle_string_element_write_helicity_character <>= module subroutine blha_particle_string_element_write_helicity_unit (blha_p, unit) class(blha_particle_string_element_t), intent(in) :: blha_p integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, '(A1,I0,A1)') '(', blha_p%hel, ')' end subroutine blha_particle_string_element_write_helicity_unit @ %def blha_particle_string_element_write_helicity_unit @ <>= module subroutine blha_particle_string_element_write_helicity_character (blha_p, c) class(blha_particle_string_element_t), intent(in) :: blha_p character(4), intent(inout) :: c write (c, '(A1,I0,A1)') '(', blha_p%hel, ')' end subroutine blha_particle_string_element_write_helicity_character @ %def blha_particle_string_element_write_helicity_character @ This type encapsulates a BLHA request. <>= public :: blha_configuration_t public :: blha_cfg_process_node_t <>= type :: blha_cfg_process_node_t type(blha_particle_string_element_t), dimension(:), allocatable :: pdg_in, pdg_out integer, dimension(:), allocatable :: fingerprint integer :: nsub integer, dimension(:), allocatable :: ids integer :: amplitude_type type(blha_cfg_process_node_t), pointer :: next => null () end type blha_cfg_process_node_t type :: blha_configuration_t type(string_t) :: name class(model_data_t), pointer :: model => null () type(string_t) :: md5 integer :: version = 2 logical :: dirty = .false. integer :: n_proc = 0 real(default) :: accuracy_target logical :: debug_unstable = .false. integer :: mode = BLHA_MODE_GENERIC logical :: polarized = .false. type(blha_cfg_process_node_t), pointer :: processes => null () !integer, dimension(2) :: matrix_element_square_type = BLHA_MEST_SUM integer :: correction_type type(string_t) :: correction_type_other integer :: irreg = BLHA_IRREG_THV type(string_t) :: irreg_other integer :: massive_particle_scheme = BLHA_MPS_ONSHELL type(string_t) :: massive_particle_scheme_other type(string_t) :: model_file logical :: subdivide_subprocesses = .false. integer :: alphas_power = -1, alpha_power = -1 integer :: ew_scheme = BLHA_EW_GF integer :: width_scheme = BLHA_WIDTH_DEFAULT logical :: openloops_use_cms = .false. integer :: openloops_phs_tolerance = 0 type(string_t) :: openloops_extra_cmd integer :: openloops_stability_log = 0 integer :: n_off_photons_is = 0 integer :: n_off_photons_fs = 0 end type blha_configuration_t @ %def blha_cffg_process_node_t blha_configuration_t @ Translate the SINDARIN input string to the corresponding named integer. <>= public :: ew_scheme_string_to_int <>= module function ew_scheme_string_to_int (ew_scheme_str) result (ew_scheme_int) integer :: ew_scheme_int type(string_t), intent(in) :: ew_scheme_str end function ew_scheme_string_to_int <>= module function ew_scheme_string_to_int (ew_scheme_str) result (ew_scheme_int) integer :: ew_scheme_int type(string_t), intent(in) :: ew_scheme_str select case (char (ew_scheme_str)) case ('GF', 'Gmu') ew_scheme_int = BLHA_EW_GF case ('alpha_qed', 'alpha_internal') ew_scheme_int = BLHA_EW_INTERNAL case ('alpha_mz') ew_scheme_int = BLHA_EW_MZ case ('alpha_0', 'alpha_thompson') ew_scheme_int = BLHA_EW_0 case default call msg_fatal ("ew_scheme: " // char (ew_scheme_str) // & " not supported. Try 'Gmu', 'alpha_internal', 'alpha_mz' or 'alpha_0'.") end select end function ew_scheme_string_to_int @ %def ew_scheme_string_to_int @ @ Translate the SINDARIN input string to the corresponding named integer denoting the type of NLO correction. <>= public :: correction_type_string_to_int <>= module function correction_type_string_to_int & (correction_type_str) result (correction_type_int) integer :: correction_type_int type(string_t), intent(in) :: correction_type_str end function correction_type_string_to_int <>= module function correction_type_string_to_int & (correction_type_str) result (correction_type_int) integer :: correction_type_int type(string_t), intent(in) :: correction_type_str select case (char (correction_type_str)) case ('QCD') correction_type_int = BLHA_CT_QCD case ('EW') correction_type_int = BLHA_CT_EW case default call msg_warning ("nlo_correction_type: " // char (correction_type_str) // & " not supported. Try setting it to 'QCD', 'EW'.") end select end function correction_type_string_to_int @ %def correction_type_string_to_int @ This types control the creation of BLHA-interface files <>= public :: blha_flv_state_t public :: blha_master_t <>= type:: blha_flv_state_t integer, dimension(:), allocatable :: flavors integer :: flv_mult logical :: flv_real = .false. end type blha_flv_state_t type :: blha_master_t integer, dimension(5) :: blha_mode = BLHA_MODE_GENERIC logical :: compute_borns = .false. logical :: compute_real_trees = .false. logical :: compute_loops = .true. logical :: compute_correlations = .false. logical :: compute_dglap = .false. integer :: ew_scheme type(string_t), dimension(:), allocatable :: suffix type(blha_configuration_t), dimension(:), allocatable :: blha_cfg integer :: n_files = 0 integer, dimension(:), allocatable :: i_file_to_nlo_index contains <> end type blha_master_t @ %def blha_flv_state_t, blha_master_t @ Master-Routines <>= procedure :: set_methods => blha_master_set_methods <>= module subroutine blha_master_set_methods (master, is_nlo, var_list) class(blha_master_t), intent(inout) :: master logical, intent(in) :: is_nlo type(var_list_t), intent(in) :: var_list end subroutine blha_master_set_methods <>= module subroutine blha_master_set_methods (master, is_nlo, var_list) class(blha_master_t), intent(inout) :: master logical, intent(in) :: is_nlo type(var_list_t), intent(in) :: var_list type(string_t) :: method, born_me_method, real_tree_me_method type(string_t) :: loop_me_method, correlation_me_method type(string_t) :: dglap_me_method type(string_t) :: default_method logical :: cmp_born, cmp_real logical :: cmp_loop, cmp_corr logical :: cmp_dglap if (is_nlo) then method = var_list%get_sval (var_str ("$method")) born_me_method = var_list%get_sval (var_str ("$born_me_method")) if (born_me_method == "") born_me_method = method real_tree_me_method = var_list%get_sval (var_str ("$real_tree_me_method")) if (real_tree_me_method == "") real_tree_me_method = method loop_me_method = var_list%get_sval (var_str ("$loop_me_method")) if (loop_me_method == "") loop_me_method = method correlation_me_method = var_list%get_sval (var_str ("$correlation_me_method")) if (correlation_me_method == "") correlation_me_method = method dglap_me_method = var_list%get_sval (var_str ("$dglap_me_method")) if (dglap_me_method == "") dglap_me_method = method cmp_born = born_me_method /= 'omega' cmp_real = is_nlo .and. (real_tree_me_method /= 'omega') cmp_loop = is_nlo .and. (loop_me_method /= 'omega') cmp_corr = is_nlo .and. (correlation_me_method /= 'omega') cmp_dglap = is_nlo .and. (dglap_me_method /= 'omega') call set_me_method (1, loop_me_method) call set_me_method (2, correlation_me_method) call set_me_method (3, real_tree_me_method) call set_me_method (4, born_me_method) call set_me_method (5, dglap_me_method) else default_method = var_list%get_sval (var_str ("$method")) cmp_born = default_method /= 'omega' cmp_real = .false.; cmp_loop = .false.; cmp_corr = .false. call set_me_method (4, default_method) end if master%n_files = count ([cmp_born, cmp_real, cmp_loop, cmp_corr, cmp_dglap]) call set_nlo_indices () master%compute_borns = cmp_born master%compute_real_trees = cmp_real master%compute_loops = cmp_loop master%compute_correlations = cmp_corr master%compute_dglap = cmp_dglap contains subroutine set_nlo_indices () integer :: i_file allocate (master%i_file_to_nlo_index (master%n_files)) master%i_file_to_nlo_index = 0 i_file = 0 if (cmp_loop) then i_file = i_file + 1 master%i_file_to_nlo_index(i_file) = 1 end if if (cmp_corr) then i_file = i_file + 1 master%i_file_to_nlo_index(i_file) = 2 end if if (cmp_real) then i_file = i_file + 1 master%i_file_to_nlo_index(i_file) = 3 end if if (cmp_born) then i_file = i_file + 1 master%i_file_to_nlo_index(i_file) = 4 end if if (cmp_dglap) then i_file = i_file + 1 master%i_file_to_nlo_index(i_file) = 5 end if end subroutine set_nlo_indices subroutine set_me_method (i, me_method) integer, intent(in) :: i type(string_t) :: me_method select case (char (me_method)) case ('gosam') call master%set_gosam (i) case ('openloops') call master%set_openloops (i) end select end subroutine set_me_method end subroutine blha_master_set_methods @ %def blha_master_set_methods @ <>= procedure :: allocate_config_files => blha_master_allocate_config_files <>= module subroutine blha_master_allocate_config_files (master) class(blha_master_t), intent(inout) :: master end subroutine blha_master_allocate_config_files <>= module subroutine blha_master_allocate_config_files (master) class(blha_master_t), intent(inout) :: master allocate (master%blha_cfg (master%n_files)) allocate (master%suffix (master%n_files)) end subroutine blha_master_allocate_config_files @ %def blha_master_allocate_config_files @ <>= procedure :: set_ew_scheme => blha_master_set_ew_scheme <>= module subroutine blha_master_set_ew_scheme (master, ew_scheme) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: ew_scheme end subroutine blha_master_set_ew_scheme <>= module subroutine blha_master_set_ew_scheme (master, ew_scheme) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: ew_scheme master%ew_scheme = ew_scheme_string_to_int (ew_scheme) end subroutine blha_master_set_ew_scheme @ %def blha_master_set_ew_scheme @ <>= procedure :: set_correction_type => blha_master_set_correction_type <>= module subroutine blha_master_set_correction_type (master, correction_type_str) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: correction_type_str end subroutine blha_master_set_correction_type <>= module subroutine blha_master_set_correction_type (master, correction_type_str) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: correction_type_str master%blha_cfg(:)%correction_type = & correction_type_string_to_int (correction_type_str) end subroutine blha_master_set_correction_type @ %def blha_master_set_correction_type @ <>= procedure :: set_photon_characteristics => blha_master_set_photon_characteristics <>= module subroutine blha_master_set_photon_characteristics (master, flv_born, n_in) class(blha_master_t), intent(inout) :: master integer, dimension(:,:), intent(in) :: flv_born integer, intent(in) :: n_in end subroutine blha_master_set_photon_characteristics <>= module subroutine blha_master_set_photon_characteristics (master, flv_born, n_in) class(blha_master_t), intent(inout) :: master integer, dimension(:,:), intent(in) :: flv_born integer, intent(in) :: n_in integer :: i_file, i, i_flv integer :: noff_is, noff_fs, noff_is_max, noff_fs_max do i_file = 1, master%n_files noff_is_max = 0; noff_fs_max = 0 do i_flv = 1, size (flv_born, 2) noff_is = 0; noff_fs = 0 do i = 1, n_in if (flv_born (i, i_flv) == PHOTON) noff_is = noff_is + 1 end do noff_is_max = max (noff_is, noff_is_max) do i = n_in + 1, size (flv_born(:, i_flv)) if (flv_born (i, i_flv) == PHOTON) noff_fs = noff_fs + 1 end do noff_fs_max = max (noff_fs, noff_fs_max) end do if (master%blha_cfg(i_file)%correction_type == BLHA_CT_EW & .and. master%ew_scheme == BLHA_EW_0 & .and. (noff_is_max > 0 .or. noff_fs_max > 0)) then call msg_fatal ("For NLO EW/mixed corrections, 'alpha_0'/" & // "'alpha_thompson' are ", [ var_str ("inconsistent EW input " & // "schemes. Please use 'alpha_mz' or 'Gmu'")]) end if master%blha_cfg(i_file)%n_off_photons_is = noff_is_max master%blha_cfg(i_file)%n_off_photons_fs = noff_fs_max end do end subroutine blha_master_set_photon_characteristics @ %def blha_master_set_photon_characteristics @ <>= procedure :: generate => blha_master_generate <>= module subroutine blha_master_generate (master, basename, model, & n_in, alpha_power, alphas_power, flv_born, flv_real) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: basename class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in integer, intent(in) :: alpha_power, alphas_power integer, intent(in), dimension(:,:), allocatable :: flv_born, flv_real end subroutine blha_master_generate <>= module subroutine blha_master_generate (master, basename, model, & n_in, alpha_power, alphas_power, flv_born, flv_real) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: basename class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in integer, intent(in) :: alpha_power, alphas_power integer, intent(in), dimension(:,:), allocatable :: flv_born, flv_real integer :: i_file if (master%n_files < 1) & call msg_fatal ("Attempting to generate OLP-files, but none are specified!") i_file = 1 call master%generate_loop (basename, model, n_in, alpha_power, & alphas_power, flv_born, i_file) call master%generate_correlation (basename, model, n_in, alpha_power, & alphas_power, flv_born, i_file) call master%generate_real_tree (basename, model, n_in, alpha_power, & alphas_power, flv_real, i_file) call master%generate_born (basename, model, n_in, alpha_power, & alphas_power, flv_born, i_file) call master%generate_dglap (basename, model, n_in, alpha_power, & alphas_power, flv_born, i_file) end subroutine blha_master_generate @ %def blha_master_generate @ <>= procedure :: generate_loop => blha_master_generate_loop <>= module subroutine blha_master_generate_loop (master, basename, model, n_in, & alpha_power, alphas_power, flv_born, i_file) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: basename class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in integer, intent(in) :: alpha_power, alphas_power integer, dimension(:,:), allocatable, intent(in) :: flv_born integer, intent(inout) :: i_file end subroutine blha_master_generate_loop <>= module subroutine blha_master_generate_loop (master, basename, model, n_in, & alpha_power, alphas_power, flv_born, i_file) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: basename class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in integer, intent(in) :: alpha_power, alphas_power integer, dimension(:,:), allocatable, intent(in) :: flv_born integer, intent(inout) :: i_file type(blha_flv_state_t), dimension(:), allocatable :: blha_flavor integer :: i_flv if (master%compute_loops) then if (allocated (flv_born)) then allocate (blha_flavor (size (flv_born, 2))) do i_flv = 1, size (flv_born, 2) allocate (blha_flavor(i_flv)%flavors (size (flv_born(:,i_flv)))) blha_flavor(i_flv)%flavors = flv_born(:,i_flv) blha_flavor(i_flv)%flv_mult = 2 end do master%suffix(i_file) = blha_get_additional_suffix (var_str ("_LOOP")) call blha_init_virtual (master%blha_cfg(i_file), blha_flavor, & n_in, alpha_power, alphas_power, master%ew_scheme, & basename, model, master%blha_mode(1), master%suffix(i_file)) i_file = i_file + 1 else call msg_fatal ("BLHA Loops requested but " & // "Born flavor not existing") end if end if end subroutine blha_master_generate_loop @ %def blha_master_generate_loop @ <>= procedure :: generate_correlation => blha_master_generate_correlation <>= module subroutine blha_master_generate_correlation (master, basename, model, n_in, & alpha_power, alphas_power, flv_born, i_file) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: basename class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in integer, intent(in) :: alpha_power, alphas_power integer, dimension(:,:), allocatable, intent(in) :: flv_born integer, intent(inout) :: i_file end subroutine blha_master_generate_correlation <>= module subroutine blha_master_generate_correlation (master, basename, model, n_in, & alpha_power, alphas_power, flv_born, i_file) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: basename class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in integer, intent(in) :: alpha_power, alphas_power integer, dimension(:,:), allocatable, intent(in) :: flv_born integer, intent(inout) :: i_file type(blha_flv_state_t), dimension(:), allocatable :: blha_flavor integer :: i_flv if (master%compute_correlations) then if (allocated (flv_born)) then allocate (blha_flavor (size (flv_born, 2))) do i_flv = 1, size (flv_born, 2) allocate (blha_flavor(i_flv)%flavors (size (flv_born(:,i_flv)))) blha_flavor(i_flv)%flavors = flv_born(:,i_flv) blha_flavor(i_flv)%flv_mult = 3 end do master%suffix(i_file) = blha_get_additional_suffix (var_str ("_SUB")) call blha_init_subtraction (master%blha_cfg(i_file), blha_flavor, & n_in, alpha_power, alphas_power, master%ew_scheme, & basename, model, master%blha_mode(2), master%suffix(i_file)) i_file = i_file + 1 else call msg_fatal ("BLHA Correlations requested but "& // "Born flavor not existing") end if end if end subroutine blha_master_generate_correlation @ %def blha_master_generate_correlation @ <>= procedure :: generate_real_tree => blha_master_generate_real_tree <>= module subroutine blha_master_generate_real_tree (master, basename, model, n_in, & alpha_power, alphas_power, flv_real, i_file) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: basename class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in integer, intent(in) :: alpha_power, alphas_power integer, dimension(:,:), allocatable, intent(in) :: flv_real integer, intent(inout) :: i_file end subroutine blha_master_generate_real_tree <>= module subroutine blha_master_generate_real_tree (master, basename, model, n_in, & alpha_power, alphas_power, flv_real, i_file) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: basename class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in integer, intent(in) :: alpha_power, alphas_power integer, dimension(:,:), allocatable, intent(in) :: flv_real integer, intent(inout) :: i_file type(blha_flv_state_t), dimension(:), allocatable :: blha_flavor integer :: i_flv if (master%compute_real_trees) then if (allocated (flv_real)) then allocate (blha_flavor (size (flv_real, 2))) do i_flv = 1, size (flv_real, 2) allocate (blha_flavor(i_flv)%flavors (size (flv_real(:,i_flv)))) blha_flavor(i_flv)%flavors = flv_real(:,i_flv) blha_flavor(i_flv)%flv_mult = 1 end do master%suffix(i_file) = blha_get_additional_suffix (var_str ("_REAL")) call blha_init_real (master%blha_cfg(i_file), blha_flavor, & n_in, alpha_power, alphas_power, master%ew_scheme, & basename, model, master%blha_mode(3), master%suffix(i_file)) i_file = i_file + 1 else call msg_fatal ("BLHA Trees requested but "& // "Real flavor not existing") end if end if end subroutine blha_master_generate_real_tree @ %def blha_master_generate_real_tree @ <>= procedure :: generate_born => blha_master_generate_born <>= module subroutine blha_master_generate_born (master, basename, model, n_in, & alpha_power, alphas_power, flv_born, i_file) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: basename class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in integer, intent(in) :: alpha_power, alphas_power integer, dimension(:,:), allocatable, intent(in) :: flv_born integer, intent(inout) :: i_file end subroutine blha_master_generate_born <>= module subroutine blha_master_generate_born (master, basename, model, n_in, & alpha_power, alphas_power, flv_born, i_file) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: basename class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in integer, intent(in) :: alpha_power, alphas_power integer, dimension(:,:), allocatable, intent(in) :: flv_born integer, intent(inout) :: i_file type(blha_flv_state_t), dimension(:), allocatable :: blha_flavor integer :: i_flv if (master%compute_borns) then if (allocated (flv_born)) then allocate (blha_flavor (size (flv_born, 2))) do i_flv = 1, size (flv_born, 2) allocate (blha_flavor(i_flv)%flavors (size (flv_born(:,i_flv)))) blha_flavor(i_flv)%flavors = flv_born(:,i_flv) blha_flavor(i_flv)%flv_mult = 1 end do master%suffix(i_file) = blha_get_additional_suffix (var_str ("_BORN")) call blha_init_born (master%blha_cfg(i_file), blha_flavor, & n_in, alpha_power, alphas_power, master%ew_scheme, & basename, model, master%blha_mode(4), master%suffix(i_file)) i_file = i_file + 1 end if end if end subroutine blha_master_generate_born @ %def blha_master_generate_born @ <>= procedure :: generate_dglap => blha_master_generate_dglap <>= module subroutine blha_master_generate_dglap (master, basename, model, n_in, & alpha_power, alphas_power, flv_born, i_file) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: basename class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in integer, intent(in) :: alpha_power, alphas_power integer, dimension(:,:), allocatable, intent(in) :: flv_born integer, intent(inout) :: i_file end subroutine blha_master_generate_dglap <>= module subroutine blha_master_generate_dglap (master, basename, model, n_in, & alpha_power, alphas_power, flv_born, i_file) class(blha_master_t), intent(inout) :: master type(string_t), intent(in) :: basename class(model_data_t), intent(in), target :: model integer, intent(in) :: n_in integer, intent(in) :: alpha_power, alphas_power integer, dimension(:,:), allocatable, intent(in) :: flv_born integer, intent(inout) :: i_file type(blha_flv_state_t), dimension(:), allocatable :: blha_flavor integer :: i_flv if (master%compute_dglap) then if (allocated (flv_born)) then allocate (blha_flavor (size (flv_born, 2))) do i_flv = 1, size (flv_born, 2) allocate (blha_flavor(i_flv)%flavors (size (flv_born(:,i_flv)))) blha_flavor(i_flv)%flavors = flv_born(:,i_flv) blha_flavor(i_flv)%flv_mult = 2 end do master%suffix(i_file) = blha_get_additional_suffix (var_str ("_DGLAP")) call blha_init_dglap (master%blha_cfg(i_file), blha_flavor, & n_in, alpha_power, alphas_power, master%ew_scheme, & basename, model, master%blha_mode(5), master%suffix(i_file)) i_file = i_file + 1 end if end if end subroutine blha_master_generate_dglap @ %def blha_master_generate_dglap @ <>= procedure :: setup_additional_features => blha_master_setup_additional_features <>= module subroutine blha_master_setup_additional_features (master, & phs_tolerance, use_cms, stability_log, extra_cmd, beam_structure) class(blha_master_t), intent(inout) :: master integer, intent(in) :: phs_tolerance logical, intent(in) :: use_cms type(string_t), intent(in), optional :: extra_cmd integer, intent(in) :: stability_log type(beam_structure_t), intent(in), optional :: beam_structure end subroutine blha_master_setup_additional_features <>= module subroutine blha_master_setup_additional_features (master, & phs_tolerance, use_cms, stability_log, extra_cmd, beam_structure) class(blha_master_t), intent(inout) :: master integer, intent(in) :: phs_tolerance logical, intent(in) :: use_cms type(string_t), intent(in), optional :: extra_cmd integer, intent(in) :: stability_log type(beam_structure_t), intent(in), optional :: beam_structure integer :: i_file logical :: polarized, throw_warning polarized = .false. if (present (beam_structure)) polarized = beam_structure%has_polarized_beams () throw_warning = .false. if (use_cms) then throw_warning = throw_warning .or. (master%compute_loops & .and. master%blha_mode(1) /= BLHA_MODE_OPENLOOPS) throw_warning = throw_warning .or. (master%compute_correlations & .and. master%blha_mode(2) /= BLHA_MODE_OPENLOOPS) throw_warning = throw_warning .or. (master%compute_real_trees & .and. master%blha_mode(3) /= BLHA_MODE_OPENLOOPS) throw_warning = throw_warning .or. (master%compute_borns & .and. master%blha_mode(4) /= BLHA_MODE_OPENLOOPS) throw_warning = throw_warning .or. (master%compute_dglap & .and. master%blha_mode(5) /= BLHA_MODE_OPENLOOPS) if (throw_warning) call cms_warning () end if do i_file = 1, master%n_files if (phs_tolerance > 0) then select case (master%blha_mode (master%i_file_to_nlo_index(i_file))) case (BLHA_MODE_GOSAM) if (polarized) call gosam_error_message () case (BLHA_MODE_OPENLOOPS) master%blha_cfg(i_file)%openloops_use_cms = use_cms master%blha_cfg(i_file)%openloops_phs_tolerance = phs_tolerance master%blha_cfg(i_file)%polarized = polarized if (present (extra_cmd)) then master%blha_cfg(i_file)%openloops_extra_cmd = extra_cmd else master%blha_cfg(i_file)%openloops_extra_cmd = var_str ('') end if master%blha_cfg(i_file)%openloops_stability_log = stability_log end select end if end do contains subroutine cms_warning () call msg_warning ("You have set ?openloops_use_cms = true, but not all active matrix ", & [var_str ("element methods are set to OpenLoops. Note that other "), & var_str ("methods might not necessarily support the complex mass "), & var_str ("scheme. This can yield inconsistencies in your NLO results!")]) end subroutine cms_warning subroutine gosam_error_message () call msg_fatal ("You are trying to evaluate a process at NLO ", & [var_str ("which involves polarized beams using GoSam. "), & var_str ("This feature is not supported yet. "), & var_str ("Please use OpenLoops instead")]) end subroutine gosam_error_message end subroutine blha_master_setup_additional_features @ %def blha_master_setup_additional_features @ <>= procedure :: set_gosam => blha_master_set_gosam <>= module subroutine blha_master_set_gosam (master, i) class(blha_master_t), intent(inout) :: master integer, intent(in) :: i end subroutine blha_master_set_gosam <>= module subroutine blha_master_set_gosam (master, i) class(blha_master_t), intent(inout) :: master integer, intent(in) :: i master%blha_mode(i) = BLHA_MODE_GOSAM end subroutine blha_master_set_gosam @ %def blha_master_set_gosam @ <>= procedure :: set_openloops => blha_master_set_openloops <>= module subroutine blha_master_set_openloops (master, i) class(blha_master_t), intent(inout) :: master integer, intent(in) :: i end subroutine blha_master_set_openloops <>= module subroutine blha_master_set_openloops (master, i) class(blha_master_t), intent(inout) :: master integer, intent(in) :: i master%blha_mode(i) = BLHA_MODE_OPENLOOPS end subroutine blha_master_set_openloops @ %def blha_master_set_openloops @ <>= procedure :: set_polarization => blha_master_set_polarization <>= module subroutine blha_master_set_polarization (master, i) class(blha_master_t), intent(inout) :: master integer, intent(in) :: i end subroutine blha_master_set_polarization <>= module subroutine blha_master_set_polarization (master, i) class(blha_master_t), intent(inout) :: master integer, intent(in) :: i master%blha_cfg(i)%polarized = .true. end subroutine blha_master_set_polarization @ %def blha_master_set_polarization @ <>= subroutine blha_init_born (blha_cfg, blha_flavor, n_in, & ap, asp, ew_scheme, basename, model, blha_mode, suffix) type(blha_configuration_t), intent(inout) :: blha_cfg type(blha_flv_state_t), intent(in), dimension(:) :: blha_flavor integer, intent(in) :: n_in integer, intent(in) :: ap, asp integer, intent(in) :: ew_scheme type(string_t), intent(in) :: basename type(model_data_t), intent(in), target :: model integer, intent(in) :: blha_mode type(string_t), intent(in) :: suffix integer, dimension(:), allocatable :: amp_type integer :: i allocate (amp_type (size (blha_flavor))) do i = 1, size (blha_flavor) amp_type(i) = BLHA_AMP_TREE end do call blha_configuration_init (blha_cfg, basename // suffix , & model, blha_mode) call blha_configuration_append_processes (blha_cfg, n_in, & blha_flavor, amp_type) call blha_configuration_set (blha_cfg, BLHA_VERSION_2, & irreg = BLHA_IRREG_CDR, alphas_power = asp, & alpha_power = ap, ew_scheme = ew_scheme, & debug = blha_mode == BLHA_MODE_GOSAM) end subroutine blha_init_born subroutine blha_init_virtual (blha_cfg, blha_flavor, n_in, & ap, asp, ew_scheme, basename, model, blha_mode, suffix) type(blha_configuration_t), intent(inout) :: blha_cfg type(blha_flv_state_t), intent(in), dimension(:) :: blha_flavor integer, intent(in) :: n_in integer, intent(in) :: ap, asp integer, intent(in) :: ew_scheme type(string_t), intent(in) :: basename type(model_data_t), intent(in), target :: model integer, intent(in) :: blha_mode type(string_t), intent(in) :: suffix integer, dimension(:), allocatable :: amp_type integer :: i allocate (amp_type (size (blha_flavor) * 2)) do i = 1, size (blha_flavor) amp_type(2 * i - 1) = BLHA_AMP_LOOP amp_type(2 * i) = BLHA_AMP_COLOR_C end do call blha_configuration_init (blha_cfg, basename // suffix , & model, blha_mode) call blha_configuration_append_processes (blha_cfg, n_in, & blha_flavor, amp_type) call blha_configuration_set (blha_cfg, BLHA_VERSION_2, & irreg = BLHA_IRREG_CDR, & alphas_power = asp, & alpha_power = ap, & ew_scheme = ew_scheme, & debug = blha_mode == BLHA_MODE_GOSAM) end subroutine blha_init_virtual subroutine blha_init_dglap (blha_cfg, blha_flavor, n_in, & ap, asp, ew_scheme, basename, model, blha_mode, suffix) type(blha_configuration_t), intent(inout) :: blha_cfg type(blha_flv_state_t), intent(in), dimension(:) :: blha_flavor integer, intent(in) :: n_in integer, intent(in) :: ap, asp integer, intent(in) :: ew_scheme type(string_t), intent(in) :: basename type(model_data_t), intent(in), target :: model integer, intent(in) :: blha_mode type(string_t), intent(in) :: suffix integer, dimension(:), allocatable :: amp_type integer :: i allocate (amp_type (size (blha_flavor) * 2)) do i = 1, size (blha_flavor) amp_type(2 * i - 1) = BLHA_AMP_TREE amp_type(2 * i) = BLHA_AMP_COLOR_C end do call blha_configuration_init (blha_cfg, basename // suffix , & model, blha_mode) call blha_configuration_append_processes (blha_cfg, n_in, & blha_flavor, amp_type) call blha_configuration_set (blha_cfg, BLHA_VERSION_2, & irreg = BLHA_IRREG_CDR, & alphas_power = asp, & alpha_power = ap, & ew_scheme = ew_scheme, & debug = blha_mode == BLHA_MODE_GOSAM) end subroutine blha_init_dglap subroutine blha_init_subtraction (blha_cfg, blha_flavor, n_in, & ap, asp, ew_scheme, basename, model, blha_mode, suffix) type(blha_configuration_t), intent(inout) :: blha_cfg type(blha_flv_state_t), intent(in), dimension(:) :: blha_flavor integer, intent(in) :: n_in integer, intent(in) :: ap, asp integer, intent(in) :: ew_scheme type(string_t), intent(in) :: basename type(model_data_t), intent(in), target :: model integer, intent(in) :: blha_mode type(string_t), intent(in) :: suffix integer, dimension(:), allocatable :: amp_type integer :: i allocate (amp_type (size (blha_flavor) * 3)) do i = 1, size (blha_flavor) amp_type(3 * i - 2) = BLHA_AMP_TREE amp_type(3 * i - 1) = BLHA_AMP_COLOR_C amp_type(3 * i) = BLHA_AMP_SPIN_C end do call blha_configuration_init (blha_cfg, basename // suffix , & model, blha_mode) call blha_configuration_append_processes (blha_cfg, n_in, & blha_flavor, amp_type) call blha_configuration_set (blha_cfg, BLHA_VERSION_2, & irreg = BLHA_IRREG_CDR, & alphas_power = asp, & alpha_power = ap, & ew_scheme = ew_scheme, & debug = blha_mode == BLHA_MODE_GOSAM) end subroutine blha_init_subtraction subroutine blha_init_real (blha_cfg, blha_flavor, n_in, & ap, asp, ew_scheme, basename, model, blha_mode, suffix) type(blha_configuration_t), intent(inout) :: blha_cfg type(blha_flv_state_t), intent(in), dimension(:) :: blha_flavor integer, intent(in) :: n_in integer, intent(in) :: ap, asp integer :: ap_ew, ap_qcd integer, intent(in) :: ew_scheme type(string_t), intent(in) :: basename type(model_data_t), intent(in), target :: model integer, intent(in) :: blha_mode type(string_t), intent(in) :: suffix integer, dimension(:), allocatable :: amp_type integer :: i allocate (amp_type (size (blha_flavor))) do i = 1, size (blha_flavor) amp_type(i) = BLHA_AMP_TREE end do select case (blha_cfg%correction_type) case (BLHA_CT_QCD) ap_ew = ap ap_qcd = asp + 1 case (BLHA_CT_EW) ap_ew = ap + 1 ap_qcd = asp end select call blha_configuration_init (blha_cfg, basename // suffix , & model, blha_mode) call blha_configuration_append_processes (blha_cfg, n_in, & blha_flavor, amp_type) call blha_configuration_set (blha_cfg, BLHA_VERSION_2, & irreg = BLHA_IRREG_CDR, & alphas_power = ap_qcd, & alpha_power = ap_ew, & ew_scheme = ew_scheme, & debug = blha_mode == BLHA_MODE_GOSAM) end subroutine blha_init_real @ %def blha_init_virtual blha_init_real @ %def blha_init_subtraction @ <>= public :: blha_get_additional_suffix <>= module function blha_get_additional_suffix (base_suffix) result (suffix) type(string_t) :: suffix type(string_t), intent(in) :: base_suffix end function blha_get_additional_suffix <>= module function blha_get_additional_suffix (base_suffix) result (suffix) type(string_t) :: suffix type(string_t), intent(in) :: base_suffix <> suffix = base_suffix <> end function blha_get_additional_suffix @ %def blha_master_extend_suffixes @ <>= integer :: n_size, rank <>= call MPI_Comm_rank (MPI_COMM_WORLD, rank) call MPI_Comm_size (MPI_COMM_WORLD, n_size) if (n_size > 1) then suffix = suffix // var_str ("_") // str (rank) end if @ <>= procedure :: write_olp => blha_master_write_olp <>= module subroutine blha_master_write_olp (master, basename) class(blha_master_t), intent(in) :: master type(string_t), intent(in) :: basename end subroutine blha_master_write_olp <>= module subroutine blha_master_write_olp (master, basename) class(blha_master_t), intent(in) :: master type(string_t), intent(in) :: basename integer :: unit type(string_t) :: filename integer :: i_file do i_file = 1, master%n_files filename = basename // master%suffix(i_file) // ".olp" unit = free_unit () open (unit, file = char (filename), status = 'replace', action = 'write') call blha_configuration_write & (master%blha_cfg(i_file), master%suffix(i_file), unit) close (unit) end do end subroutine blha_master_write_olp @ %def blha_master_write_olp @ <>= procedure :: final => blha_master_final <>= module subroutine blha_master_final (master) class(blha_master_t), intent(inout) :: master end subroutine blha_master_final <>= module subroutine blha_master_final (master) class(blha_master_t), intent(inout) :: master master%n_files = 0 deallocate (master%suffix) deallocate (master%blha_cfg) deallocate (master%i_file_to_nlo_index) end subroutine blha_master_final @ %def blha_master_final @ <>= public :: blha_configuration_init <>= module subroutine blha_configuration_init (cfg, name, model, mode) type(blha_configuration_t), intent(inout) :: cfg type(string_t), intent(in) :: name class(model_data_t), target, intent(in) :: model integer, intent(in), optional :: mode end subroutine blha_configuration_init <>= module subroutine blha_configuration_init (cfg, name, model, mode) type(blha_configuration_t), intent(inout) :: cfg type(string_t), intent(in) :: name class(model_data_t), target, intent(in) :: model integer, intent(in), optional :: mode if (.not. associated (cfg%model)) then cfg%name = name cfg%model => model end if if (present (mode)) cfg%mode = mode end subroutine blha_configuration_init @ %def blha_configuration_init @ Create an array of massive particle indices, to be used by the "MassiveParticle"-statement of the order file. <>= subroutine blha_configuration_get_massive_particles & (cfg, massive, i_massive) type(blha_configuration_t), intent(in) :: cfg logical, intent(out) :: massive integer, intent(out), dimension(:), allocatable :: i_massive integer, parameter :: max_particles = 10 integer, dimension(max_particles) :: i_massive_tmp integer, dimension(max_particles) :: checked type(blha_cfg_process_node_t), pointer :: current_process integer :: k integer :: n_massive n_massive = 0; k = 1 checked = 0 if (associated (cfg%processes)) then current_process => cfg%processes else call msg_fatal ("BLHA, massive particles: " // & "No processes allocated!") end if do call check_pdg_list (current_process%pdg_in%pdg) call check_pdg_list (current_process%pdg_out%pdg) if (k > max_particles) & call msg_fatal ("BLHA, massive particles: " // & "Max. number of particles exceeded!") if (associated (current_process%next)) then current_process => current_process%next else exit end if end do if (n_massive > 0) then allocate (i_massive (n_massive)) i_massive = i_massive_tmp (1:n_massive) massive = .true. else massive = .false. end if contains subroutine check_pdg_list (pdg_list) integer, dimension(:), intent(in) :: pdg_list integer :: i, i_pdg type(flavor_t) :: flv do i = 1, size (pdg_list) i_pdg = abs (pdg_list(i)) call flv%init (i_pdg, cfg%model) if (flv%get_mass () > 0._default) then !!! Avoid duplicates in output if (.not. any (checked == i_pdg)) then i_massive_tmp(k) = i_pdg checked(k) = i_pdg k = k + 1 n_massive = n_massive + 1 end if end if end do end subroutine check_pdg_list end subroutine blha_configuration_get_massive_particles @ %def blha_configuration_get_massive_particles @ <>= public :: blha_configuration_append_processes <>= module subroutine blha_configuration_append_processes (cfg, n_in, flavor, amp_type) type(blha_configuration_t), intent(inout) :: cfg integer, intent(in) :: n_in type(blha_flv_state_t), dimension(:), intent(in) :: flavor integer, dimension(:), intent(in), optional :: amp_type end subroutine blha_configuration_append_processes <>= module subroutine blha_configuration_append_processes (cfg, n_in, flavor, amp_type) type(blha_configuration_t), intent(inout) :: cfg integer, intent(in) :: n_in type(blha_flv_state_t), dimension(:), intent(in) :: flavor integer, dimension(:), intent(in), optional :: amp_type integer :: n_tot type(blha_cfg_process_node_t), pointer :: current_node integer :: i_process, i_flv integer, dimension(:), allocatable :: pdg_in, pdg_out integer, dimension(:), allocatable :: flavor_state integer :: proc_offset, n_proc_tot proc_offset = 0; n_proc_tot = 0 do i_flv = 1, size (flavor) n_proc_tot = n_proc_tot + flavor(i_flv)%flv_mult end do if (.not. associated (cfg%processes)) & allocate (cfg%processes) current_node => cfg%processes do i_flv = 1, size (flavor) n_tot = size (flavor(i_flv)%flavors) allocate (pdg_in (n_in), pdg_out (n_tot - n_in)) allocate (flavor_state (n_tot)) flavor_state = flavor(i_flv)%flavors do i_process = 1, flavor(i_flv)%flv_mult pdg_in = flavor_state (1 : n_in) pdg_out = flavor_state (n_in + 1 : ) if (cfg%polarized) then select case (cfg%mode) case (BLHA_MODE_OPENLOOPS) call allocate_and_init_pdg_and_helicities (current_node, & pdg_in, pdg_out, amp_type (proc_offset + i_process)) case (BLHA_MODE_GOSAM) !!! Nothing special for GoSam yet. This exception is already caught !!! in blha_master_setup_additional_features end select else call allocate_and_init_pdg (current_node, pdg_in, pdg_out, & amp_type (proc_offset + i_process)) end if if (proc_offset + i_process /= n_proc_tot) then allocate (current_node%next) current_node => current_node%next end if if (i_process == flavor(i_flv)%flv_mult) & proc_offset = proc_offset + flavor(i_flv)%flv_mult end do deallocate (pdg_in, pdg_out) deallocate (flavor_state) end do contains subroutine allocate_and_init_pdg (node, pdg_in, pdg_out, amp_type) type(blha_cfg_process_node_t), intent(inout), pointer :: node integer, intent(in), dimension(:), allocatable :: pdg_in, pdg_out integer, intent(in) :: amp_type allocate (node%pdg_in (size (pdg_in))) allocate (node%pdg_out (size (pdg_out))) node%pdg_in%pdg = pdg_in node%pdg_out%pdg = pdg_out node%amplitude_type = amp_type end subroutine allocate_and_init_pdg subroutine allocate_and_init_pdg_and_helicities (node, pdg_in, pdg_out, amp_type) type(blha_cfg_process_node_t), intent(inout), pointer :: node integer, intent(in), dimension(:), allocatable :: pdg_in, pdg_out integer, intent(in) :: amp_type integer :: h1, h2 if (size (pdg_in) == 2) then do h1 = -1, 1, 2 do h2 = -1, 1, 2 call allocate_and_init_pdg (current_node, pdg_in, pdg_out, amp_type) current_node%pdg_in(1)%polarized = .true. current_node%pdg_in(2)%polarized = .true. current_node%pdg_in(1)%hel = h1 current_node%pdg_in(2)%hel = h2 if (h1 + h2 /= 2) then !!! not end of loop allocate (current_node%next) current_node => current_node%next end if end do end do else do h1 = -1, 1, 2 call allocate_and_init_pdg (current_node, pdg_in, pdg_out, amp_type) current_node%pdg_in(1)%polarized = .true. current_node%pdg_in(1)%hel = h1 if (h1 /= 1) then !!! not end of loop allocate (current_node%next) current_node => current_node%next end if end do end if end subroutine allocate_and_init_pdg_and_helicities end subroutine blha_configuration_append_processes @ %def blha_configuration_append_processes @ Change parameter(s). <>= public :: blha_configuration_set <>= module subroutine blha_configuration_set (cfg, & version, irreg, massive_particle_scheme, & model_file, alphas_power, alpha_power, ew_scheme, width_scheme, & accuracy, debug) type(blha_configuration_t), intent(inout) :: cfg integer, optional, intent(in) :: version integer, optional, intent(in) :: irreg integer, optional, intent(in) :: massive_particle_scheme type(string_t), optional, intent(in) :: model_file integer, optional, intent(in) :: alphas_power, alpha_power integer, optional, intent(in) :: ew_scheme integer, optional, intent(in) :: width_scheme real(default), optional, intent(in) :: accuracy logical, optional, intent(in) :: debug end subroutine blha_configuration_set <>= module subroutine blha_configuration_set (cfg, & version, irreg, massive_particle_scheme, & model_file, alphas_power, alpha_power, ew_scheme, width_scheme, & accuracy, debug) type(blha_configuration_t), intent(inout) :: cfg integer, optional, intent(in) :: version integer, optional, intent(in) :: irreg integer, optional, intent(in) :: massive_particle_scheme type(string_t), optional, intent(in) :: model_file integer, optional, intent(in) :: alphas_power, alpha_power integer, optional, intent(in) :: ew_scheme integer, optional, intent(in) :: width_scheme real(default), optional, intent(in) :: accuracy logical, optional, intent(in) :: debug if (present (version)) & cfg%version = version if (present (irreg)) & cfg%irreg = irreg if (present (massive_particle_scheme)) & cfg%massive_particle_scheme = massive_particle_scheme if (present (model_file)) & cfg%model_file = model_file if (present (alphas_power)) & cfg%alphas_power = alphas_power if (present (alpha_power)) & cfg%alpha_power = alpha_power if (present (ew_scheme)) & cfg%ew_scheme = ew_scheme if (present (width_scheme)) & cfg%width_scheme = width_scheme if (present (accuracy)) & cfg%accuracy_target = accuracy if (present (debug)) & cfg%debug_unstable = debug cfg%dirty = .false. end subroutine blha_configuration_set @ %def blha_configuration_set @ <>= public :: blha_configuration_get_n_proc <>= module function blha_configuration_get_n_proc (cfg) result (n_proc) type(blha_configuration_t), intent(in) :: cfg integer :: n_proc end function blha_configuration_get_n_proc <>= module function blha_configuration_get_n_proc (cfg) result (n_proc) type(blha_configuration_t), intent(in) :: cfg integer :: n_proc n_proc = cfg%n_proc end function blha_configuration_get_n_proc @ %def blha_configuration_get_n_proc @ Write the BLHA file. Internal mode is intented for md5summing only. Special cases of external photons in \texttt{OpenLoops}: For electroweak corrections the particle ID (PID) of photons is a crucial input for the computation of matrix elements by \texttt{OpenLoops}. According to "arXiv: 1907.13071", section 3.2, external photons are classified by the following types: \begin{itemize} \item PID $= -2002$: off-shell photons, that undergo $\gamma\rightarrow f\bar{f}$ splittings at NLO EW, or initial state photons from QED PDFs \item PID $= 2002$: on-shell photons, that do not undergo $\gamma\rightarrow f\bar{f}$ splittings at NLO EW, or initial state photons for example at photon colliders \item PID $= 22$: unresolved photons, representing radiated photons at NLO EW, absent at LO \end{itemize} For the first two types scattering amplitudes for processes with external photons at NLO EW get renormalisation factors containing photon-coupling and wave function counterterms. Logarithmic mass singularities arising due to the renormalisation of off-shell external photon wave functions are cancelled by collinear singularities of photon PDF counterterms or analogous terms in virtual contributions originating from $\gamma\rightarrow f\bar{f}$ splittings of final state photons. The finite remainders of the renormalisation factors are thus dictated by the specific photon PID stated above. As consequence, we have to adjust the input PIDs written into the BLHA file which will be read by \texttt{OpenLoops}.\\ Concretely, for the case of electroweak corrections initial state photons associated with photon PDFs and final state photons (if existent at LO) are labeled as off-shell photons with PID "$-2002$". On-shell photons with PID "$2002$" are neglected for now since to include them for processes at NLO EW is non-trivial from the phenomenological point of view. Processes at NLO EW typically are studied at high energy scales for which photon-induced sub-processes in most cases can not be neglected. However, on-shell, e.~g. tagged, photons are defined at low energy scales and thus the process has to be described with external photon fields and couplings at two different scales. Another issue which has to be adressed if various photon PIDs are taken into account is that real and virtual amplitudes have to be computed at the same order in $\alpha$ at a specific scale for the subtraction scheme to be consistent. The complication comes by the fact that the EW coupling $\alpha$ of each external photon in the amplitudes will automatically be rescaled by \texttt{OpenLoops} corresponding to the specific photon type. Following eq. (3.30) of "arXiv: 1907.13071", by default the coupling of an on-shell photon will be changed to $\alpha(0)$ and that of an off-shell photon to $\alpha_{G_\mu}$ if not chosen already at a high scale, e.~g. $\alpha(M_Z)$. In order to not spoil the IR cancellation \texttt{OpenLoops} supplies to register unresolved photons with PID "22" describing a radiated photon at NLO EW for which the photon-coupling $\alpha$ is left unchanged at the value which is computed with the electroweak input scheme chosen by the user. This is adopted here by labeling each emitted photon as unresolved with PID "22" if no photons are present at LO.\\ For EW corrections the freedom to choose an electroweak input scheme is restricted, however, since the number of external photons present at LO is not conserved for the corresponding real flavor structures due to possible $\gamma \rightarrow f\bar{f}$ splittings. This forbids to choose $\alpha=\alpha(0)$ since otherwise the order in $\alpha(0)$ is not conserved in the real amplitudes corresponding to the factorizing Born process. Consequently, for FKS the NLO components are not of the same order in $\alpha(0)$. The option \texttt{\$blha\_ew\_scheme = "alpha\_0"} is thus refused for the case if EW corrections are activated and photons are present at LO. <>= public :: blha_configuration_write <>= module subroutine blha_configuration_write (cfg, suffix, unit, internal, no_version) type(blha_configuration_t), intent(in) :: cfg integer, intent(in), optional :: unit logical, intent(in), optional :: internal, no_version type(string_t), intent(in) :: suffix end subroutine blha_configuration_write <>= module subroutine blha_configuration_write (cfg, suffix, unit, internal, no_version) type(blha_configuration_t), intent(in) :: cfg integer, intent(in), optional :: unit logical, intent(in), optional :: internal, no_version type(string_t), intent(in) :: suffix integer, dimension(:), allocatable :: pdg_flv integer :: u - logical :: full + logical :: full, nlo3 type(string_t) :: buf type(blha_cfg_process_node_t), pointer :: node integer :: i character(3) :: pdg_char character(5) :: pdg_char_extra character(4) :: hel_char character(6) :: suffix_char character(len=25), parameter :: pad = "" logical :: write_process, no_v no_v = .false. ; if (present (no_version)) no_v = no_version u = given_output_unit (unit); if (u < 0) return full = .true.; if (present (internal)) full = .not. internal if (full .and. cfg%dirty) call msg_bug ( & "BUG: attempted to write out a dirty BLHA configuration") if (full) then if (no_v) then write (u, "(A)") "# BLHA order written by WHIZARD [version]" else write (u, "(A)") "# BLHA order written by WHIZARD <>" end if write (u, "(A)") end if select case (cfg%mode) case (BLHA_MODE_GOSAM); buf = "GoSam" case (BLHA_MODE_OPENLOOPS); buf = "OpenLoops" case default; buf = "vanilla" end select write (u, "(A)") "# BLHA interface mode: " // char (buf) write (u, "(A)") "# process: " // char (cfg%name) write (u, "(A)") "# model: " // char (cfg%model%get_name ()) select case (cfg%version) case (1); buf = "BLHA1" case (2); buf = "BLHA2" end select write (u, '(A25,A)') "InterfaceVersion " // pad, char (buf) select case (cfg%correction_type) case (BLHA_CT_QCD); buf = "QCD" case (BLHA_CT_EW); buf = "EW" case default; buf = cfg%correction_type_other end select write (u,'(A25,A)') "CorrectionType" // pad, char (buf) select case (cfg%mode) case (BLHA_MODE_OPENLOOPS) buf = cfg%name // '.olc' write (u, '(A25,A)') "Extra AnswerFile" // pad, char (buf) end select select case (cfg%irreg) case (BLHA_IRREG_CDR); buf = "CDR" case (BLHA_IRREG_DRED); buf = "DRED" case (BLHA_IRREG_THV); buf = "tHV" case (BLHA_IRREG_MREG); buf = "MassReg" case default; buf = cfg%irreg_other end select write (u,'(A25,A)') "IRregularisation" // pad, char (buf) select case (cfg%massive_particle_scheme) case (BLHA_MPS_ONSHELL); buf = "OnShell" case default; buf = cfg%massive_particle_scheme_other end select if (cfg%mode == BLHA_MODE_GOSAM) & write (u,'(A25,A)') "MassiveParticleScheme" // pad, char (buf) select case (cfg%version) case (1) if (cfg%alphas_power >= 0) write (u,'(A25,A)') & "AlphasPower" // pad, int2char (cfg%alphas_power) if (cfg%alpha_power >= 0) write (u,'(A25,A)') & "AlphaPower " // pad, int2char (cfg%alpha_power) case (2) if (cfg%alphas_power >= 0) write (u,'(A25,A)') & "CouplingPower QCD " // pad, int2char (cfg%alphas_power) if (cfg%alpha_power >= 0) write (u, '(A25,A)') & "CouplingPower QED " // pad, int2char (cfg%alpha_power) end select select case (cfg%mode) case (BLHA_MODE_GOSAM) select case (cfg%ew_scheme) case (BLHA_EW_GF, BLHA_EW_INTERNAL); buf = "alphaGF" case (BLHA_EW_MZ); buf = "alphaMZ" case (BLHA_EW_MSBAR); buf = "alphaMSbar" case (BLHA_EW_0); buf = "alpha0" case (BLHA_EW_RUN); buf = "alphaRUN" end select write (u, '(A25, A)') "EWScheme " // pad, char (buf) case (BLHA_MODE_OPENLOOPS) select case (cfg%ew_scheme) case (BLHA_EW_0); buf = "alpha0" case (BLHA_EW_GF); buf = "Gmu" case (BLHA_EW_MZ, BLHA_EW_INTERNAL); buf = "alphaMZ" case default call msg_fatal ("OpenLoops input: Only supported EW schemes & & are 'alpha0', 'Gmu', and 'alphaMZ'") end select write (u, '(A25, A)') "ewscheme " // pad, char (buf) end select select case (cfg%mode) case (BLHA_MODE_GOSAM) write (u, '(A25)', advance='no') "MassiveParticles " // pad do i = 1, size (OLP_MASSIVE_PARTICLES) if (OLP_MASSIVE_PARTICLES(i) > 0) & write (u, '(I2,1X)', advance='no') OLP_MASSIVE_PARTICLES(i) end do write (u,*) case (BLHA_MODE_OPENLOOPS) if (cfg%openloops_use_cms) then write (u, '(A25,I1)') "extra use_cms " // pad, 1 else write (u, '(A25,I1)') "extra use_cms " // pad, 0 end if write (u, '(A25,I1)') "extra me_cache " // pad, 0 !!! Turn off calculation of 1/eps & 1/eps^2 poles in one-loop calculation !!! Not needed in FKS (or any numerical NLO subtraction scheme) write (u, '(A25,I1)') "extra IR_on " // pad, 0 if (cfg%openloops_phs_tolerance > 0) then write (u, '(A25,A4,I0)') "extra psp_tolerance " // pad, "10e-", & cfg%openloops_phs_tolerance end if call check_extra_cmd (cfg%openloops_extra_cmd) write (u, '(A)') char (cfg%openloops_extra_cmd) if (cfg%openloops_stability_log > 0) & write (u, '(A25,I1)') "extra stability_log " // pad, & cfg%openloops_stability_log end select if (full) then write (u, "(A)") write (u, "(A)") "# Process definitions" write (u, "(A)") end if if (cfg%debug_unstable) & write (u, '(A25,A)') "DebugUnstable " // pad, "True" write (u, *) node => cfg%processes do while (associated (node)) write_process = .true. allocate (pdg_flv (size (node%pdg_in) + size (node%pdg_out))) do i = 1, size (node%pdg_in) pdg_flv (i) = node%pdg_in(i)%pdg end do do i = 1, size (node%pdg_out) pdg_flv (i + size (node%pdg_in)) = node%pdg_out(i)%pdg end do suffix_char = char (suffix) if (cfg%correction_type == BLHA_CT_EW .and. cfg%alphas_power > 0) then if ((suffix_char (1:5) == "_BORN" .and. .not. query_coupling_powers & (pdg_flv, cfg%alpha_power, cfg%alphas_power)) .or. & ((suffix_char (1:4) == "_SUB" .or. suffix_char (1:5) == "_LOOP" .or. & suffix_char (1:6) == "_DGLAP") .and. (.not. (query_coupling_powers & (pdg_flv, cfg%alpha_power, cfg%alphas_power) .or. query_coupling_powers & (pdg_flv, cfg%alpha_power + 1, cfg%alphas_power - 1)) .or. & all (is_gluon (pdg_flv))))) then deallocate (pdg_flv) node => node%next cycle end if end if select case (node%amplitude_type) case (BLHA_AMP_LOOP); buf = "Loop" case (BLHA_AMP_COLOR_C); buf = "ccTree" case (BLHA_AMP_SPIN_C) if (cfg%mode == BLHA_MODE_OPENLOOPS) then buf = "sctree_polvect" else buf = "scTree" end if case (BLHA_AMP_TREE); buf = "Tree" case (BLHA_AMP_LOOPINDUCED); buf = "LoopInduced" end select + nlo3 = qcd_ew_interferences (pdg_flv) .and. & + (node%amplitude_type == BLHA_AMP_COLOR_C .or. & + node%amplitude_type == BLHA_AMP_SPIN_C) .and. & + .not. query_coupling_powers (pdg_flv, cfg%alpha_power+2, cfg%alphas_power-2) if (write_process) then write (u, '(A25, A)') "AmplitudeType " // pad, char (buf) buf = "" if (cfg%correction_type == BLHA_CT_EW .and. cfg%alphas_power > 0 .and. & (suffix_char (1:4) == "_SUB" .or. suffix_char (1:5) == "_LOOP" & .or. suffix_char (1:6) == "_DGLAP")) then - if (query_coupling_powers (pdg_flv, cfg%alpha_power, cfg%alphas_power)) then + if (query_coupling_powers (pdg_flv, cfg%alpha_power, cfg%alphas_power) & + .and. .not. nlo3) then write (u,'(A25,A)') "CorrectionType" // pad, "EW" select case (cfg%version) case (1) if (cfg%alphas_power >= 0) write (u,'(A25,A)') & "AlphasPower" // pad, int2char (cfg%alphas_power) if (cfg%alpha_power >= 0) write (u,'(A25,A)') & "AlphaPower " // pad, int2char (cfg%alpha_power) case (2) if (cfg%alphas_power >= 0) write (u,'(A25,A)') & "CouplingPower QCD " // pad, int2char (cfg%alphas_power) if (cfg%alpha_power >= 0) write (u, '(A25,A)') & "CouplingPower QED " // pad, int2char (cfg%alpha_power) end select else if (query_coupling_powers & (pdg_flv, cfg%alpha_power + 1, cfg%alphas_power - 1)) then write (u,'(A25,A)') "CorrectionType" // pad, "QCD" select case (cfg%version) case (1) if (cfg%alphas_power >= 0) write (u,'(A25,A)') & "AlphasPower" // pad, int2char (cfg%alphas_power - 1) if (cfg%alpha_power >= 0) write (u,'(A25,A)') & "AlphaPower " // pad, int2char (cfg%alpha_power + 1) case (2) if (cfg%alphas_power >= 0) write (u,'(A25,A)') & "CouplingPower QCD " // pad, int2char (cfg%alphas_power - 1) if (cfg%alpha_power >= 0) write (u, '(A25,A)') & "CouplingPower QED " // pad, int2char (cfg%alpha_power + 1) end select end if end if do i = 1, size (node%pdg_in) if (cfg%correction_type == BLHA_CT_EW .and. node%pdg_in(i)%pdg == PHOTON & .and. cfg%n_off_photons_is > 0) then if (cfg%ew_scheme == BLHA_EW_0) then call msg_fatal ("ew_scheme: 'alpha_0' or 'alpha_thompson' " & // "in combination", [ var_str ("with off-shell external photons " & // "is not consistent with FKS.")]) end if write (pdg_char_extra, '(I5)') PHOTON_OFFSHELL buf = (buf // pdg_char_extra) // " " else call node%pdg_in(i)%write_pdg (pdg_char) if (node%pdg_in(i)%polarized) then call node%pdg_in(i)%write_helicity (hel_char) buf = (buf // pdg_char // hel_char) // " " else buf = (buf // pdg_char) // " " end if end if end do buf = buf // "-> " do i = 1, size (node%pdg_out) if (cfg%correction_type == BLHA_CT_EW .and. node%pdg_out(i)%pdg == PHOTON & .and. cfg%n_off_photons_fs > 0) then if (cfg%ew_scheme == BLHA_EW_0) then call msg_fatal ("ew_scheme: 'alpha_0' or 'alpha_thompson' " & // "in combination with off-shell external photons " & // "is not consistent with FKS. Try a different one.") end if write (pdg_char_extra, '(I5)') PHOTON_OFFSHELL buf = (buf // pdg_char_extra) // " " else call node%pdg_out(i)%write_pdg (pdg_char) buf = (buf // pdg_char) // " " end if end do write (u, "(A)") char (trim (buf)) write (u, *) end if deallocate (pdg_flv) node => node%next end do end subroutine blha_configuration_write @ %def blha_configuration_write @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Module definition} These modules implement the communication with one loop matrix element providers according to the Binoth LesHouches Accord Interface. The actual matrix element(s) are loaded as a dynamic library. This module defines the common OLP-interfaces defined through the Binoth Les-Houches accord. <<[[blha_olp_interfaces.f90]]>>= <> module blha_olp_interfaces use, intrinsic :: iso_c_binding !NODEP! use, intrinsic :: iso_fortran_env use kinds <> use os_interface use lorentz use interactions use model_data use prclib_interfaces use process_libraries use prc_core_def use prc_core use prc_external use blha_config <> <> <> <> <> interface <> end interface end module blha_olp_interfaces @ %def module blha_olp_interfaces @ <<[[blha_olp_interfaces_sub.f90]]>>= <> submodule (blha_olp_interfaces) blha_olp_interfaces_s <> use constants use numeric_utils, only: vanishes use numeric_utils, only: extend_integer_array, crop_integer_array use io_units use string_utils use physics_defs use diagnostics use sm_qcd use flavors use pdg_arrays, only: is_gluon, is_quark, qcd_ew_interferences implicit none <> contains <> end submodule blha_olp_interfaces_s @ %def blha_olp_interfaces_s @ <>= public :: blha_template_t <>= type :: blha_template_t integer :: I_BORN = 0 integer :: I_REAL = 1 integer :: I_LOOP = 2 integer :: I_SUB = 3 integer :: I_DGLAP = 4 logical, dimension(0:4) :: compute_component logical :: include_polarizations = .false. logical :: switch_off_muon_yukawas = .false. logical :: use_internal_color_correlations = .true. real(default) :: external_top_yukawa = -1._default integer :: ew_scheme integer :: loop_method = BLHA_MODE_GENERIC contains <> end type blha_template_t @ %def blha_template_t @ <>= procedure :: write => blha_template_write <>= module subroutine blha_template_write (blha_template, unit) class(blha_template_t), intent(in) :: blha_template integer, intent(in), optional :: unit end subroutine blha_template_write <>= module subroutine blha_template_write (blha_template, unit) class(blha_template_t), intent(in) :: blha_template integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u,"(A,4(L1))") "Compute components: ", & blha_template%compute_component write (u,"(A,L1)") "Include polarizations: ", & blha_template%include_polarizations write (u,"(A,L1)") "Switch off muon yukawas: ", & blha_template%switch_off_muon_yukawas write (u,"(A,L1)") "Use internal color correlations: ", & blha_template%use_internal_color_correlations end subroutine blha_template_write @ %def blha_template_write @ Compute the total number of used helicity states for the given particle PDG codes, given a model. Applies only if polarization is supported. This yields the [[n_hel]] value as required below. <>= procedure :: get_n_hel => blha_template_get_n_hel <>= module function blha_template_get_n_hel (blha_template, pdg, model) result (n_hel) class(blha_template_t), intent(in) :: blha_template integer, dimension(:), intent(in) :: pdg class(model_data_t), intent(in), target :: model integer :: n_hel end function blha_template_get_n_hel <>= module function blha_template_get_n_hel (blha_template, pdg, model) result (n_hel) class(blha_template_t), intent(in) :: blha_template integer, dimension(:), intent(in) :: pdg class(model_data_t), intent(in), target :: model integer :: n_hel type(flavor_t) :: flv integer :: f n_hel = 1 if (blha_template%include_polarizations) then do f = 1, size (pdg) call flv%init (pdg(f), model) n_hel = n_hel * flv%get_multiplicity () end do end if end function blha_template_get_n_hel @ %def blha_template_get_n_hel @ <>= integer, parameter :: I_ALPHA_0 = 1 integer, parameter :: I_GF = 2 integer, parameter :: I_ALPHA_MZ = 3 integer, parameter :: I_ALPHA_INTERNAL = 4 integer, parameter :: I_SW2 = 5 <>= public :: prc_blha_t <>= type, abstract, extends (prc_external_t) :: prc_blha_t integer :: n_particles integer :: n_hel integer :: n_proc integer, dimension(:, :), allocatable :: i_tree, i_spin_c, i_color_c integer, dimension(:, :), allocatable :: i_virt integer, dimension(:, :), allocatable :: i_hel logical, dimension(5) :: ew_parameter_mask integer :: sqme_tree_pos contains <> end type prc_blha_t @ %def prc_blha_t @ Obviously, this process-core type uses the BLHA interface. <>= procedure, nopass :: uses_blha => prc_blha_uses_blha <>= module function prc_blha_uses_blha () result (flag) logical :: flag end function prc_blha_uses_blha <>= module function prc_blha_uses_blha () result (flag) logical :: flag flag = .true. end function prc_blha_uses_blha @ %def prc_blha_uses_blha @ <>= public :: blha_driver_t <>= type, abstract, extends (prc_external_driver_t) :: blha_driver_t type(string_t) :: contract_file type(string_t) :: nlo_suffix logical :: include_polarizations = .false. logical :: switch_off_muon_yukawas = .false. real(default) :: external_top_yukawa = -1.0 procedure(olp_start),nopass, pointer :: & blha_olp_start => null () procedure(olp_eval), nopass, pointer :: & blha_olp_eval => null() procedure(olp_info), nopass, pointer :: & blha_olp_info => null () procedure(olp_set_parameter), nopass, pointer :: & blha_olp_set_parameter => null () procedure(olp_eval2), nopass, pointer :: & blha_olp_eval2 => null () procedure(olp_option), nopass, pointer :: & blha_olp_option => null () procedure(olp_polvec), nopass, pointer :: & blha_olp_polvec => null () procedure(olp_finalize), nopass, pointer :: & blha_olp_finalize => null () procedure(olp_print_parameter), nopass, pointer :: & blha_olp_print_parameter => null () contains <> end type blha_driver_t @ @ %def blha_driver_t <>= public :: prc_blha_writer_t <>= type, abstract, extends (prc_external_writer_t) :: prc_blha_writer_t type(blha_configuration_t) :: blha_cfg contains <> end type prc_blha_writer_t @ @ %def prc_blha_writer_t <>= public :: blha_def_t <>= type, abstract, extends (prc_external_def_t) :: blha_def_t type(string_t) :: suffix contains <> end type blha_def_t @ %def blha_def_t @ <>= public :: blha_state_t <>= type, abstract, extends (prc_external_state_t) :: blha_state_t contains <> end type blha_state_t @ %def blha_state_t @ <>= procedure :: reset_new_kinematics => blha_state_reset_new_kinematics <>= module subroutine blha_state_reset_new_kinematics (object) class(blha_state_t), intent(inout) :: object end subroutine blha_state_reset_new_kinematics <>= module subroutine blha_state_reset_new_kinematics (object) class(blha_state_t), intent(inout) :: object object%new_kinematics = .true. end subroutine blha_state_reset_new_kinematics @ %def blha_state_reset_new_kinematics @ <>= integer, parameter, public :: OLP_PARAMETER_LIMIT = 10 integer, parameter, public :: OLP_MOMENTUM_LIMIT = 50 integer, parameter, public :: OLP_RESULTS_LIMIT = 60 <>= public :: olp_start <>= interface subroutine olp_start (contract_file_name, ierr) bind (C,name = "OLP_Start") import character(kind = c_char, len = 1), intent(in) :: contract_file_name integer(kind = c_int), intent(out) :: ierr end subroutine olp_start end interface @ %def olp_start_interface @ <>= public :: olp_eval <>= interface subroutine olp_eval (label, momenta, mu, parameters, res) & bind (C, name = "OLP_EvalSubProcess") import integer(kind = c_int), value, intent(in) :: label real(kind = c_double), value, intent(in) :: mu real(kind = c_double), dimension(OLP_MOMENTUM_LIMIT), intent(in) :: & momenta real(kind = c_double), dimension(OLP_PARAMETER_LIMIT), intent(in) :: & parameters real(kind = c_double), dimension(OLP_RESULTS_LIMIT), intent(out) :: res end subroutine olp_eval end interface @ %def olp_eval interface @ <>= public :: olp_info <>= interface subroutine olp_info (olp_file, olp_version, message) bind(C) import character(kind = c_char), intent(inout), dimension(15) :: olp_file character(kind = c_char), intent(inout), dimension(15) :: olp_version character(kind = c_char), intent(inout), dimension(255) :: message end subroutine olp_info end interface @ %def olp_info interface @ <>= public :: olp_set_parameter <>= interface subroutine olp_set_parameter & (variable_name, real_part, complex_part, success) bind(C) import character(kind = c_char,len = 1), intent(in) :: variable_name real(kind = c_double), intent(in) :: real_part, complex_part integer(kind = c_int), intent(out) :: success end subroutine olp_set_parameter end interface @ %def olp_set_parameter_interface @ <>= public :: olp_eval2 <>= interface subroutine olp_eval2 (label, momenta, mu, res, acc) bind(C) import integer(kind = c_int), intent(in) :: label real(kind = c_double), intent(in) :: mu real(kind = c_double), dimension(OLP_MOMENTUM_LIMIT), intent(in) :: momenta real(kind = c_double), dimension(OLP_RESULTS_LIMIT), intent(out) :: res real(kind = c_double), intent(out) :: acc end subroutine olp_eval2 end interface @ %def olp_eval2 interface @ <>= public :: olp_option <>= interface subroutine olp_option (line, stat) bind(C) import character(kind = c_char, len=1), intent(in) :: line integer(kind = c_int), intent(out) :: stat end subroutine end interface @ %def olp_option_interface @ <>= public :: olp_polvec <>= interface subroutine olp_polvec (p, q, eps) bind(C) import real(kind = c_double), dimension(0:3), intent(in) :: p, q real(kind = c_double), dimension(0:7), intent(out) :: eps end subroutine end interface @ %def olp_polvec_interface @ <>= public :: olp_finalize <>= interface subroutine olp_finalize () bind(C) import end subroutine olp_finalize end interface @ %def olp_finalize_interface @ <>= public :: olp_print_parameter <>= interface subroutine olp_print_parameter (filename) bind(C) import character(kind = c_char, len = 1), intent(in) :: filename end subroutine olp_print_parameter end interface @ %def olp_print_parameter_interface @ <>= public :: blha_result_array_size <>= pure module function blha_result_array_size & (n_part, amp_type) result (rsize) integer, intent(in) :: n_part, amp_type integer :: rsize end function blha_result_array_size <>= pure module function blha_result_array_size & (n_part, amp_type) result (rsize) integer, intent(in) :: n_part, amp_type integer :: rsize select case (amp_type) case (BLHA_AMP_TREE) rsize = 1 case (BLHA_AMP_LOOP) rsize = 4 case (BLHA_AMP_COLOR_C) rsize = n_part * (n_part - 1) / 2 case (BLHA_AMP_SPIN_C) rsize = 2 * n_part**2 case default rsize = 0 end select end function blha_result_array_size @ %def blha_result_array_size @ <>= procedure :: create_momentum_array => prc_blha_create_momentum_array <>= module function prc_blha_create_momentum_array (object, p) result (mom) class(prc_blha_t), intent(in) :: object type(vector4_t), intent(in), dimension(:) :: p real(double), dimension(5*object%n_particles) :: mom end function prc_blha_create_momentum_array <>= module function prc_blha_create_momentum_array (object, p) result (mom) class(prc_blha_t), intent(in) :: object type(vector4_t), intent(in), dimension(:) :: p real(double), dimension(5*object%n_particles) :: mom integer :: n, i, k n = size (p) if (n > 10) call msg_fatal ("Number of external particles exceeds" & // "size of BLHA-internal momentum array") mom = zero k = 1 do i = 1, n mom(k : k + 3) = vector4_get_components (p(i)) mom(k + 4) = invariant_mass (p(i)) k = k + 5 end do end function prc_blha_create_momentum_array @ %def prc_blha_create_momentum_array @ <>= procedure :: init => blha_template_init <>= module subroutine blha_template_init (template, requires_polarizations, & switch_off_muon_yukawas, external_top_yukawa, ew_scheme) class(blha_template_t), intent(inout) :: template logical, intent(in) :: requires_polarizations, switch_off_muon_yukawas real(default), intent(in) :: external_top_yukawa type(string_t), intent(in) :: ew_scheme end subroutine blha_template_init <>= module subroutine blha_template_init (template, requires_polarizations, & switch_off_muon_yukawas, external_top_yukawa, ew_scheme) class(blha_template_t), intent(inout) :: template logical, intent(in) :: requires_polarizations, switch_off_muon_yukawas real(default), intent(in) :: external_top_yukawa type(string_t), intent(in) :: ew_scheme template%compute_component = .false. template%include_polarizations = requires_polarizations template%switch_off_muon_yukawas = switch_off_muon_yukawas template%external_top_yukawa = external_top_yukawa template%ew_scheme = ew_scheme_string_to_int (ew_scheme) end subroutine blha_template_init @ %def blha_template_init @ <>= procedure :: set_born => blha_template_set_born procedure :: set_real_trees => blha_template_set_real_trees procedure :: set_loop => blha_template_set_loop procedure :: set_subtraction => blha_template_set_subtraction procedure :: set_dglap => blha_template_set_dglap <>= module subroutine blha_template_set_born (template) class(blha_template_t), intent(inout) :: template end subroutine blha_template_set_born module subroutine blha_template_set_real_trees (template) class(blha_template_t), intent(inout) :: template end subroutine blha_template_set_real_trees module subroutine blha_template_set_loop (template) class(blha_template_t), intent(inout) :: template end subroutine blha_template_set_loop module subroutine blha_template_set_subtraction (template) class(blha_template_t), intent(inout) :: template end subroutine blha_template_set_subtraction module subroutine blha_template_set_dglap (template) class(blha_template_t), intent(inout) :: template end subroutine blha_template_set_dglap <>= module subroutine blha_template_set_born (template) class(blha_template_t), intent(inout) :: template template%compute_component (template%I_BORN) = .true. end subroutine blha_template_set_born module subroutine blha_template_set_real_trees (template) class(blha_template_t), intent(inout) :: template template%compute_component (template%I_REAL) = .true. end subroutine blha_template_set_real_trees module subroutine blha_template_set_loop (template) class(blha_template_t), intent(inout) :: template template%compute_component(template%I_LOOP) = .true. end subroutine blha_template_set_loop module subroutine blha_template_set_subtraction (template) class(blha_template_t), intent(inout) :: template template%compute_component (template%I_SUB) = .true. end subroutine blha_template_set_subtraction module subroutine blha_template_set_dglap (template) class(blha_template_t), intent(inout) :: template template%compute_component (template%I_DGLAP) = .true. end subroutine blha_template_set_dglap @ %def blha_template_set_components @ <>= procedure :: set_internal_color_correlations & => blha_template_set_internal_color_correlations <>= module subroutine blha_template_set_internal_color_correlations (template) class(blha_template_t), intent(inout) :: template end subroutine blha_template_set_internal_color_correlations <>= module subroutine blha_template_set_internal_color_correlations (template) class(blha_template_t), intent(inout) :: template template%use_internal_color_correlations = .true. end subroutine blha_template_set_internal_color_correlations @ %def blha_template_set_internal_color_correlations @ <>= procedure :: get_internal_color_correlations & => blha_template_get_internal_color_correlations <>= pure module function blha_template_get_internal_color_correlations & (template) result (val) logical :: val class(blha_template_t), intent(in) :: template end function blha_template_get_internal_color_correlations <>= pure module function blha_template_get_internal_color_correlations & (template) result (val) logical :: val class(blha_template_t), intent(in) :: template val = template%use_internal_color_correlations end function blha_template_get_internal_color_correlations @ %def blha_template_use_internal_color_correlations @ <>= procedure :: compute_born => blha_template_compute_born procedure :: compute_real_trees => blha_template_compute_real_trees procedure :: compute_loop => blha_template_compute_loop procedure :: compute_subtraction => blha_template_compute_subtraction procedure :: compute_dglap => blha_template_compute_dglap <>= pure module function blha_template_compute_born (template) result (val) class(blha_template_t), intent(in) :: template logical :: val end function blha_template_compute_born pure module function blha_template_compute_real_trees (template) result (val) class(blha_template_t), intent(in) :: template logical :: val end function blha_template_compute_real_trees pure module function blha_template_compute_loop (template) result (val) class(blha_template_t), intent(in) :: template logical :: val end function blha_template_compute_loop pure module function blha_template_compute_subtraction (template) result (val) class(blha_template_t), intent(in) :: template logical :: val end function blha_template_compute_subtraction pure module function blha_template_compute_dglap (template) result (val) class(blha_template_t), intent(in) :: template logical :: val end function blha_template_compute_dglap <>= pure module function blha_template_compute_born (template) result (val) class(blha_template_t), intent(in) :: template logical :: val val = template%compute_component (template%I_BORN) end function blha_template_compute_born pure module function blha_template_compute_real_trees (template) result (val) class(blha_template_t), intent(in) :: template logical :: val val = template%compute_component (template%I_REAL) end function blha_template_compute_real_trees pure module function blha_template_compute_loop (template) result (val) class(blha_template_t), intent(in) :: template logical :: val val = template%compute_component (template%I_LOOP) end function blha_template_compute_loop pure module function blha_template_compute_subtraction (template) result (val) class(blha_template_t), intent(in) :: template logical :: val val = template%compute_component (template%I_SUB) end function blha_template_compute_subtraction pure module function blha_template_compute_dglap (template) result (val) class(blha_template_t), intent(in) :: template logical :: val val = template%compute_component (template%I_DGLAP) end function blha_template_compute_dglap @ %def blha_template_compute @ <>= procedure :: set_loop_method => blha_template_set_loop_method <>= module subroutine blha_template_set_loop_method (template, master) class(blha_template_t), intent(inout) :: template class(blha_master_t), intent(in) :: master end subroutine blha_template_set_loop_method <>= module subroutine blha_template_set_loop_method (template, master) class(blha_template_t), intent(inout) :: template class(blha_master_t), intent(in) :: master template%loop_method = master%blha_mode(1) end subroutine blha_template_set_loop_method @ %def blha_template_set_loop_method @ <>= procedure :: check => blha_template_check <>= module function blha_template_check (template) result (val) class(blha_template_t), intent(in) :: template logical :: val end function blha_template_check <>= module function blha_template_check (template) result (val) class(blha_template_t), intent(in) :: template logical :: val val = count (template%compute_component) == 1 end function blha_template_check @ %def blha_template_check @ <>= procedure :: reset => blha_template_reset <>= module subroutine blha_template_reset (template) class(blha_template_t), intent(inout) :: template end subroutine blha_template_reset <>= module subroutine blha_template_reset (template) class(blha_template_t), intent(inout) :: template template%compute_component = .false. end subroutine blha_template_reset @ %def blha_template_reset @ <>= procedure :: write => prc_blha_writer_write <>= module subroutine prc_blha_writer_write (writer, unit) class(prc_blha_writer_t), intent(in) :: writer integer, intent(in) :: unit end subroutine prc_blha_writer_write <>= module subroutine prc_blha_writer_write (writer, unit) class(prc_blha_writer_t), intent(in) :: writer integer, intent(in) :: unit write (unit, "(1x,A)") char (writer%get_process_string ()) end subroutine prc_blha_writer_write @ @ %def prc_blha_writer_write <>= procedure :: get_process_string => prc_blha_writer_get_process_string <>= module function prc_blha_writer_get_process_string (writer) result (s_proc) class(prc_blha_writer_t), intent(in) :: writer type(string_t) :: s_proc end function prc_blha_writer_get_process_string <>= module function prc_blha_writer_get_process_string (writer) result (s_proc) class(prc_blha_writer_t), intent(in) :: writer type(string_t) :: s_proc s_proc = var_str ("") end function prc_blha_writer_get_process_string @ %def prc_blha_writer_get_process_string @ <>= procedure :: get_n_proc => prc_blha_writer_get_n_proc <>= module function prc_blha_writer_get_n_proc (writer) result (n_proc) class(prc_blha_writer_t), intent(in) :: writer integer :: n_proc end function prc_blha_writer_get_n_proc <>= module function prc_blha_writer_get_n_proc (writer) result (n_proc) class(prc_blha_writer_t), intent(in) :: writer integer :: n_proc n_proc = blha_configuration_get_n_proc (writer%blha_cfg) end function prc_blha_writer_get_n_proc @ %def prc_blha_writer_get_n_proc @ <>= procedure(blha_driver_set_GF), deferred :: & set_GF <>= abstract interface subroutine blha_driver_set_GF (driver, GF) import class(blha_driver_t), intent(inout) :: driver real(default), intent(in) :: GF end subroutine blha_driver_set_GF end interface @ %def blha_driver_set_GF @ <>= procedure(blha_driver_set_alpha_s), deferred :: & set_alpha_s <>= abstract interface subroutine blha_driver_set_alpha_s (driver, alpha_s) import class(blha_driver_t), intent(in) :: driver real(default), intent(in) :: alpha_s end subroutine blha_driver_set_alpha_s end interface @ %def set_alpha_s interface @ <>= procedure(blha_driver_set_weinberg_angle), deferred :: & set_weinberg_angle <>= abstract interface subroutine blha_driver_set_weinberg_angle (driver, sw2) import class(blha_driver_t), intent(inout) :: driver real(default), intent(in) :: sw2 end subroutine blha_driver_set_weinberg_angle end interface @ %def blha_driver_set_weinberg_angle @ <>= procedure(blha_driver_set_alpha_qed), deferred :: set_alpha_qed <>= abstract interface subroutine blha_driver_set_alpha_qed (driver, alpha) import class(blha_driver_t), intent(inout) :: driver real(default), intent(in) :: alpha end subroutine blha_driver_set_alpha_qed end interface @ %def blha_driver_set_alpha_qed @ <>= procedure(blha_driver_print_alpha_s), deferred :: & print_alpha_s <>= abstract interface subroutine blha_driver_print_alpha_s (object) import class(blha_driver_t), intent(in) :: object end subroutine blha_driver_print_alpha_s end interface @ %def print_alpha_s interface @ <>= public :: parameter_error_message <>= module subroutine parameter_error_message (par, subr) type(string_t), intent(in) :: par, subr end subroutine parameter_error_message <>= module subroutine parameter_error_message (par, subr) type(string_t), intent(in) :: par, subr type(string_t) :: message message = "Setting of parameter " // par & // "failed in " // subr // "!" call msg_fatal (char (message)) end subroutine parameter_error_message @ %def parameter_error_message @ <>= public :: ew_parameter_error_message <>= module subroutine ew_parameter_error_message (par) type(string_t), intent(in) :: par end subroutine ew_parameter_error_message <>= module subroutine ew_parameter_error_message (par) type(string_t), intent(in) :: par type(string_t) :: message message = "Setting of parameter " // par & // "failed. This happens because the chosen " & // "EWScheme in the BLHA file does not fit " & // "your parameter choice" call msg_fatal (char (message)) end subroutine ew_parameter_error_message @ %def ew_parameter_error_message @ <>= procedure :: set_mass_and_width => blha_driver_set_mass_and_width <>= module subroutine blha_driver_set_mass_and_width & (driver, i_pdg, mass, width) class(blha_driver_t), intent(inout) :: driver integer, intent(in) :: i_pdg real(default), intent(in), optional :: mass real(default), intent(in), optional :: width end subroutine blha_driver_set_mass_and_width <>= module subroutine blha_driver_set_mass_and_width & (driver, i_pdg, mass, width) class(blha_driver_t), intent(inout) :: driver integer, intent(in) :: i_pdg real(default), intent(in), optional :: mass real(default), intent(in), optional :: width type(string_t) :: buf character(kind=c_char,len=20) :: c_string integer :: ierr if (present (mass)) then buf = 'mass(' // str (abs(i_pdg)) // ')' c_string = char(buf) // c_null_char call driver%blha_olp_set_parameter & (c_string, dble(mass), 0._double, ierr) if (ierr == 0) then buf = "BLHA driver: Attempt to set mass of particle " // & str (abs(i_pdg)) // "failed" call msg_fatal (char(buf)) end if end if if (present (width)) then buf = 'width(' // str (abs(i_pdg)) // ')' c_string = char(buf)//c_null_char call driver%blha_olp_set_parameter & (c_string, dble(width), 0._double, ierr) if (ierr == 0) then buf = "BLHA driver: Attempt to set width of particle " // & str (abs(i_pdg)) // "failed" call msg_fatal (char(buf)) end if end if end subroutine blha_driver_set_mass_and_width @ %def blha_driver_set_mass_and_width @ <>= procedure(blha_driver_init_dlaccess_to_library), deferred :: & init_dlaccess_to_library <>= abstract interface subroutine blha_driver_init_dlaccess_to_library & (object, os_data, dlaccess, success) import class(blha_driver_t), intent(in) :: object type(os_data_t), intent(in) :: os_data type(dlaccess_t), intent(out) :: dlaccess logical, intent(out) :: success end subroutine blha_driver_init_dlaccess_to_library end interface @ %def interface blha_driver_init_dlaccess_to_library @ <>= procedure :: load => blha_driver_load <>= module subroutine blha_driver_load (object, os_data, success) class(blha_driver_t), intent(inout) :: object type(os_data_t), intent(in) :: os_data logical, intent(out) :: success end subroutine blha_driver_load <>= module subroutine blha_driver_load (object, os_data, success) class(blha_driver_t), intent(inout) :: object type(os_data_t), intent(in) :: os_data logical, intent(out) :: success type(dlaccess_t) :: dlaccess type(c_funptr) :: c_fptr logical :: init_success call object%init_dlaccess_to_library (os_data, dlaccess, init_success) c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_Start")) call c_f_procpointer (c_fptr, object%blha_olp_start) call check_for_error (var_str ("OLP_Start")) c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_EvalSubProcess")) call c_f_procpointer (c_fptr, object%blha_olp_eval) call check_for_error (var_str ("OLP_EvalSubProcess")) c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_Info")) call c_f_procpointer (c_fptr, object%blha_olp_info) call check_for_error (var_str ("OLP_Info")) c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_SetParameter")) call c_f_procpointer (c_fptr, object%blha_olp_set_parameter) call check_for_error (var_str ("OLP_SetParameter")) c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_EvalSubProcess2")) call c_f_procpointer (c_fptr, object%blha_olp_eval2) call check_for_error (var_str ("OLP_EvalSubProcess2")) !!! The following three functions are not implemented in OpenLoops. !!! In another BLHA provider, they need to be implemented separately. !!! c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_Option")) !!! call c_f_procpointer (c_fptr, object%blha_olp_option) !!! call check_for_error (var_str ("OLP_Option")) !!! c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_Polvec")) !!! call c_f_procpointer (c_fptr, object%blha_olp_polvec) !!! call check_for_error (var_str ("OLP_Polvec")) !!! c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_Finalize")) !!! call c_f_procpointer (c_fptr, object%blha_olp_finalize) !!! call check_for_error (var_str ("OLP_Finalize")) c_fptr = dlaccess_get_c_funptr (dlaccess, var_str ("OLP_PrintParameter")) call c_f_procpointer (c_fptr, object%blha_olp_print_parameter) call check_for_error (var_str ("OLP_PrintParameter")) success = .true. contains subroutine check_for_error (function_name) type(string_t), intent(in) :: function_name if (dlaccess_has_error (dlaccess)) & call msg_fatal (char ("Loading of " // function_name // " failed!")) end subroutine check_for_error end subroutine blha_driver_load @ %def blha_driver_load @ <>= integer, parameter :: LEN_MAX_FLAVOR_STRING = 100 integer, parameter :: N_MAX_FLAVORS = 100 <>= procedure :: read_contract_file => blha_driver_read_contract_file <>= module subroutine blha_driver_read_contract_file (driver, flavors, & amp_type, flv_index, hel_index, label, helicities) class(blha_driver_t), intent(inout) :: driver integer, intent(in), dimension(:,:) :: flavors integer, intent(out), dimension(:), allocatable :: amp_type, & flv_index, hel_index, label integer, intent(out), dimension(:,:) :: helicities end subroutine blha_driver_read_contract_file <>= module subroutine blha_driver_read_contract_file (driver, flavors, & amp_type, flv_index, hel_index, label, helicities) class(blha_driver_t), intent(inout) :: driver integer, intent(in), dimension(:,:) :: flavors integer, intent(out), dimension(:), allocatable :: amp_type, & flv_index, hel_index, label integer, intent(out), dimension(:,:) :: helicities integer :: unit, filestat character(len=LEN_MAX_FLAVOR_STRING) :: rd_line logical :: read_flavor, give_warning integer :: label_count, i_flv, i integer :: i_hel, n_in integer :: i_next, n_entries integer, dimension(size(flavors, 1) + 2) :: i_array integer, dimension(size(flavors, 1) + 2) :: hel_array integer, dimension(size(flavors, 1)) :: flv_array integer, parameter :: NO_NUMBER = -1000 integer, parameter :: PROC_NOT_FOUND = -1001 integer, parameter :: list_incr = 50 integer :: n_found allocate (amp_type (N_MAX_FLAVORS), flv_index (N_MAX_FLAVORS), & hel_index (N_MAX_FLAVORS), label (N_MAX_FLAVORS)) amp_type = -1; flv_index = -1; hel_index = -1; label = -1 helicities = 0 n_in = size (helicities, dim = 2) n_entries = size (flavors, 1) + 2 unit = free_unit () open (unit, file = char (driver%contract_file), status="old") read_flavor = .false. label_count = 1 i_hel = 1 n_found = 0 give_warning = .false. do read (unit, "(A)", iostat = filestat) rd_line if (filestat == iostat_end) then exit else if (rd_line(1:13) == 'AmplitudeType') then if (i_hel > 2 * n_in) i_hel = 1 i_next = find_next_word_index (rd_line, 13) if (label_count > size (amp_type)) & call extend_integer_array (amp_type, list_incr) if (rd_line(i_next : i_next + 4) == 'Loop') then amp_type(label_count) = BLHA_AMP_LOOP else if (rd_line(i_next : i_next + 4) == 'Tree') then amp_type(label_count) = BLHA_AMP_TREE else if (rd_line(i_next : i_next + 6) == 'ccTree') then amp_type(label_count) = BLHA_AMP_COLOR_C else if (rd_line(i_next : i_next + 6) == 'scTree' .or. & rd_line(i_next : i_next + 14) == 'sctree_polvect') then amp_type(label_count) = BLHA_AMP_SPIN_C else call msg_fatal ("AmplitudeType present but AmpType not known!") end if read_flavor = .true. else if (read_flavor .and. .not. (rd_line(1:13) == 'CouplingPower' & .or. rd_line(1:14) == 'CorrectionType')) then i_array = create_flavor_string (rd_line, n_entries) if (driver%include_polarizations) then hel_array = create_helicity_string (rd_line, n_entries) call check_helicity_array (hel_array, n_entries, n_in) else hel_array = 0 end if if (.not. all (i_array == PROC_NOT_FOUND)) then do i_flv = 1, size (flavors, 2) flv_array = 0 do i = 1, size (flv_array) if (i_array (i) == PHOTON_OFFSHELL .and. & flavors (i, i_flv) == PHOTON) then flv_array (i) = i_array (i) else flv_array (i) = flavors (i, i_flv) end if end do if (all (i_array (1 : n_entries - 2) == flv_array (:))) then if (label_count > size (label)) & call extend_integer_array (label, list_incr) label(label_count) = i_array (n_entries) if (label_count > size (flv_index)) & call extend_integer_array (flv_index, list_incr) flv_index (label_count) = i_flv if (label_count > size (hel_index)) & call extend_integer_array (hel_index, list_incr) hel_index (label_count) = i_hel if (driver%include_polarizations) then helicities (label(label_count), :) = hel_array (1:n_in) i_hel = i_hel + 1 end if n_found = n_found + 1 label_count = label_count + 1 exit end if end do give_warning = .false. else give_warning = .true. end if read_flavor = .false. end if end if end do call crop_integer_array (amp_type, label_count-1) if (n_found == 0) then call msg_fatal ("The desired process has not been found ", & [var_str ("by the OLP-Provider. Maybe the value of alpha_power "), & var_str ("or alphas_power does not correspond to the process. "), & var_str ("If you are using OpenLoops, you can set the option "), & var_str ("openloops_verbosity to a value larger than 1 to obtain "), & var_str ("more information")]) else if (give_warning) then call msg_warning ("Some processes have not been found in the OLC file.", & [var_str ("This is because these processes do not fit the required "), & var_str ("coupling alpha_power and alphas_power. Be aware that the "), & var_str ("results of this calculation are not necessarily an accurate "), & var_str ("description of the physics of interest.")]) end if close(unit) contains function create_flavor_string (s, n_entries) result (i_array) character(len=LEN_MAX_FLAVOR_STRING), intent(in) :: s integer, intent(in) :: n_entries integer, dimension(n_entries) :: i_array integer :: k, current_position integer :: i_entry k = 1; current_position = 1 do if (current_position > LEN_MAX_FLAVOR_STRING) & call msg_fatal ("Read OLC File: Current position exceeds maximum value") if (s(current_position:current_position) /= " ") then call create_flavor (s, i_entry, current_position) if (i_entry /= NO_NUMBER .and. i_entry /= PROC_NOT_FOUND) then i_array(k) = i_entry k = k + 1 if (k > n_entries) then return else call increment_current_position (s, current_position) end if else if (i_entry == PROC_NOT_FOUND) then i_array = PROC_NOT_FOUND return else call increment_current_position (s, current_position) end if else call increment_current_position (s, current_position) end if end do end function create_flavor_string function create_helicity_string (s, n_entries) result (hel_array) character(len = LEN_MAX_FLAVOR_STRING), intent(in) :: s integer, intent(in) :: n_entries integer, dimension(n_entries) :: hel_array integer :: k, current_position integer :: hel k = 1; current_position = 1 do if (current_position > LEN_MAX_FLAVOR_STRING) & call msg_fatal ("Read OLC File: Current position exceeds maximum value") if (s(current_position:current_position) /= " ") then call create_helicity (s, hel, current_position) if (hel >= -1 .and. hel <= 1) then hel_array(k) = hel k = k + 1 if (k > n_entries) then return else call increment_current_position (s, current_position) end if else call increment_current_position (s, current_position) end if else call increment_current_position (s, current_position) end if end do end function create_helicity_string subroutine increment_current_position (s, current_position) character(len = LEN_MAX_FLAVOR_STRING), intent(in) :: s integer, intent(inout) :: current_position current_position = find_next_word_index (s, current_position) end subroutine increment_current_position subroutine get_next_buffer (s, current_position, buf, last_buffer_index) character(len = LEN_MAX_FLAVOR_STRING), intent(in) :: s integer, intent(inout) :: current_position character(len = 10), intent(out) :: buf integer, intent(out) :: last_buffer_index integer :: i i = 1; buf = "" do if (s(current_position:current_position) /= " ") then buf(i:i) = s(current_position:current_position) i = i + 1; current_position = current_position + 1 else exit end if end do last_buffer_index = i end subroutine get_next_buffer function is_particle_buffer (buf, i) result (valid) logical :: valid character(len = 10), intent(in) :: buf integer, intent(in) :: i valid = (buf(1 : i - 1) /= "->" .and. buf(1 : i - 1) /= "|" & .and. buf(1 : i - 1) /= "Process") end function is_particle_buffer subroutine create_flavor (s, i_particle, current_position) character(len=LEN_MAX_FLAVOR_STRING), intent(in) :: s integer, intent(out) :: i_particle integer, intent(inout) :: current_position character(len=10) :: buf integer :: i, last_buffer_index call get_next_buffer (s, current_position, buf, last_buffer_index) i = last_buffer_index if (is_particle_buffer (buf, i)) then call strip_helicity (buf, i) i_particle = read_ival (var_str (buf(1 : i - 1))) else if (buf(1 : i - 1) == "Process") then i_particle = PROC_NOT_FOUND else i_particle = NO_NUMBER end if end subroutine create_flavor subroutine create_helicity (s, helicity, current_position) character(len = LEN_MAX_FLAVOR_STRING), intent(in) :: s integer, intent(out) :: helicity integer, intent(inout) :: current_position character(len = 10) :: buf integer :: i, last_buffer_index logical :: success call get_next_buffer (s, current_position, buf, last_buffer_index) i = last_buffer_index if (is_particle_buffer (buf, i)) then call strip_flavor (buf, i, helicity, success) else helicity = 0 end if end subroutine create_helicity subroutine strip_helicity (buf, i) character(len = 10), intent(in) :: buf integer, intent(inout) :: i integer :: i_last i_last = i - 1 if (i_last < 4) return if (buf(i_last - 2 : i_last) == "(1)") then i = i - 3 else if (buf(i_last - 3 : i_last) == "(-1)") then i = i - 4 end if end subroutine strip_helicity subroutine strip_flavor (buf, i, helicity, success) character(len = 10), intent(in) :: buf integer, intent(in) :: i integer, intent(out) :: helicity logical, intent(out) :: success integer :: i_last i_last = i - 1 helicity = 0 if (i_last < 4) return if (buf(i_last - 2 : i_last) == "(1)") then helicity = 1 success = .true. else if (buf(i_last - 3 : i_last) == "(-1)") then helicity = -1 success = .true. else success = .false. end if end subroutine strip_flavor function find_next_word_index (word, i_start) result (i_next) character(len = LEN_MAX_FLAVOR_STRING), intent(in) :: word integer, intent(in) :: i_start integer :: i_next i_next = i_start + 1 do if (word(i_next : i_next) /= " ") then exit else i_next = i_next + 1 end if if (i_next > LEN_MAX_FLAVOR_STRING) & call msg_fatal ("Find next word: line limit exceeded") end do end function find_next_word_index subroutine check_helicity_array (hel_array, n_entries, n_in) integer, intent(in), dimension(:) :: hel_array integer, intent(in) :: n_entries, n_in integer :: n_particles, i logical :: valid n_particles = n_entries - 2 !!! only allow polarisations for incoming fermions for now valid = all (hel_array (n_in + 1 : n_particles) == 0) do i = 1, n_in valid = valid .and. (hel_array(i) == 1 .or. hel_array(i) == -1) end do if (.not. valid) & call msg_fatal ("Invalid helicities encountered!") end subroutine check_helicity_array end subroutine blha_driver_read_contract_file @ %def blha_driver_read_contract_file @ <>= procedure :: set_alpha_qed => prc_blha_set_alpha_qed <>= module subroutine prc_blha_set_alpha_qed (object, model) class(prc_blha_t), intent(inout) :: object type(model_data_t), intent(in), target :: model end subroutine prc_blha_set_alpha_qed <>= module subroutine prc_blha_set_alpha_qed (object, model) class(prc_blha_t), intent(inout) :: object type(model_data_t), intent(in), target :: model real(default) :: alpha alpha = one / model%get_real (var_str ('alpha_em_i')) select type (driver => object%driver) class is (blha_driver_t) call driver%set_alpha_qed (alpha) end select end subroutine prc_blha_set_alpha_qed @ %def prc_blha_set_alpha_qed @ <>= procedure :: set_GF => prc_blha_set_GF <>= module subroutine prc_blha_set_GF (object, model) class(prc_blha_t), intent(inout) :: object type(model_data_t), intent(in), target :: model end subroutine prc_blha_set_GF <>= module subroutine prc_blha_set_GF (object, model) class(prc_blha_t), intent(inout) :: object type(model_data_t), intent(in), target :: model real(default) :: GF GF = model%get_real (var_str ('GF')) select type (driver => object%driver) class is (blha_driver_t) call driver%set_GF (GF) end select end subroutine prc_blha_set_GF @ %def prc_blha_set_GF @ <>= procedure :: set_weinberg_angle => prc_blha_set_weinberg_angle <>= module subroutine prc_blha_set_weinberg_angle (object, model) class(prc_blha_t), intent(inout) :: object type(model_data_t), intent(in), target :: model end subroutine prc_blha_set_weinberg_angle <>= module subroutine prc_blha_set_weinberg_angle (object, model) class(prc_blha_t), intent(inout) :: object type(model_data_t), intent(in), target :: model real(default) :: sw2 sw2 = model%get_real (var_str ('sw2')) select type (driver => object%driver) class is (blha_driver_t) call driver%set_weinberg_angle (sw2) end select end subroutine prc_blha_set_weinberg_angle @ %def prc_blha_set_weinberg_angle @ <>= procedure :: set_electroweak_parameters => & prc_blha_set_electroweak_parameters <>= module subroutine prc_blha_set_electroweak_parameters (object, model) class(prc_blha_t), intent(inout) :: object type(model_data_t), intent(in), target :: model end subroutine prc_blha_set_electroweak_parameters <>= module subroutine prc_blha_set_electroweak_parameters (object, model) class(prc_blha_t), intent(inout) :: object type(model_data_t), intent(in), target :: model if (count (object%ew_parameter_mask) == 0) then call msg_fatal ("Cannot decide EW parameter setting: No scheme set!") else if (count (object%ew_parameter_mask) > 1) then call msg_fatal ("Cannot decide EW parameter setting: More than one scheme set!") end if if (object%ew_parameter_mask (I_ALPHA_INTERNAL)) call object%set_alpha_qed (model) if (object%ew_parameter_mask (I_GF)) call object%set_GF (model) if (object%ew_parameter_mask (I_SW2)) call object%set_weinberg_angle (model) end subroutine prc_blha_set_electroweak_parameters @ %def prc_blha_set_electrweak_parameters @ <>= procedure :: read_contract_file => prc_blha_read_contract_file <>= module subroutine prc_blha_read_contract_file (object, flavors) class(prc_blha_t), intent(inout) :: object integer, intent(in), dimension(:,:) :: flavors end subroutine prc_blha_read_contract_file <>= module subroutine prc_blha_read_contract_file (object, flavors) class(prc_blha_t), intent(inout) :: object integer, intent(in), dimension(:,:) :: flavors integer, dimension(:), allocatable :: amp_type, flv_index, hel_index, label integer, dimension(:,:), allocatable :: helicities integer :: i_proc, i_hel allocate (helicities (N_MAX_FLAVORS, object%data%n_in)) select type (driver => object%driver) class is (blha_driver_t) call driver%read_contract_file (flavors, amp_type, flv_index, & hel_index, label, helicities) end select object%n_proc = count (amp_type >= 0) do i_proc = 1, object%n_proc if (amp_type (i_proc) < 0) exit if (hel_index(i_proc) < 0 .and. object%includes_polarization ()) & call msg_bug ("Object includes polarization, but helicity index is undefined.") i_hel = hel_index (i_proc) select case (amp_type (i_proc)) case (BLHA_AMP_TREE) if (allocated (object%i_tree)) then object%i_tree(flv_index(i_proc), i_hel) = label(i_proc) else call msg_fatal ("Tree matrix element present, & &but neither Born nor real indices are allocated!") end if case (BLHA_AMP_COLOR_C) if (allocated (object%i_color_c)) then object%i_color_c(flv_index(i_proc), i_hel) = label(i_proc) else call msg_fatal ("Color-correlated matrix element present, & &but cc-indices are not allocated!") end if case (BLHA_AMP_SPIN_C) if (allocated (object%i_spin_c)) then object%i_spin_c(flv_index(i_proc), i_hel) = label(i_proc) else call msg_fatal ("Spin-correlated matrix element present, & &but sc-indices are not allocated!") end if case (BLHA_AMP_LOOP) if (allocated (object%i_virt)) then object%i_virt(flv_index(i_proc), i_hel) = label(i_proc) else call msg_fatal ("Loop matrix element present, & &but virt-indices are not allocated!") end if case default call msg_fatal ("Undefined amplitude type") end select if (allocated (object%i_hel)) & object%i_hel (i_proc, :) = helicities (label(i_proc), :) end do end subroutine prc_blha_read_contract_file @ %def prc_blha_read_contract_file @ <>= procedure :: print_parameter_file => prc_blha_print_parameter_file <>= module subroutine prc_blha_print_parameter_file (object, i_component) class(prc_blha_t), intent(in) :: object integer, intent(in) :: i_component end subroutine prc_blha_print_parameter_file <>= module subroutine prc_blha_print_parameter_file (object, i_component) class(prc_blha_t), intent(in) :: object integer, intent(in) :: i_component type(string_t) :: filename select type (def => object%def) class is (blha_def_t) filename = def%basename // '_' // str (i_component) // '.olp_parameters' end select select type (driver => object%driver) class is (blha_driver_t) call driver%blha_olp_print_parameter (char(filename)//c_null_char) end select end subroutine prc_blha_print_parameter_file @ %def prc_blha_print_parameter_file @ <>= procedure :: compute_amplitude => prc_blha_compute_amplitude <>= module function prc_blha_compute_amplitude & (object, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced, & core_state) result (amp) class(prc_blha_t), intent(in) :: object integer, intent(in) :: j type(vector4_t), dimension(:), intent(in) :: p integer, intent(in) :: f, h, c real(default), intent(in) :: fac_scale, ren_scale real(default), intent(in), allocatable :: alpha_qcd_forced class(prc_core_state_t), intent(inout), allocatable, optional :: core_state complex(default) :: amp end function prc_blha_compute_amplitude <>= module function prc_blha_compute_amplitude & (object, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced, & core_state) result (amp) class(prc_blha_t), intent(in) :: object integer, intent(in) :: j type(vector4_t), dimension(:), intent(in) :: p integer, intent(in) :: f, h, c real(default), intent(in) :: fac_scale, ren_scale real(default), intent(in), allocatable :: alpha_qcd_forced class(prc_core_state_t), intent(inout), allocatable, optional :: core_state complex(default) :: amp select type (core_state) class is (blha_state_t) core_state%alpha_qcd = object%qcd%alpha%get (ren_scale) end select amp = zero end function prc_blha_compute_amplitude @ %def prc_blha_compute_amplitude @ <>= procedure :: init_blha => prc_blha_init_blha <>= module subroutine prc_blha_init_blha (object, blha_template, n_in, & n_particles, n_flv, n_hel) class(prc_blha_t), intent(inout) :: object type(blha_template_t), intent(in) :: blha_template integer, intent(in) :: n_in, n_particles, n_flv, n_hel end subroutine prc_blha_init_blha <>= module subroutine prc_blha_init_blha (object, blha_template, n_in, & n_particles, n_flv, n_hel) class(prc_blha_t), intent(inout) :: object type(blha_template_t), intent(in) :: blha_template integer, intent(in) :: n_in, n_particles, n_flv, n_hel object%n_particles = n_particles object%n_flv = n_flv object%n_hel = n_hel if (blha_template%compute_loop ()) then if (blha_template%include_polarizations) then allocate (object%i_virt (n_flv, n_hel), & object%i_color_c (n_flv, n_hel)) if (blha_template%use_internal_color_correlations) then allocate (object%i_hel (n_flv * n_in * n_hel * 2, n_in)) else allocate (object%i_hel (n_flv * n_in * n_hel, n_in)) end if else allocate (object%i_virt (n_flv, 1), object%i_color_c (n_flv, 1)) end if object%i_virt = -1 object%i_color_c = -1 else if (blha_template%compute_subtraction ()) then if (blha_template%include_polarizations) then allocate (object%i_tree (n_flv, n_hel), & object%i_color_c (n_flv, n_hel), & object%i_spin_c (n_flv, n_hel), & object%i_hel (3 * (n_flv * n_hel * n_in), n_in)) object%i_hel = 0 else allocate (object%i_tree (n_flv, 1), object%i_color_c (n_flv, 1) , & object%i_spin_c (n_flv, 1)) end if object%i_tree = -1 object%i_color_c = -1 object%i_spin_c = -1 else if (blha_template%compute_dglap ()) then if (blha_template%include_polarizations) then allocate (object%i_tree (n_flv, n_hel), & object%i_color_c (n_flv, n_hel), & object%i_hel (3 * (n_flv * n_hel * n_in), n_in)) object%i_hel = 0 else allocate (object%i_tree (n_flv, 1), object%i_color_c (n_flv, 1)) end if object%i_tree = -1 object%i_color_c = -1 else if (blha_template%compute_real_trees () .or. blha_template%compute_born ()) then if (blha_template%include_polarizations) then allocate (object%i_tree (n_flv, n_hel)) allocate (object%i_hel (n_flv * n_hel * n_in, n_in)) object%i_hel = 0 else allocate (object%i_tree (n_flv, 1)) end if object%i_tree = -1 end if call object%init_ew_parameters (blha_template%ew_scheme) select type (driver => object%driver) class is (blha_driver_t) driver%include_polarizations = blha_template%include_polarizations driver%switch_off_muon_yukawas = blha_template%switch_off_muon_yukawas driver%external_top_yukawa = blha_template%external_top_yukawa end select end subroutine prc_blha_init_blha @ %def prc_blha_init_blha @ <>= procedure :: set_mass_and_width => prc_blha_set_mass_and_width <>= module subroutine prc_blha_set_mass_and_width (object, i_pdg, mass, width) class(prc_blha_t), intent(inout) :: object integer, intent(in) :: i_pdg real(default), intent(in) :: mass, width end subroutine prc_blha_set_mass_and_width <>= module subroutine prc_blha_set_mass_and_width (object, i_pdg, mass, width) class(prc_blha_t), intent(inout) :: object integer, intent(in) :: i_pdg real(default), intent(in) :: mass, width select type (driver => object%driver) class is (blha_driver_t) call driver%set_mass_and_width (i_pdg, mass, width) end select end subroutine prc_blha_set_mass_and_width @ %def prc_blha_set_mass_and_width @ <>= procedure :: set_particle_properties => prc_blha_set_particle_properties <>= module subroutine prc_blha_set_particle_properties (object, model) class(prc_blha_t), intent(inout) :: object class(model_data_t), intent(in), target :: model end subroutine prc_blha_set_particle_properties <>= module subroutine prc_blha_set_particle_properties (object, model) class(prc_blha_t), intent(inout) :: object class(model_data_t), intent(in), target :: model integer :: i, i_pdg type(flavor_t) :: flv real(default) :: mass, width integer :: ierr real(default) :: top_yukawa do i = 1, OLP_N_MASSIVE_PARTICLES i_pdg = OLP_MASSIVE_PARTICLES(i) if (i_pdg < 0) cycle call flv%init (i_pdg, model) mass = flv%get_mass (); width = flv%get_width () select type (driver => object%driver) class is (blha_driver_t) call driver%set_mass_and_width (i_pdg, mass = mass, width = width) if (i_pdg == 5) call driver%blha_olp_set_parameter & ('yuk(5)'//c_null_char, dble(mass), 0._double, ierr) if (i_pdg == 6) then if (driver%external_top_yukawa > 0._default) then top_yukawa = driver%external_top_yukawa else top_yukawa = mass end if call driver%blha_olp_set_parameter & ('yuk(6)'//c_null_char, dble(top_yukawa), 0._double, ierr) end if if (driver%switch_off_muon_yukawas) then if (i_pdg == 13) call driver%blha_olp_set_parameter & ('yuk(13)' //c_null_char, 0._double, 0._double, ierr) end if end select end do end subroutine prc_blha_set_particle_properties @ %def prc_blha_set_particle_properties @ This mask adapts which electroweak parameters are supposed to set according to the chosen BLHA EWScheme. This is only implemented for the default OLP method so far. <>= procedure :: init_ew_parameters => prc_blha_init_ew_parameters <>= module subroutine prc_blha_init_ew_parameters (object, ew_scheme) class(prc_blha_t), intent(inout) :: object integer, intent(in) :: ew_scheme end subroutine prc_blha_init_ew_parameters <>= module subroutine prc_blha_init_ew_parameters (object, ew_scheme) class(prc_blha_t), intent(inout) :: object integer, intent(in) :: ew_scheme object%ew_parameter_mask = .false. select case (ew_scheme) case (BLHA_EW_0) object%ew_parameter_mask (I_ALPHA_0) = .true. case (BLHA_EW_GF) object%ew_parameter_mask (I_GF) = .true. case (BLHA_EW_MZ) object%ew_parameter_mask (I_ALPHA_MZ) = .true. case (BLHA_EW_INTERNAL) object%ew_parameter_mask (I_ALPHA_INTERNAL) = .true. end select end subroutine prc_blha_init_ew_parameters @ %def prc_blha_init_ew_parameters @ Computes a virtual matrix element from an interface to an external one-loop provider. The output of [[blha_olp_eval2]] is an array of [[dimension(4)]], corresponding to the $\epsilon^2$-, $\epsilon^1$- and $\epsilon^0$-poles of the virtual matrix element at position [[r(1:3)]] and the Born matrix element at position [[r(4)]]. The matrix element is rejected if its accuracy is larger than the maximal allowed accuracy. OpenLoops includes a factor of 1 / [[n_hel]] in the amplitudes, which we have to undo if polarized matrix elements are requested (GoSam does not support polarized matrix elements). <>= procedure :: compute_sqme_virt => prc_blha_compute_sqme_virt <>= module subroutine prc_blha_compute_sqme_virt (object, & i_flv, i_hel, p, ren_scale, es_scale, loop_method, sqme, bad_point) class(prc_blha_t), intent(in) :: object integer, intent(in) :: i_flv, i_hel type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: ren_scale, es_scale integer, intent(in) :: loop_method real(default), dimension(4), intent(out) :: sqme logical, intent(out) :: bad_point end subroutine prc_blha_compute_sqme_virt <>= module subroutine prc_blha_compute_sqme_virt (object, & i_flv, i_hel, p, ren_scale, es_scale, loop_method, sqme, bad_point) class(prc_blha_t), intent(in) :: object integer, intent(in) :: i_flv, i_hel type(vector4_t), dimension(:), intent(in) :: p real(default), intent(in) :: ren_scale, es_scale integer, intent(in) :: loop_method real(default), dimension(4), intent(out) :: sqme logical, intent(out) :: bad_point real(double), dimension(5 * object%n_particles) :: mom real(double), dimension(:), allocatable :: r real(double) :: mu_dble, es_dble real(double) :: acc_dble real(default) :: acc real(default) :: alpha_s integer :: ierr if (object%i_virt(i_flv, i_hel) >= 0) then allocate (r (blha_result_array_size (object%n_particles, BLHA_AMP_LOOP))) if (debug_on) call msg_debug2 (D_VIRTUAL, "prc_blha_compute_sqme_virt") if (debug_on) call msg_debug2 (D_VIRTUAL, "i_flv", i_flv) if (debug_on) call msg_debug2 (D_VIRTUAL, "object%i_virt(i_flv, i_hel)", object%i_virt(i_flv, i_hel)) if (debug2_active (D_VIRTUAL)) then call msg_debug2 (D_VIRTUAL, "use momenta: ") call vector4_write_set (p, show_mass = .true., & check_conservation = .true.) end if mom = object%create_momentum_array (p) if (vanishes (ren_scale)) & call msg_fatal ("prc_blha_compute_sqme_virt: ren_scale vanishes") mu_dble = dble (ren_scale) es_dble = dble (es_scale) alpha_s = object%qcd%alpha%get (ren_scale) select type (driver => object%driver) class is (blha_driver_t) if (loop_method == BLHA_MODE_OPENLOOPS) then call driver%blha_olp_set_parameter ('mureg'//c_null_char, es_dble, 0._double, ierr) if (ierr == 0) call parameter_error_message (var_str ('mureg'), & var_str ('prc_blha_compute_sqme_virt')) end if call driver%set_alpha_s (alpha_s) call driver%blha_olp_eval2 (object%i_virt(i_flv, i_hel), mom, mu_dble, r, acc_dble) end select acc = acc_dble sqme = r(1:4) bad_point = acc > object%maximum_accuracy if (object%includes_polarization ()) sqme = object%n_hel * sqme else sqme = zero end if end subroutine prc_blha_compute_sqme_virt @ %def prc_blha_compute_sqme_virt @ Computes a tree-level matrix element from an interface to an external one-loop provider. The matrix element is rejected if its accuracy is larger than the maximal allowed accuracy. OpenLoops includes a factor of 1 / [[n_hel]] in the amplitudes, which we have to undo if polarized matrix elements are requested (GoSam does not support polarized matrix elements). <>= procedure :: compute_sqme => prc_blha_compute_sqme <>= module subroutine prc_blha_compute_sqme (object, i_flv, i_hel, p, & ren_scale, sqme, bad_point) class(prc_blha_t), intent(in) :: object integer, intent(in) :: i_flv, i_hel type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: ren_scale real(default), intent(out) :: sqme logical, intent(out) :: bad_point end subroutine prc_blha_compute_sqme <>= module subroutine prc_blha_compute_sqme (object, i_flv, i_hel, p, & ren_scale, sqme, bad_point) class(prc_blha_t), intent(in) :: object integer, intent(in) :: i_flv, i_hel type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: ren_scale real(default), intent(out) :: sqme logical, intent(out) :: bad_point real(double), dimension(5*object%n_particles) :: mom real(double), dimension(OLP_RESULTS_LIMIT) :: r real(double) :: mu_dble, acc_dble real(default) :: acc, alpha_s if (object%i_tree(i_flv, i_hel) >= 0) then if (debug_on) call msg_debug2 (D_REAL, "prc_blha_compute_sqme") if (debug_on) call msg_debug2 (D_REAL, "i_flv", i_flv) if (debug2_active (D_REAL)) then call msg_debug2 (D_REAL, "use momenta: ") call vector4_write_set (p, show_mass = .true., & check_conservation = .true.) end if mom = object%create_momentum_array (p) if (vanishes (ren_scale)) & call msg_fatal ("prc_blha_compute_sqme: ren_scale vanishes") mu_dble = dble(ren_scale) alpha_s = object%qcd%alpha%get (ren_scale) select type (driver => object%driver) class is (blha_driver_t) call driver%set_alpha_s (alpha_s) call driver%blha_olp_eval2 (object%i_tree(i_flv, i_hel), mom, & mu_dble, r, acc_dble) sqme = r(object%sqme_tree_pos) end select acc = acc_dble bad_point = acc > object%maximum_accuracy if (object%includes_polarization ()) sqme = object%n_hel * sqme else sqme = zero end if end subroutine prc_blha_compute_sqme @ %def prc_blha_compute_sqme @ For the color correlated matrix the standard is to compute the diagonal entries from the born amplitudes and corresponding casimirs. However, if EW corrections are activated, the thus derived entries can be computed with born amplitudes of wrong coupling powers if the flavor structure potentially induces QCD-EW interference amplitudes. For this purpose a second possibility, to compute the diagonal from the off-diagonal elements is implemented as a special case. <>= public :: blha_color_c_fill_diag <>= module subroutine blha_color_c_fill_diag & (sqme_born, flavors, sqme_color_c, special_case) real(default), intent(in) :: sqme_born integer, intent(in), dimension(:) :: flavors logical, intent(in), optional :: special_case real(default), intent(inout), dimension(:,:) :: sqme_color_c end subroutine blha_color_c_fill_diag <>= module subroutine blha_color_c_fill_diag & (sqme_born, flavors, sqme_color_c, special_case) real(default), intent(in) :: sqme_born integer, intent(in), dimension(:) :: flavors logical, intent(in), optional :: special_case real(default), intent(inout), dimension(:,:) :: sqme_color_c real(default) :: sqme_line_off integer :: i, j logical :: special_c special_c = .false. if (present (special_case)) & special_c = special_case .and. qcd_ew_interferences (flavors) do i = 1, size (flavors) if (is_quark (flavors(i))) then sqme_line_off = zero do j = 1, size (flavors) if (j /= i) sqme_line_off = sqme_line_off + sqme_color_c (i, j) end do if (special_c) then sqme_color_c (i, i) = - sqme_line_off else sqme_color_c (i, i) = -cf * sqme_born end if else if (is_gluon (flavors(i))) then sqme_line_off = zero do j = 1, size (flavors) if (j /= i) sqme_line_off = sqme_line_off + sqme_color_c (i, j) end do if (special_c) then sqme_color_c (i, i) = - sqme_line_off else sqme_color_c (i, i) = -ca * sqme_born end if else sqme_color_c (i, i) = zero end if end do end subroutine blha_color_c_fill_diag @ %def blha_color_c_fill_diag <>= public :: blha_color_c_fill_offdiag <>= module subroutine blha_color_c_fill_offdiag & (n, r, sqme_color_c, offset, n_flv) integer, intent(in) :: n real(default), intent(in), dimension(:) :: r real(default), intent(inout), dimension(:,:) :: sqme_color_c integer, intent(in), optional :: offset, n_flv end subroutine blha_color_c_fill_offdiag <>= module subroutine blha_color_c_fill_offdiag & (n, r, sqme_color_c, offset, n_flv) integer, intent(in) :: n real(default), intent(in), dimension(:) :: r real(default), intent(inout), dimension(:,:) :: sqme_color_c integer, intent(in), optional :: offset, n_flv integer :: i, j, pos, incr if (present (offset)) then incr = offset else incr = 0 end if pos = 0 do j = 1, n do i = 1, j if (i /= j) then pos = (j - 1) * (j - 2) / 2 + i if (present (n_flv)) incr = incr + n_flv - 1 if (present (offset)) pos = pos + incr sqme_color_c (i, j) = -r (pos) sqme_color_c (j, i) = sqme_color_c (i, j) end if end do end do end subroutine blha_color_c_fill_offdiag @ %def blha_color_c_fill_offdiag @ Computes a color-correlated matrix element from an interface to an external one-loop provider. The output of [[blha_olp_eval2]] is an array of [[dimension(n * (n - 1) / 2)]]. The matrix element is rejected if its accuracy is larger than the maximal allowed accuracy. OpenLoops includes a factor of 1 / [[n_hel]] in the amplitudes, which we have to undo if polarized matrix elements are requested (GoSam does not support polarized matrix elements). <>= procedure :: compute_sqme_color_c_raw => prc_blha_compute_sqme_color_c_raw <>= module subroutine prc_blha_compute_sqme_color_c_raw & (object, i_flv, i_hel, p, ren_scale, rr, bad_point) class(prc_blha_t), intent(in) :: object integer, intent(in) :: i_flv, i_hel type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: ren_scale real(default), intent(out), dimension(:) :: rr logical, intent(out) :: bad_point end subroutine prc_blha_compute_sqme_color_c_raw <>= module subroutine prc_blha_compute_sqme_color_c_raw & (object, i_flv, i_hel, p, ren_scale, rr, bad_point) class(prc_blha_t), intent(in) :: object integer, intent(in) :: i_flv, i_hel type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: ren_scale real(default), intent(out), dimension(:) :: rr logical, intent(out) :: bad_point real(double), dimension(5 * object%n_particles) :: mom real(double), dimension(size(rr)) :: r real(default) :: alpha_s, acc real(double) :: mu_dble, acc_dble if (debug2_active (D_REAL)) then call msg_debug2 (D_REAL, "use momenta: ") call vector4_write_set (p, show_mass = .true., & check_conservation = .true.) end if if (object%i_color_c(i_flv, i_hel) >= 0) then mom = object%create_momentum_array (p) if (vanishes (ren_scale)) & call msg_fatal ("prc_blha_compute_sqme_color_c: ren_scale vanishes") mu_dble = dble(ren_scale) alpha_s = object%qcd%alpha%get (ren_scale) select type (driver => object%driver) class is (blha_driver_t) call driver%set_alpha_s (alpha_s) call driver%blha_olp_eval2 (object%i_color_c(i_flv, i_hel), & mom, mu_dble, r, acc_dble) end select rr = r acc = acc_dble bad_point = acc > object%maximum_accuracy if (object%includes_polarization ()) rr = object%n_hel * rr else rr = zero end if end subroutine prc_blha_compute_sqme_color_c_raw @ %def prc_blha_compute_sqme_color_c_raw @ <>= procedure :: compute_sqme_color_c => prc_blha_compute_sqme_color_c <>= module subroutine prc_blha_compute_sqme_color_c & (object, i_flv, i_hel, p, ren_scale, born_color_c, bad_point, born_out) class(prc_blha_t), intent(inout) :: object integer, intent(in) :: i_flv, i_hel type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: ren_scale real(default), intent(inout), dimension(:,:) :: born_color_c real(default), intent(out), optional :: born_out logical, intent(out) :: bad_point end subroutine prc_blha_compute_sqme_color_c <>= module subroutine prc_blha_compute_sqme_color_c & (object, i_flv, i_hel, p, ren_scale, born_color_c, bad_point, born_out) class(prc_blha_t), intent(inout) :: object integer, intent(in) :: i_flv, i_hel type(vector4_t), intent(in), dimension(:) :: p real(default), intent(in) :: ren_scale real(default), intent(inout), dimension(:,:) :: born_color_c real(default), intent(out), optional :: born_out logical, intent(out) :: bad_point real(default), dimension(:), allocatable :: r logical :: bad_point2 real(default) :: born integer, dimension(:), allocatable :: flavors if (debug2_active (D_REAL)) then call msg_debug2 (D_REAL, "use momenta: ") call vector4_write_set (p, show_mass = .true., & check_conservation = .true.) end if allocate (r (blha_result_array_size & (size(born_color_c, dim=1), BLHA_AMP_COLOR_C))) call object%compute_sqme_color_c_raw (i_flv, i_hel, p, ren_scale, r, bad_point) select type (driver => object%driver) class is (blha_driver_t) if (allocated (object%i_tree)) then call object%compute_sqme (i_flv, i_hel, p, ren_scale, born, bad_point2) else born = zero end if if (present (born_out)) born_out = born end select call blha_color_c_fill_offdiag (object%n_particles, r, born_color_c) flavors = object%get_flv_state (i_flv) call blha_color_c_fill_diag (born, flavors, born_color_c) bad_point = bad_point .or. bad_point2 end subroutine prc_blha_compute_sqme_color_c @ %def prc_blha_compute_sqme_color_c @ <>= generic :: get_beam_helicities => get_beam_helicities_single generic :: get_beam_helicities => get_beam_helicities_array procedure :: get_beam_helicities_single => prc_blha_get_beam_helicities_single procedure :: get_beam_helicities_array => prc_blha_get_beam_helicities_array <>= module function prc_blha_get_beam_helicities_single & (object, i, invert_second) result (hel) integer, dimension(:), allocatable :: hel class(prc_blha_t), intent(in) :: object logical, intent(in), optional :: invert_second integer, intent(in) :: i end function prc_blha_get_beam_helicities_single module function prc_blha_get_beam_helicities_array & (object, invert_second) result (hel) integer, dimension(:,:), allocatable :: hel class(prc_blha_t), intent(in) :: object logical, intent(in), optional :: invert_second end function prc_blha_get_beam_helicities_array <>= module function prc_blha_get_beam_helicities_single & (object, i, invert_second) result (hel) integer, dimension(:), allocatable :: hel class(prc_blha_t), intent(in) :: object logical, intent(in), optional :: invert_second integer, intent(in) :: i logical :: inv inv = .false.; if (present (invert_second)) inv = invert_second allocate (hel (object%data%n_in)) hel = object%i_hel (i, :) if (inv .and. object%data%n_in == 2) hel(2) = -hel(2) end function prc_blha_get_beam_helicities_single @ %def prc_blha_get_beam_helicities_single @ <>= module function prc_blha_get_beam_helicities_array & (object, invert_second) result (hel) integer, dimension(:,:), allocatable :: hel class(prc_blha_t), intent(in) :: object logical, intent(in), optional :: invert_second integer :: i allocate (hel (object%n_proc, object%data%n_in)) do i = 1, object%n_proc hel(i,:) = object%get_beam_helicities (i, invert_second) end do end function prc_blha_get_beam_helicities_array @ %def prc_blha_get_beam_helicities_array @ <>= procedure :: includes_polarization => prc_blha_includes_polarization <>= module function prc_blha_includes_polarization (object) result (polarized) logical :: polarized class(prc_blha_t), intent(in) :: object end function prc_blha_includes_polarization <>= module function prc_blha_includes_polarization (object) result (polarized) logical :: polarized class(prc_blha_t), intent(in) :: object select type (driver => object%driver) class is (blha_driver_t) polarized = driver%include_polarizations end select end function prc_blha_includes_polarization @ %def prc_blha_includes_polarization @ Setup an index mapping for flavor structures and helicities that give the same matrix element. The index mapping is according to the order of flavor structures known to the [[prc_core]] class. Overrides [[prc_core_set_equivalent_flv_hel_indices]]. <>= procedure :: set_equivalent_flv_hel_indices => prc_blha_set_equivalent_flv_hel_indices <>= module subroutine prc_blha_set_equivalent_flv_hel_indices (object) class(prc_blha_t), intent(inout) :: object end subroutine prc_blha_set_equivalent_flv_hel_indices <>= module subroutine prc_blha_set_equivalent_flv_hel_indices (object) class(prc_blha_t), intent(inout) :: object integer :: n_flv, n_hel integer :: i_flv1, i_flv2, i_hel1, i_hel2 integer, dimension(:,:), allocatable :: amp_id, amp_id_color if (allocated (object%i_virt)) then amp_id = object%i_virt else amp_id = object%i_tree end if if (allocated (object%i_color_c)) then amp_id_color = object%i_color_c end if n_flv = size (amp_id, dim=1) n_hel = size (amp_id, dim=2) if (.not. allocated (object%data%eqv_flv_index)) & allocate (object%data%eqv_flv_index(n_flv)) if (.not. allocated (object%data%eqv_hel_index)) & allocate (object%data%eqv_hel_index(n_hel)) if (size (object%data%eqv_flv_index) /= n_flv) & call msg_bug ("BLHA Core: Size mismatch between eqv_flv_index and number of flavors.") if (size (object%data%eqv_hel_index) /= n_hel) & call msg_bug ("BLHA Core: Size mismatch between eqv_hel_index and number of helicities.") do i_flv1 = 1, n_flv do i_hel1 = 1, n_hel FLV_LOOP: do i_flv2 = 1, i_flv1 do i_hel2 = 1, i_hel1 if (amp_id(i_flv2, i_hel2) == amp_id(i_flv1, i_hel1)) then if (.not. allocated (amp_id_color)) then object%data%eqv_flv_index(i_flv1) = i_flv2 object%data%eqv_hel_index(i_hel1) = i_hel2 exit FLV_LOOP else if (amp_id_color (i_flv2, i_hel2) == & amp_id_color(i_flv1, i_hel1)) then object%data%eqv_flv_index(i_flv1) = i_flv2 object%data%eqv_hel_index(i_hel1) = i_hel2 exit FLV_LOOP end if end if end do end do FLV_LOOP end do end do end subroutine prc_blha_set_equivalent_flv_hel_indices @ %def prc_blha_set_equivalent_flv_hel_indices @ <>= procedure(prc_blha_init_driver), deferred :: & init_driver <>= abstract interface subroutine prc_blha_init_driver (object, os_data) import class(prc_blha_t), intent(inout) :: object type(os_data_t), intent(in) :: os_data end subroutine prc_blha_init_driver end interface @ %def prc_blha_init_driver interface @ In general, the BLHA consits of a virtual matrix element and $n_{\rm{sub}}$ subtraction terms. The subtractions terms can be pure Born matrix elements (to be used in collinear subtraction or in internal color-correlation), color-correlated matrix elements or spin-correlated matrix elements. The numbers should be ordered in such a way that $\mathcal{V}_{\rm{fin}}$ is first, followed by the pure Born, the color-correlated and the spin-correlated matrix elements. This repeats $n_{\rm{flv}}$ times. Let $\nu_i$ be the position of the $ith$ virtual matrix element. The next $\mathcal{V}_{\rm{fin}}$ is at position $\nu_i = \nu_{i - 1} + n_{\rm{sub}} + 1$. Obviously, $\nu_1 = 1$. This allows us to determine the virtual matrix element positions using the recursive function implemented below. <>= public :: blha_loop_positions <>= recursive module function blha_loop_positions (i_flv, n_sub) result (index) integer :: index integer, intent(in) :: i_flv, n_sub end function blha_loop_positions <>= recursive module function blha_loop_positions (i_flv, n_sub) result (index) integer :: index integer, intent(in) :: i_flv, n_sub index = 0 if (i_flv == 1) then index = 1 else index = blha_loop_positions (i_flv - 1, n_sub) + n_sub + 1 end if end function blha_loop_positions @ %def blha_loop_positions @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[blha_ut.f90]]>>= <> module blha_ut use unit_tests use blha_uti <> <> contains <> end module blha_ut @ %def blha_ut @ <<[[blha_uti.f90]]>>= <> module blha_uti <> use format_utils, only: write_separator use variables, only: var_list_t use os_interface use models use blha_config <> <> contains <> <> end module blha_uti @ %def blha_uti @ API: driver for the unit tests below. <>= public :: blha_test <>= subroutine blha_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results call test(blha_1, "blha_1", "Test the creation of BLHA-OLP files", u, results) call test(blha_2, "blha_2", "Test the creation of BLHA-OLP files for "& &"multiple flavor structures", u, results) call test(blha_3, "blha_3", "Test helicity-information in OpenLoops OLP files", & u, results) end subroutine blha_test @ %def blha_test @ <>= subroutine setup_and_write_blha_configuration (u, single, polarized) integer, intent(in) :: u logical, intent(in), optional :: single logical, intent(in), optional :: polarized logical :: polrzd, singl type(blha_master_t) :: blha_master integer :: i integer :: n_in, n_out integer :: alpha_power, alphas_power integer, dimension(:,:), allocatable :: flv_born, flv_real type(string_t) :: proc_id, method, correction_type type(os_data_t) :: os_data type(model_list_t) :: model_list type(var_list_t) :: var_list type(model_t), pointer :: model => null () integer :: openloops_phs_tolerance polrzd = .false.; if (present (polarized)) polrzd = polarized singl = .true.; if (present (single)) singl = single if (singl) then write (u, "(A)") "* Process: e+ e- -> W+ W- b b~" n_in = 2; n_out = 4 alpha_power = 4; alphas_power = 0 allocate (flv_born (n_in + n_out, 1)) allocate (flv_real (n_in + n_out + 1, 1)) flv_born(1,1) = 11; flv_born(2,1) = -11 flv_born(3,1) = 24; flv_born(4,1) = -24 flv_born(5,1) = 5; flv_born(6,1) = -5 flv_real(1:6,1) = flv_born(:,1) flv_real(7,1) = 21 else write (u, "(A)") "* Process: e+ e- -> u:d:s U:D:S" n_in = 2; n_out = 2 alpha_power = 2; alphas_power = 0 allocate (flv_born (n_in + n_out, 3)) allocate (flv_real (n_in + n_out + 1, 3)) flv_born(1,:) = 11; flv_born(2,:) = -11 flv_born(3,1) = 1; flv_born(4,1) = -1 flv_born(3,2) = 2; flv_born(4,2) = -2 flv_born(3,3) = 3; flv_born(4,3) = -3 flv_real(1:4,:) = flv_born flv_real(5,:) = 21 end if proc_id = var_str ("BLHA_Test") call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), os_data, model) write (u, "(A)") "* BLHA matrix elements assumed for all process components" write (u, "(A)") "* Mode: GoSam" method = var_str ("gosam") correction_type = var_str ("QCD") call var_list%append_string (var_str ("$born_me_method"), method) call var_list%append_string (var_str ("$real_tree_me_method"), method) call var_list%append_string (var_str ("$loop_me_method"), method) call var_list%append_string (var_str ("$correlation_me_method"), method) call blha_master%set_ew_scheme (var_str ("GF")) call blha_master%set_methods (.true., var_list) call blha_master%allocate_config_files () call blha_master%set_correction_type (correction_type) call blha_master%generate (proc_id, model, n_in, & alpha_power, alphas_power, flv_born, flv_real) call test_output (u) call blha_master%final () call var_list%final () write (u, "(A)") "* Switch to OpenLoops" openloops_phs_tolerance = 7 method = var_str ("openloops") correction_type = var_str ("QCD") call var_list%append_string (var_str ("$born_me_method"), method) call var_list%append_string (var_str ("$real_tree_me_method"), method) call var_list%append_string (var_str ("$loop_me_method"), method) call var_list%append_string (var_str ("$correlation_me_method"), method) call blha_master%set_methods (.true., var_list) call blha_master%allocate_config_files () call blha_master%set_correction_type (correction_type) call blha_master%generate (proc_id, model, n_in, & alpha_power, alphas_power, flv_born, flv_real) if (polrzd) then do i = 1, 4 call blha_master%set_polarization (i) end do end if call blha_master%setup_additional_features & (openloops_phs_tolerance, .false., 0) call test_output (u) contains subroutine test_output (u) integer, intent(in) :: u do i = 1, 4 call write_separator (u) call write_component_type (i, u) call write_separator (u) call blha_configuration_write & (blha_master%blha_cfg(i), blha_master%suffix(i), u, no_version = .true.) end do end subroutine test_output subroutine write_component_type (i, u) integer, intent(in) :: i, u type(string_t) :: message, component_type message = var_str ("OLP-File content for ") select case (i) case (1) component_type = var_str ("loop") case (2) component_type = var_str ("subtraction") case (3) component_type = var_str ("real") case (4) component_type = var_str ("born") end select message = message // component_type // " matrix elements" write (u, "(A)") char (message) end subroutine write_component_type end subroutine setup_and_write_blha_configuration @ %def setup_and_write_blha_configuration @ <>= public :: blha_1 <>= subroutine blha_1 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: blha_1" write (u, "(A)") "* Purpose: Test the creation of olp-files for single "& &"and unpolarized flavor structures" write (u, "(A)") call setup_and_write_blha_configuration (u, single = .true., polarized = .false.) end subroutine blha_1 @ %def blha_1 @ <>= public :: blha_2 <>= subroutine blha_2 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: blha_2" write (u, "(A)") "* Purpose: Test the creation of olp-files for multiple "& &"and unpolarized flavor structures" write (u, "(A)") call setup_and_write_blha_configuration (u, single = .false., polarized = .false.) end subroutine blha_2 @ %def blha_2 @ <>= public :: blha_3 <>= subroutine blha_3 (u) integer, intent(in) :: u write (u, "(A)") "* Test output: blha_3" write (u, "(A)") "* Purpose: Test the creation of olp-files for single "& &"and polarized flavor structures" write (u, "(A)") call setup_and_write_blha_configuration (u, single = .true., polarized = .true.) end subroutine blha_3 @ %def blha_3 @